DBD-Pg-2.19.3/0000755000076400007640000000000012014741170011202 5ustar greggregDBD-Pg-2.19.3/dbivport.h0000644000076400007640000000374011642756716013232 0ustar greggreg/* dbivport.h Provides macros that enable greater portability between DBI versions. This file should be *copied* and included in driver distributions and #included into the source, after #include DBIXS.h New driver releases should include an updated copy of dbivport.h from the most recent DBI release. */ #ifndef DBI_VPORT_H #define DBI_VPORT_H #ifndef DBIh_SET_ERR_CHAR /* Emulate DBIh_SET_ERR_CHAR Only uses the err_i, errstr and state parameters. */ #define DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method) \ sv_setiv(DBIc_ERR(imp_xxh), err_i); \ (state) ? (void)sv_setpv(DBIc_STATE(imp_xxh), state) : (void)SvOK_off(DBIc_STATE(imp_xxh)); \ sv_setpv(DBIc_ERRSTR(imp_xxh), errstr) #endif #ifndef DBIcf_Executed #define DBIcf_Executed 0x080000 #endif #ifndef DBIc_TRACE_LEVEL_MASK #define DBIc_TRACE_LEVEL_MASK 0x0000000F #define DBIc_TRACE_FLAGS_MASK 0xFFFFFF00 #define DBIc_TRACE_SETTINGS(imp) (DBIc_DBISTATE(imp)->debug) #define DBIc_TRACE_LEVEL(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_LEVEL_MASK) #define DBIc_TRACE_FLAGS(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_FLAGS_MASK) /* DBIc_TRACE_MATCHES - true if s1 'matches' s2 (c.f. trace_msg()) DBIc_TRACE_MATCHES(foo, DBIc_TRACE_SETTINGS(imp)) */ #define DBIc_TRACE_MATCHES(s1, s2) \ ( ((s1 & DBIc_TRACE_LEVEL_MASK) >= (s2 & DBIc_TRACE_LEVEL_MASK)) \ || ((s1 & DBIc_TRACE_FLAGS_MASK) & (s2 & DBIc_TRACE_FLAGS_MASK)) ) /* DBIc_TRACE - true if flags match & DBI level>=flaglevel, or if DBI level>level DBIc_TRACE(imp, 0, 0, 4) = if level >= 4 DBIc_TRACE(imp, DBDtf_FOO, 2, 4) = if tracing DBDtf_FOO & level>=2 or level>=4 DBIc_TRACE(imp, DBDtf_FOO, 2, 0) = as above but never trace just due to level */ #define DBIc_TRACE(imp, flags, flaglevel, level) \ ( (flags && (DBIc_TRACE_FLAGS(imp) & flags) && (DBIc_TRACE_LEVEL(imp) >= flaglevel)) \ || (level && DBIc_TRACE_LEVEL(imp) >= level) ) #endif #endif /* !DBI_VPORT_H */ DBD-Pg-2.19.3/META.yml0000644000076400007640000000310512014725553012461 0ustar greggreg--- #YAML:1.0 name : DBD-Pg version : 2.19.3 abstract : DBI PostgreSQL interface author: - Greg Sabino Mullane license : perl distribution_type : module dynamic_config : 1 requires: DBI : 1.52 perl : 5.006001 version : 0 build_requires: DBI : 1.52 Test::More : 0.61 Time::HiRes : 0 version : 0 configure_requires: DBI : 1.52 version : 0 recommends: Cwd : 0 Encode : 0 File::Temp : 0 Module::Signature : 0.50 provides: DBD::Pg: file : Pg.pm version : 2.19.3 Bundle::DBD::Pg: file : lib/Bundle/DBD/Pg.pm version : 2.19.3 keywords: - Postgres - PostgreSQL - DBI - libpq - dbdpg resources: homepage : http://search.cpan.org/dist/DBD-Pg/ license : http://dev.perl.org/licenses/ bugtracker : http://rt.cpan.org/Public/Dist/Display.html?Name=DBD-Pg repository : git://bucardo.org/dbdpg.git MailingList : http://www.nntp.perl.org/group/perl.dbd.pg/ meta-spec: version : 1.4 url : http://module-build.sourceforge.net/META-spec-v1.4.html generated_by : emacs DBD-Pg-2.19.3/SIGNATURE0000644000076400007640000000701412014741104012465 0ustar greggregThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.68. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: RIPEMD160 SHA1 c2fd448ad2624dcf8c2556ed96c9b96b93226861 .perlcriticrc SHA1 9979d6215733e2ee6ffea338ad78f42e732fd503 Changes SHA1 21bc5f3c797d4d5b72285198ffeb1e4e1f0a2902 LICENSES/artistic.txt SHA1 06877624ea5c77efe3b7e39b0f909eda6e25a4ec LICENSES/gpl-2.0.txt SHA1 117e5883538d3a9bcdb7b4f015ae0b3ae060c0fe MANIFEST SHA1 8d2857ee9a6326c08507d8552f86709dd068fbe5 MANIFEST.SKIP SHA1 9246e6deff6836d67a7cb8a2147e6c9401edca78 META.yml SHA1 a9387491ff695b2d738dda00dbb7c3e44c36474b Makefile.PL SHA1 6a27537e7ca0f502f1ef4576a8e8ceb729521476 Pg.h SHA1 2bad7aa2f5931e91c2d483e4c9eefd869b2e667b Pg.pm SHA1 b941c69074e649ba9a934864ef247a1bbb47a336 Pg.xs SHA1 4507190c55c2ded0a1b9f2a380fa700cbeeed9f1 README SHA1 c3c6f2f05e24486af075dca95f442c8c3c119bad README.dev SHA1 7e213bf90f513595b59c0a2c4ef94fea1592efcf README.win32 SHA1 7ed6f5dc8cef944cf07228e2769663d0c74cf668 TODO SHA1 cc2ffbfc02f4125fef1b7fc2b369d9314559f5e7 dbdimp.c SHA1 26562b3b5f8abf26547381975dd3ed60e48ab36b dbdimp.h SHA1 6c33bcf138e577722283bef02fceb8cbce4d100d dbivport.h SHA1 f417a1bcaf4dbf180cf037343bf108def5923747 lib/Bundle/DBD/Pg.pm SHA1 82c1cc1b15a55e0b553165ea4dd6cfff2bb008a4 quote.c SHA1 7ccff1056809e35bcc1a3ff4f5a3d337f207681f quote.h SHA1 93aa7e8cae0a361d1e6163dea0281ebff41f3c5f t/00_signature.t SHA1 073baf503a601ceeb49516d61bd275f0c1e51563 t/00basic.t SHA1 1f50adea4f2c7a5110eca34dc8b6d5dc9d4121ed t/01connect.t SHA1 ce0b281693d4b8309a7a4e7a07ec6f898d937e60 t/01constants.t SHA1 42b9933a52e9a95051aa06f5556559c7272d5901 t/02attribs.t SHA1 58e6cbdec408ea4d298ab81347ce38797527eccd t/03dbmethod.t SHA1 d5d619fb3c1df974b9e8b2f85df2c8ff8dc54f48 t/03smethod.t SHA1 5ff94b9b67a90dbc8a5ff4f01ef7d1ef716018f0 t/04misc.t SHA1 b7b72e0a9569e97e97975ea12e4adbc99a50d076 t/06bytea.t SHA1 c4c43b2229411c3850de0a9cb9bae8e5ccc7d822 t/07copy.t SHA1 e6fe3d9c739d31f344c4a56382004a97202e4d51 t/08async.t SHA1 a78b82d35ab294149decacc160a468d8d94fa434 t/09arrays.t SHA1 519aa6a52d58f77515b62127066ca3b7ea09677a t/12placeholders.t SHA1 81558ca5c783ea6792fd103444a04df615a8d127 t/20savepoints.t SHA1 dfef0062e9549b2cad7b429c7214734ab6ab5a4a t/99cleanup.t SHA1 1e10fbc9aa1b11523e8f477a4afbeffbe47e6b1b t/dbdpg_test_setup.pl SHA1 96edfd4f4165c50f98353f800fbd182555762a0c t/lib/App/Info.pm SHA1 b3349a313289db245720d0a3c7446662e9b6af33 t/lib/App/Info/Handler.pm SHA1 a669fab6421aa2a8385f33b0e90efcd3d7040415 t/lib/App/Info/Handler/Prompt.pm SHA1 d3e9a478612e570c0b9af03f99e987ba01a6e36e t/lib/App/Info/RDBMS.pm SHA1 2fa62674d3121d67ff9c1d6aee844a1a8bf62088 t/lib/App/Info/RDBMS/PostgreSQL.pm SHA1 ef601a037cd4c9866ae4922298418b92b203ab47 t/lib/App/Info/Request.pm SHA1 108f10ce0dc3657a706861d57f4f8bcddabf2ada t/lib/App/Info/Util.pm SHA1 0dca94a106eea0bf988039d05e20560e70897dd7 testme.tmp.pl SHA1 191e3d66b5e0c71cf520076d1322b6309560bcd0 types.c SHA1 3346dfbefe3a9af077276fb412e42281306577d2 types.h SHA1 f07cd5ecaeb854c81ceb9206364979cf607e6546 win32.mak -----BEGIN PGP SIGNATURE----- iEYEAREDAAYFAlAzwkQACgkQvJuQZxSWSsgvjQCfXr+9jChSxl9gAk/OmNBEECCQ GUkAmwbKrc6eGsiRGeWzcx/14fLVyvG0 =uw+B -----END PGP SIGNATURE----- DBD-Pg-2.19.3/LICENSES/0000755000076400007640000000000012014741170012407 5ustar greggregDBD-Pg-2.19.3/LICENSES/gpl-2.0.txt0000644000076400007640000004310311642756716014252 0ustar greggreg GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 Lesser 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 Lesser General Public License instead of this License. DBD-Pg-2.19.3/LICENSES/artistic.txt0000644000076400007640000001517211642756716015022 0ustar greggreg The Artistic License August 15, 1997 Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a. place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b. use the modified Package only within your corporation or organization. c. rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d. make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a. distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b. accompany the distribution with the machine-readable source of the Package with your modifications. c. give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d. make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End DBD-Pg-2.19.3/dbdimp.h0000644000076400007640000002345011726452761012634 0ustar greggreg/* Copyright (c) 2000-2012 Greg Sabino Mullane and others: see the Changes file Portions Copyright (c) 1997-2000 Edmund Mergl Portions Copyright (c) 1994-1997 Tim Bunce You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. */ /* Define drh implementor data structure */ struct imp_drh_st { dbih_drc_t com; /* MUST be first element in structure */ }; /* Define dbh implementor data structure */ struct imp_dbh_st { dbih_dbc_t com; /* MUST be first element in structure */ int pg_protocol; /* value of PQprotocolVersion, usually 3 (could also be 0) */ int pg_server_version; /* server version e.g. 80100 */ int pid_number; /* prefixed before prepare_number */ int prepare_number; /* internal prepared statement name modifier */ int copystate; /* 0=none PGRES_COPY_IN PGRES_COPY_OUT */ int pg_errorlevel; /* PQsetErrorVerbosity. Set by user, defaults to 1 */ int server_prepare; /* do we want to use PQexecPrepared? 0=no 1=yes 2=smart. Can be changed by user */ int async_status; /* 0=no async 1=async started -1=async has been cancelled */ imp_sth_t *async_sth; /* current async statement handle */ AV *savepoints; /* list of savepoints */ PGconn *conn; /* connection structure */ char *sqlstate; /* from the last result */ bool pg_bool_tf; /* do bools return 't'/'f'? Set by user, default is 0 */ bool pg_enable_utf8; /* should we attempt to make utf8 strings? Set by user, default is 0 */ bool prepare_now; /* force immediate prepares, even with placeholders. Set by user, default is 0 */ bool done_begin; /* have we done a begin? (e.g. are we in a transaction?) */ bool dollaronly; /* only consider $1, $2 ... as valid placeholders */ bool expand_array; /* transform arrays from the db into Perl arrays? Default is 1 */ bool txn_read_only; /* are we in read-only mode? Set with $dbh->{ReadOnly} */ }; /* Each statement is broken up into segments */ struct seg_st { char *segment; /* non-placeholder string segment */ int placeholder; /* which placeholder this points to, 0=none */ struct ph_st *ph; /* points to the relevant ph structure */ struct seg_st *nextseg; /* linked lists are fun */ }; typedef struct seg_st seg_t; /* The placeholders are also a linked list */ struct ph_st { char *fooname; /* name if using :foo style */ char *value; /* the literal passed-in value, may be binary */ STRLEN valuelen; /* length of the value */ char *quoted; /* quoted version of the value, for PQexec only */ STRLEN quotedlen; /* length of the quoted value */ bool referenced; /* used for PREPARE AS construction */ bool defaultval; /* is it using a generic 'default' value? */ bool iscurrent; /* do we want to use a literal CURRENT_TIMESTAMP? */ bool isdefault; /* are we passing a literal 'DEFAULT'? */ bool isinout; /* is this a bind_param_inout value? */ SV *inout; /* what variable we are updating via inout magic */ sql_type_info_t* bind_type; /* type information for this placeholder */ struct ph_st *nextph; /* more linked list goodness */ }; typedef struct ph_st ph_t; /* Define sth implementor data structure */ struct imp_sth_st { dbih_stc_t com; /* MUST be first element in structure */ int server_prepare; /* inherited from dbh. 3 states: 0=no 1=yes 2=smart */ int placeholder_type; /* which style is being used 1=? 2=$1 3=:foo */ int numsegs; /* how many segments this statement has */ int numphs; /* how many placeholders this statement has */ int numbound; /* how many placeholders were explicitly bound by the client, not us */ int cur_tuple; /* current tuple being fetched */ int rows; /* number of affected rows */ int async_flag; /* async? 0=no 1=async 2=cancel 4=wait */ int async_status; /* 0=no async 1=async started -1=async has been cancelled */ STRLEN totalsize; /* total string length of the statement (with no placeholders)*/ const char ** PQvals; /* List of values to pass to PQ* */ int * PQlens; /* List of lengths to pass to PQ* */ int * PQfmts; /* List of formats to pass to PQ* */ Oid * PQoids; /* List of types to pass to PQ* */ char *prepare_name; /* name of the prepared query; NULL if not prepared */ char *firstword; /* first word of the statement */ PGresult *result; /* result structure from the executed query */ sql_type_info_t **type_info; /* type of each column in result */ seg_t *seg; /* linked list of segments */ ph_t *ph; /* linked list of placeholders */ bool prepare_now; /* prepare this statement right away, even if it has placeholders */ bool prepared_by_us; /* false if {prepare_name} set directly */ bool onetime; /* this statement is guaranteed not to be run again - so don't use SSP */ bool direct; /* allow bypassing of the statement parsing */ bool is_dml; /* is this SELECT/INSERT/UPDATE/DELETE? */ bool has_binary; /* does it have one or more binary placeholders? */ bool has_default; /* does it have one or more 'DEFAULT' values? */ bool has_current; /* does it have one or more 'DEFAULT' values? */ bool dollaronly; /* Only use $1 as placeholders, allow all else */ bool use_inout; /* Any placeholders using inout? */ bool all_bound; /* Have all placeholders been bound? */ }; /* Avoid name clashes by assigning DBI funcs to a pg_ name. */ /* In order of appearance in dbdimp.c */ #define dbd_init pg_init extern void dbd_init (dbistate_t *dbistate); #define dbd_db_login6 pg_db_login6 int dbd_db_login6 (SV * dbh, imp_dbh_t * imp_dbh, char * dbname, char * uid, char * pwd, SV *attr); #define dbd_db_ping pg_db_ping int dbd_db_ping(SV *dbh); #define dbd_db_commit pg_db_commit int dbd_db_commit (SV * dbh, imp_dbh_t * imp_dbh); #define dbd_db_rollback pg_db_rollback int dbd_db_rollback (SV * dbh, imp_dbh_t * imp_dbh); #define dbd_db_disconnect pg_db_disconnect int dbd_db_disconnect (SV * dbh, imp_dbh_t * imp_dbh); #define dbd_db_destroy pg_db_destroy void dbd_db_destroy (SV * dbh, imp_dbh_t * imp_dbh); #define dbd_db_FETCH_attrib pg_db_FETCH_attrib SV * dbd_db_FETCH_attrib (SV * dbh, imp_dbh_t * imp_dbh, SV * keysv); #define dbd_db_STORE_attrib pg_db_STORE_attrib int dbd_db_STORE_attrib (SV * dbh, imp_dbh_t * imp_dbh, SV * keysv, SV * valuesv); #define dbd_st_FETCH_attrib pg_st_FETCH_attrib SV * dbd_st_FETCH_attrib (SV * sth, imp_sth_t * imp_sth, SV * keysv); #define dbd_st_STORE_attrib pg_st_STORE_attrib int dbd_st_STORE_attrib (SV * sth, imp_sth_t * imp_sth, SV * keysv, SV * valuesv); #define dbd_discon_all pg_discon_all int dbd_discon_all (SV * drh, imp_drh_t * imp_drh); #define dbd_st_prepare pg_st_prepare int dbd_st_prepare (SV * sth, imp_sth_t * imp_sth, char * statement, SV * attribs); #define dbd_bind_ph pg_bind_ph int dbd_bind_ph (SV * sth, imp_sth_t * imp_sth, SV * ph_name, SV * newvalue, IV sql_type, SV * attribs, int is_inout, IV maxlen); #define dbd_st_execute pg_st_execute int dbd_st_execute (SV * sth, imp_sth_t * imp_sth); #define dbd_st_fetch pg_st_fetch AV * dbd_st_fetch (SV * sth, imp_sth_t * imp_sth); #define dbd_st_rows pg_st_rows int dbd_st_rows (SV * sth, imp_sth_t * imp_sth); #define dbd_st_finish pg_st_finish int dbd_st_finish (SV * sth, imp_sth_t * imp_sth); #define dbd_st_cancel pg_st_cancel int dbd_st_cancel (SV * sth, imp_sth_t * imp_sth); #define dbd_st_destroy pg_st_destroy void dbd_st_destroy (SV * sth, imp_sth_t * imp_sth); #define dbd_st_blob_read pg_st_blob_read int dbd_st_blob_read (SV * sth, imp_sth_t * imp_sth, int lobjId, long offset, long len, SV * destrv, long destoffset); /* Everything else should map back to the DBI version, or be handled by Pg.pm TODO: Explicitly map out each one. */ /* Custom PG functions, in order they appear in dbdimp.c */ int pg_db_getfd (imp_dbh_t * imp_dbh); SV * pg_db_pg_notifies (SV *dbh, imp_dbh_t *imp_dbh); SV * pg_stringify_array(SV * input, const char * array_delim, int server_version); int pg_quickexec (SV *dbh, const char *sql, const int asyncflag); int pg_db_putline (SV *dbh, const char *buffer); int pg_db_getline (SV *dbh, SV * svbuf, int length); int pg_db_getcopydata (SV *dbh, SV * dataline, int async); int pg_db_putcopydata (SV *dbh, SV * dataline); int pg_db_putcopyend (SV * dbh); int pg_db_endcopy (SV * dbh); void pg_db_pg_server_trace (SV *dbh, FILE *fh); void pg_db_pg_server_untrace (SV *dbh); int pg_db_savepoint (SV *dbh, imp_dbh_t *imp_dbh, char * savepoint); int pg_db_rollback_to (SV *dbh, imp_dbh_t *imp_dbh, const char * savepoint); int pg_db_release (SV *dbh, imp_dbh_t *imp_dbh, char * savepoint); unsigned int pg_db_lo_creat (SV *dbh, int mode); int pg_db_lo_open (SV *dbh, unsigned int lobjId, int mode); int pg_db_lo_close (SV *dbh, int fd); int pg_db_lo_read (SV *dbh, int fd, char *buf, size_t len); int pg_db_lo_write (SV *dbh, int fd, char *buf, size_t len); int pg_db_lo_lseek (SV *dbh, int fd, int offset, int whence); int pg_db_lo_tell (SV *dbh, int fd); int pg_db_lo_unlink (SV *dbh, unsigned int lobjId); unsigned int pg_db_lo_import (SV *dbh, char *filename); unsigned int pg_db_lo_import_with_oid (SV *dbh, char *filename, unsigned int lobjId); int pg_db_lo_export (SV *dbh, unsigned int lobjId, char *filename); int pg_db_result (SV *h, imp_dbh_t *imp_dbh); int pg_db_ready(SV *h, imp_dbh_t *imp_dbh); int pg_db_cancel (SV *h, imp_dbh_t *imp_dbh); int pg_db_cancel_sth (SV *sth, imp_sth_t *imp_sth); /* end of dbdimp.h */ DBD-Pg-2.19.3/Makefile.PL0000644000076400007640000002460512014725544013172 0ustar greggreguse ExtUtils::MakeMaker; use Config; use strict; use warnings; use 5.006001; ## No version.pm for this one, as the prereqs are not loaded yet. my $VERSION = '2.19.3'; ## App::Info is stored inside t/lib ## Create a proper path so we can use it below my $lib; BEGIN { use vars qw/$sep/; my %sep = ( MacOS => ':', MSWin32 => '\\', os2 => '\\', VMS => '\\', NetWare => '\\', dos => '\\', ); $sep = $sep{$^O} || '/'; $lib = join $sep, 't', 'lib'; } use lib $lib; if ($VERSION =~ /_/) { print "WARNING! This is a test version ($VERSION) and should not be used in production!\n"; } if (grep { /help/ } @ARGV) { print qq{ Usage: perl $0 No other options are necessary, although you may need to set some evironment variables. See the README file for full details. In brief: By default Makefile.PL uses App::Info to find the location of the PostgreSQL library and include directories. However, if you want to control it yourself, define the environment variables POSTGRES_INCLUDE and POSTGRES_LIB, or define just POSTGRES_HOME. Note that if you have compiled PostgreSQL with SSL support, you must define the POSTGRES_LIB environment variable and add "-lssl" to it, like this: export POSTGRES_LIB="/usr/local/pgsql/lib -lssl" The usual steps to install DBD::Pg: 1. perl Makefile.PL 2. make 3. make test 4. make install Do steps 1 to 3 as a normal user, not as root! If all else fails, email dbd-pg\@perl.org for help. }; exit 1; } print "Configuring DBD::Pg $VERSION\n"; my $POSTGRES_INCLUDE; my $POSTGRES_LIB; # We need the version information to properly set compiler options later # Use App::Info to get the data we need. require App::Info::RDBMS::PostgreSQL; require App::Info::Handler::Prompt; my $p = App::Info::Handler::Prompt->new; my $pg = App::Info::RDBMS::PostgreSQL->new(on_unknown => $p); my ($major_ver, $minor_ver, $patch, $conf, $bindir) = map {$pg->$_} qw/major_version minor_version patch_version configure bin_dir/; my $initdb = ''; if (defined $bindir and -d $bindir) { my $testinitdb = "$bindir${sep}initdb"; if (-e $testinitdb) { $initdb = $testinitdb; } } my $serverversion = 0; my $defaultport = 0; if (defined $major_ver) { $serverversion = sprintf '%d%.02d%.02d', $major_ver, $minor_ver, $patch; $defaultport = $conf =~ /with-pgport=(\d+)/ ? $1 : 5432; } # We set POSTGRES_INCLUDE and POSTGRES_LIB from the first found of: # 1. environment variable # 2. App::Info::RDBMS::PostgreSQL information # 3. subdirectory of $ENV{POSTGRES_HOME} $POSTGRES_INCLUDE = $ENV{POSTGRES_INCLUDE} || $pg->inc_dir || "$ENV{POSTGRES_HOME}/include"; $POSTGRES_LIB = $ENV{POSTGRES_LIB} || $pg->lib_dir || "$ENV{POSTGRES_HOME}/lib"; my $os = $^O; print "PostgreSQL version: $serverversion (default port: $defaultport)\n"; my $showhome = $ENV{POSTGRES_HOME} || '(not set)'; print "POSTGRES_HOME: $showhome\n"; my $showinc = $POSTGRES_INCLUDE || '(not set)'; print "POSTGRES_INCLUDE: $showinc\n"; my $showlib = $POSTGRES_LIB || '(not set)'; print "POSTGRES_LIB: $showlib\n"; print "OS: $os\n"; my $baddir = 0; sub does_path_exist { my ($path_name, $path) = @_; return if ! defined $path or ! length $path or -d $path; printf "The value of %s points to a non-existent directory: %s\n", $path_name, $path; $baddir++; return; } does_path_exist('POSTGRES_HOME', $ENV{POSTGRES_HOME}); does_path_exist('POSTGRES_INCLUDE', $POSTGRES_INCLUDE); if ($baddir) { print "Cannot build unless the directories exist, exiting.\n"; exit 0; } if ($serverversion < 11) { print "Could not determine the PostgreSQL library version.\n". "Please ensure that a valid path is given to the 'pg_config' command,\n". "either manually or by setting the environment variables\n". "POSTGRES_DATA, POSTGRES_INCLUDE, and POSTGRES_LIB\n"; exit 0; } if ($os =~ /Win32/) { for ($POSTGRES_INCLUDE, $POSTGRES_LIB) { $_ = qq{"$_"} if index $_,'"'; } } ## Warn about older versions if ($serverversion < 70400) { print "\n****************\n"; print "WARNING! DBD::Pg no longer supports versions less than 7.4.\n"; print "You must upgrade PostgreSQL to a newer version.\n"; print "****************\n\n"; exit 1; } my $dbi_arch_dir; { eval { require DBI::DBD; }; if ($@) { print "Could not load DBI::DBD - is the DBI module installed?\n"; exit 0; } local *STDOUT; ## Prevent duplicate debug info as WriteMakefile also calls this $dbi_arch_dir = DBI::DBD::dbd_dbi_arch_dir(); } my $defines = " -DPGLIBVERSION=$serverversion -DPGDEFPORT=$defaultport"; my $comp_opts = $Config{q{ccflags}} . $defines; if ($ENV{DBDPG_GCCDEBUG}) { warn "Enabling many compiler options\n"; $comp_opts .= ' -Wchar-subscripts -Wcomment'; $comp_opts .= ' -Wformat=2'; ## does -Wformat,-Wformat-y2k,-Wformat-nonliteral,-Wformat-security $comp_opts .= ' -Wnonnull'; $comp_opts .= ' -Wuninitialized -Winit-self'; ## latter requires the former $comp_opts .= ' -Wimplicit'; ## does -Wimplicit-int and -Wimplicit-function-declaration $comp_opts .= ' -Wmain -Wmissing-braces -Wparentheses -Wsequence-point -Wreturn-type -Wswitch -Wswitch-enum -Wtrigraphs'; $comp_opts .= ' -Wunused'; ## contains -Wunused- function,label,parameter,variable,value $comp_opts .= ' -Wunknown-pragmas -Wstrict-aliasing'; $comp_opts .= ' -Wall'; ## all of above, but we enumerate anyway $comp_opts .= ' -Wextra -Wdeclaration-after-statement -Wendif-labels -Wpointer-arith'; $comp_opts .= ' -Wbad-function-cast -Wcast-qual -Wcast-align -Wsign-compare -Waggregate-return'; $comp_opts .= ' -Wmissing-prototypes -Wmissing-declarations -Wmissing-format-attribute -Wpacked -Winline -Winvalid-pch'; $comp_opts .= ' -Wdisabled-optimization'; $comp_opts .= ' -Wnested-externs'; $comp_opts .= " -Wstrict-prototypes"; ## Still hits a couple places in types.h $comp_opts .= " -Wswitch-default"; $comp_opts .= " -Wsystem-headers"; $comp_opts .= " -Wmissing-noreturn"; $comp_opts .= " -Wfloat-equal"; ## Does not like SvTRUE() calls $comp_opts .= " -Wpadded"; ## Use when adding/changing our structs } my %opts = ( NAME => 'DBD::Pg', VERSION_FROM => 'Pg.pm', INC => "-I$POSTGRES_INCLUDE -I$dbi_arch_dir", OBJECT => "Pg\$(OBJ_EXT) dbdimp\$(OBJ_EXT) quote\$(OBJ_EXT) types\$(OBJ_EXT)", LIBS => ["-L$POSTGRES_LIB -lpq -lm"], AUTHOR => 'Greg Sabino Mullane', ABSTRACT => 'PostgreSQL database driver for the DBI module', PREREQ_PM => { 'ExtUtils::MakeMaker' => '6.11', 'DBI' => '1.52', 'Test::More' => '0.61', 'Time::HiRes' => '0', 'version' => '0', }, CCFLAGS => $comp_opts, PERL_MALLOC_OK => 1, NEEDS_LINKING => 1, NO_META => 1, NORECURS => 1, clean => { FILES => 'trace Pg.xsi README.testdatabase' }, realclean => { FILES => 'dbdpg_test_database/' }, ); if ($os eq 'hpux') { my $osvers = $Config{osvers}; if ($osvers < 10) { print "Warning: Forced to build static not dynamic on $os $osvers.\a\n"; $opts{LINKTYPE} = 'static'; } } elsif ($os =~ /Win32/) { my $msdir = $POSTGRES_LIB; $msdir =~ s{"$}{/ms"}; $opts{LIBS}[0] .= " -L$msdir -lsecur32"; } if ($Config{dlsrc} =~ /dl_none/) { $opts{LINKTYPE} = 'static'; } { package MY; ## no critic sub MY::test { ## no critic my $string = shift->SUPER::test(@_); $string =~ s/(PERL_DL_NONLAZY=1)/PGINITDB="$initdb" $1/g; return $string; } } sub constants { my $self = shift; my $old_constants = $self->SUPER::constants(); my $new_constants = ''; for my $line (split /\n/ => $old_constants) { if ($line =~ /^INC = .*strawberry.*/ ) { print qq(Strawberry Perl found; adjusting the INC variable;\n); $line . ' -I ' . DBI::DBD::dbd_dbi_arch_dir(); print qq(INC is now $line\n); } $new_constants .= "$line\n"; } return $new_constants; } sub MY::postamble { ## no critic ProhibitQualifiedSubDeclarations no strict 'subs'; ## no critic ProhibitNoStrict my $string = DBI::DBD->dbd_postamble(); use strict 'subs'; ## Evil, evil stuff - but we really want to suppress the "duplicate function" message! $string =~ s/dependancy/dependency/g; ## why not, while we are here $string =~ s{(BASEEXT\)/g)}{$1; s/^do\\\(/dontdo\\\(/}; my $tags = <<'MAKE_FRAG'; .PHONY: tags tags: ctags -f tags --recurse --totals \ --exclude=blib \ --exclude=.git \ --exclude='*~' \ --languages=Perl,C --langmap=c:+.h,Perl:+.t \ MAKE_FRAG $string = "$string\n$tags\n"; $string .= <<'MAKE_SPLINT'; ## This must be version 3.1.2 or better: earlier versions have many ## problems parsing the DBI header files SPLINT = splint ## Temp directory, for use with +keep SPLINT_TMP = $(TMP)/splint_dbdpg SPLINTFLAGS = \ -message-stream-stdout \ -linelen 90 \ -boolops \ -tmpdir $(SPLINT_TMP) \ +posixstrictlib \ +ignoresigns \ +showdeephistory \ -predboolint \ -nullpass \ +charint \ +boolint \ +allglobals \ SPLINTFLAGS_TEST = SDEFINES = splint: $(H_FILES) $(C_FILES) $(MKPATH) $(SPLINT_TMP) $(SPLINT) $(SPLINTFLAGS) $(SPLINTFLAGS_TEST) $(SDEFINES) -I$(PERL_INC) $(INC) $(C_FILES) MAKE_SPLINT $string =~ s/SDEFINES = /SDEFINES =$defines/; return $string; } my $output = WriteMakefile(%opts); if (!exists $output->{EXTRALIBS} or ($output->{EXTRALIBS} !~ /\-lpq/ and $output->{EXTRALIBS} !~ /libpq/)) { my $makefile = exists $output->{MAKEFILE} ? "\nRemoving ($output->{MAKEFILE})\n" : ''; warn qq{ ========================================================== WARNING! No libpq libraries were detected! You need to install the postgresql-libs package for your system, or set the POSTGRES_LIB environment variable to the correct place. $makefile =========================================================== }; ## Do not let make proceed unlink $output->{MAKEFILE} if $makefile; exit 1; } exit 0; # end of Makefile.PL DBD-Pg-2.19.3/README0000644000076400007640000002732612014725566012107 0ustar greggregDBD::Pg is Copyright (C) 1994-2012, Greg Sabino Mullane DBD::Pg -- the DBI PostgreSQL interface for Perl DESCRIPTION: ------------ This is version 2.19.3 of DBD::Pg, the Perl interface to Postgres using DBI. The web site for this interface, and the latest version, can be found at: http://search.cpan.org/dist/DBD-Pg/ The mailing list is at: http://www.nntp.perl.org/group/perl.dbd.pg/ The development of DBD::Pg can be tracked at: git://bucardo.org/dbdpg.git For information about PostgreSQL, visit: http://www.postgresql.org/ For information on what has changed for each version, see the Changes files. REQUIREMENTS: ------------- build, test, and install Perl 5 (at least 5.6.1) build, test, and install the DBI module (at least 1.52) build, test, and install PostgreSQL (at least 7.4) build, test, and install Test::Simple (at least 0.47) DBD::Pg needs to know where to find the libpq libraries: this is usually done by checking the output of the pg_config executable. If pg_config is not available, then you may need to install the development package for PostgreSQL. To do this on Debian and Ubuntu, use: apt-get install postgresql-dev; on RedHat and CentOS, use: yum install postgresql-devel. Note that the development libraries are needed even if you already have PostgreSQL up and running. IF YOU HAVE PROBLEMS OR COMMENTS: --------------------------------- Please send any problems and comments to Please include what OS you are using, and the version of Perl, DBI, and DBD::Pg you are using. Also tell which version of PostgreSQL DBD::Pg was compiled against, and which version you are connecting to. The easiest way to gather all of this information is to run "make test", which outputs it all early in the tests. You can also try the #postgresql channel on irc.freenode.net, which usually (but not always) has people who can help you with DBD::Pg. BUG REPORTS: ----------- If you feel certain you have found a bug, you can file a bug report by visiting: http://rt.cpan.org/Public/Dist/Display.html?Name=DBD-Pg and selecting the "Report a new bug" link. Please check that the bug has not already been reported first. PATCHES: -------- Patches are always welcome: the best way is to attach a git diff output to a bug report at the above URL for rt.cpan.org. Feel free to ask for a commit bit as well, if you think you might be patching more than once. :) INSTALLATION: ------------- Before installing, please use the "cpansign -v" program to cryptographically verify that your copy of DBD::Pg is complete and valid. The program "cpansign" is part of Module::Signature, available from CPAN. By default Makefile.PL uses App::Info to find the location of the PostgreSQL library and include directories. However, if you want to control it yourself, define the environment variables POSTGRES_INCLUDE and POSTGRES_LIB, or define just POSTGRES_HOME. Note that if you have compiled PostgreSQL with SSL support, you must define the POSTGRES_LIB environment variable and add "-lssl" and "-lcrypto" to it, like this: export POSTGRES_LIB="/usr/local/pgsql/lib -lssl -lcrypto" The usual steps to install DBD::Pg: 1. perl Makefile.PL 2. make 3. make test 4. make install Do steps 1 to 2 as a normal user, not as root! If the script cannot find the pg_config information itself, it will ask you for the path to it. Enter the complete path to the pg_config file here, including the name of the file itself. TESTING: -------- The tests rely on being able to connect to a valid Postgres database. The easiest way to ensure this is to set the following environment variables: DBI_DSN=dbi:Pg:dbname= DBI_USER= DBI_PASS= If you are running on a non-standard port, you must set PGPORT or add the port to the DBI_DSN variable like this: DBI_DSN='dbi:Pg:dbname=;port=' Put double quotes around the dbname if it has a semicolon or a space inside of it: DBI_DSN='dbi:Pg:dbname=""' If no valid connection is found, the tests will use the "initdb" program to try and create a Postgres database cluster to test with. The first available port starting at 5440 will be used. You can increase the verbosity of the tests by setting the environment variable TEST_VERBOSE. You can also enable tracing within the tests themselves by setting DBD_TRACE to whatever trace level you want. Be aware that setting the trace level can result in extremely verbose output. When reporting test failures, please use TEST_VERBOSE=1, but do *not* set DBD_TRACE unless requested, and send only the relevant sections. Please consider installing CPAN::Reporter so that your tests are automatically gathered and reported, which helps the development of DBD::Pg. TROUBLESHOOTING: ---------------- * Placeholder issues If you find that some of your queries containing placeholders are no longer working, this may because DBD::Pg now uses the native PostgreSQL placeholders on the server itself whenever possible. Previously, DBD::Pg did a simple emulation of placeholders, so the rules were not as strict. You should either rewrite your queries to make them legal SQL syntax for PostgreSQL, or turn off server-side prepares. To change your queries, make sure that the type of each placeholder can be determined by the PostgreSQL parser. So instead of: SELECT ? use something like: SELECT ?::int To turn off server-side prepares completely (with a loss of some performance and features), do this at the top of your scripts: $dbh->{pg_server_prepare} = 0; This can also be set for individual queries at the statement handle level: see the documentation section on "Placeholders" for more details. * PostgreSQL library issues: DBD::Pg uses the libpq library that comes with Postgres. If the shared libpq library is not available, DBD::Pg will error with a message that usually mentions a file names libpq.so, like this: Can't load './blib/arch/auto/DBD/Pg/Pg.so' for module DBD::Pg: libpq.so.5: cannot open shared object file: No such file or directory at .../DynaLoader.pm line 230. This means that the libraries are not installed in a place where the system can find them when it tries to load the Pg.so file. On some systems, you can run /sbin/ldconfig -v to see a list of shared modules, or just search the system for the file with "locate libpq.so". If it exists but is not being loaded, you may need to add the directory it is in to /etc/ld.so.conf file and run the ldconfig command. Otherwise, you may need to add the path to the environment variable LD_LIBRARY_PATH. If you get an error message like: perl: error while loading shared libraries: /usr/lib/perl5/site_perl/5.6.1/i386-linux/auto/DBD/Pg/Pg.so: undefined symbol: PQconnectdb when you call DBI->connect, then your libpq.so was probably not seen at build-time. This should have caused 'make test' to fail; did you really run it and look at the output? * Perl issues: Some Linux distributions have incomplete perl installations. If you have compile errors like "XS_VERSION_BOOTCHECK undeclared", do: find .../lib/perl5 -name XSUB.h -print If this file is not present, you need to recompile and re-install perl. If you get a message about "use of uninitialized value in -d" when doing a "make install_vendor", you can work around this by adding a dummy value to the INSTALLVENDORBIN environment variable: make install_vendor INSTALLVENDORBIN=/tmp (thanks to Peter Eisentraut ) * Strawberry Perl issues: You'll need to create a .a library from the .dll before running the Makefile.PL, by running pexports and dlltool as shown below, within the C:\Program Files\PostgreSQL\8.3\bin directory: pexports libpq.dll > libpq.def dlltool -dllname libpq.dll --def libpq.def --output-lib ..\lib\libpq.a Then you'll need to set the required environment: set PATH=C:\PROGRA~1\PostgreSQL\8.3\bin;%PATH% set DBI_DSN=dbi:Pg:dbname=testdb set DBI_USER=*PostgreSQL username* set DBI_PASS=*PostgreSQL password* set POSTGRES_HOME=C:/PROGRA~1/PostgreSQL/8.3 set POSTGRES_INCLUDE=C:/PROGRA~1/PostgreSQL/8.3/include set POSTGRES_LIB=C:/PROGRA~1/PostgreSQL/8.3/lib Note that the username and password are the ones for PostgreSQL, NOT the ones for the Windows account that the PostgreSQL installer creates to run the service safely. (You may wish to set these variables on the system level, by going to Control Panel > System > Advanced tab > Environment Variables button and adding the environment variables there.) Now the Makefile.PL can be ran: perl Makefile.PL dmake dmake test dmake install * SGI issues: If you get segmentation faults, make sure you are using the malloc which comes with perl when compiling perl (the default is not to). (thanks to "David R. Noble" ) * HP issues: If you get error messages like: can't open shared library: .../lib/libpq.sl No such file or directory when running the test script, try to replace the 'shared' option in the LDDFLAGS with 'archive'. (thanks to Dan Lauterbach ) * FreeBSD issues: If you get during "make test" the error message: 'DBD driver has not implemented the AutoCommit attribute' recompile the DBI module and the DBD-Pg module and disable optimization. This error message is due to the broken optimization in gcc-2.7.2.1. If you get compiler errors like: In function `XS_DBD__Pg__dr_discon_all_' `sv_yes' undeclared (first use in this function) it may be because there is a 'patchlevel.h' file from another package (such as 'hdf') in your POSTGRES_INCLUDE dir. The presence of this file prevents the compiler from finding the perl include file 'mach/CORE/patchlevel.h'. Do 'pg_config --includedir' to identify the POSTGRES_INCLUDE dir. Rename patchlevel.h whilst you build DBD::Pg. * Sun issues: If you get compile errors like: /usr/include/string.h:57: parse error before `]' then you need to remove from pgsql/include/libpq-fe.h the define for strerror, which clashes with the definition in the standard include file. * Win32 issues: For installation, please see the README.win32 file. Running DBD-Pg scripts on Win32 needs some configuration work on the server side: o add a postgres user with the same name as the NT-User (e.g. Administrator) o make sure, that your pg_hba.conf on the server is configured, such that a connection from another host will be accepted * OS X issues: You may need to add "-lssl" and "-lcrypto" to your LIB variable before compiling. (thanks to ) If having problems compiling, try running: env -i command This trick stops 'command' from inheriting environment variables from the shell process, which more often than not fixes up such weird build errors without having to do anything else in particular. (thanks to David Landgren ) * SCO issues: If the 'make test' gives an error about a symbol not being found, you can correct the problem by manually running ld after the 'make' command: LD_RUN_PATH="/usr/local/pgsql/lib" ld -G -L/usr/local/lib Pg.o \ dbdimp.o -o blib/arch/auto/DBD/Pg/Pg.so -L/usr/local/pgsql/lib -lpq \ -L/opt/K/SKUNK2000/Gcc/2.95.2pl1/usr/local/lib/gcc-lib/i386-pc-sco3.2v5.0.5/2.95.2/ \ -lgcc Once this is done, 'make test' succeeds properly. (thanks to ) COPYRIGHT: ---------- Copyright (c) 2002-2012 Greg Sabino Mullane and others: see the Changes file Portions Copyright (c) 2002 Jeffrey W. Baker Portions Copyright (c) 1997-2001 Edmund Mergl Portions Copyright (c) 1994-1997 Tim Bunce LICENSE INFORMATION: -------------------- This module (DBD::Pg) is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. DBD-Pg-2.19.3/TODO0000644000076400007640000000305512004404674011701 0ustar greggregPossible items to do, in no particular order Feature requests can be entered at http://rt.cpan.org/Public/Dist/Display.html?Name=DBD-Pg - Don't automatically use server-side prepare until a threshold is reached, e.g. X number of executes. Make this a parameter. - Fix ping problem: http://www.cpantesters.org/cpan/report/53c5cc72-6d39-11e1-8b9d-82c3d2d9ea9f - Use WITH HOLD for cursor work - Devise a way to automatically create ppm for Windows builds - I8N docs and error messages - Change quote and dequote functions to take Sv instead of string so that things like arrays can be serialized by the quote function. This will take care of broken chopblanks and pg_bool_tf (pass the quote/dequote options struct to function quote/dequote functions) - Allow user callbacks to quote user-defined types - Revisit the use of version.pm - Test heavily with a thread-enabled Perl - Remove libpq dependency - Handle and/or better tests for different encoding, especially those not supported as a server encoding (e.g. BIG5) - Support passing hashrefs in and out for custom types. - Support a flag for behind-the-scenes CURSOR to emulate partial fetches. - Handle unicode conversion better and perhaps eliminate the need for the pg_enable_utf8 attribute. - Fix this: http://nntp.x.perl.org/group/perl.cpan.testers/2698430 - Composite type support: http://www.postgresql.org/docs/current/interactive/rowtypes.html - Full support for execute_array, e.g. the return values - Fix array support: execute([1,2]) not working as expected, deep arrays not returned correctly.DBD-Pg-2.19.3/t/0000755000076400007640000000000012014741170011445 5ustar greggregDBD-Pg-2.19.3/t/07copy.t0000644000076400007640000002303011642756716012773 0ustar greggreg#!perl ## Test the COPY functionality use 5.006; use strict; use warnings; use Data::Dumper; use DBD::Pg ':async'; use Test::More; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if ($dbh) { plan tests => 57; } else { plan skip_all => 'Connection to database failed, cannot continue testing'; } ok (defined $dbh, 'Connect to database for bytea testing'); my ($result,$expected,@data,$t); my $table = 'dbd_pg_test4'; $dbh->do(qq{CREATE TABLE $table(id2 integer, val2 text)}); $dbh->commit(); my $pgversion = $dbh->{pg_server_version}; # # Test of the pg_putline and pg_endcopy methods # ## pg_putline should fail unless we are in a COPY IN state $t='pg_putline fails when issued without a preceding COPY command'; eval { $dbh->pg_putline("12\tMulberry"); }; ok ($@, $t); $t='putline returned a value of 1 for success'; $dbh->do("COPY $table FROM STDIN"); $result = $dbh->pg_putline("12\tMulberry\n"); is ($result, 1, $t); $t='putline returned a value of 1 for success'; $result = $dbh->pg_putline("13\tStrawberry\n"); is ($result, 1, $t); $t='putline returned a value of 1 for success'; $result = $dbh->pg_putline("14\tBlueberry\n"); is ($result, 1, $t); ## Commands are not allowed while in a COPY IN state $t='do() fails while in a COPY IN state'; eval { $dbh->do(q{SELECT 'dbdpg_copytest'}); }; ok ($@, $t); ## pg_getline is not allowed as we are in a COPY_IN state $t='pg_getline fails while in a COPY IN state'; $data[0] = ''; eval { $dbh->pg_getline($data[0], 100); }; ok ($@, $t); $t='pg_endcopy returned a 1'; $result = $dbh->pg_endcopy(); is ($result, 1, $t); ## Make sure we can issue normal commands again $dbh->do(q{SELECT 'dbdpg_copytest'}); ## Make sure we are out of the COPY IN state and pg_putline no longer works $t='pg_putline fails when issued after pg_endcopy called'; eval { $dbh->pg_putline("16\tBlackberry"); }; ok ($@, $t); ## Check that our lines were inserted properly $t='putline inserted values correctly'; $expected = [[12 => 'Mulberry'],[13 => 'Strawberry'],[14 => 'Blueberry']]; $result = $dbh->selectall_arrayref("SELECT id2,val2 FROM $table ORDER BY id2"); is_deeply ($result, $expected, $t); # pg_endcopy should not work because we are no longer in a COPY state $t='pg_endcopy fails when called twice after COPY IN'; eval { $dbh->pg_endcopy; }; ok ($@, $t); $dbh->commit(); # # Test of the pg_getline method # ## pg_getline should fail unless we are in a COPY OUT state $t='pg_getline fails when issued without a preceding COPY command'; eval { $dbh->pg_getline($data[0], 100); }; ok ($@, $t); $t='pg_getline returns a 1'; $dbh->do("COPY $table TO STDOUT"); my ($buffer,$badret,$badval) = ('',0,0); $result = $dbh->pg_getline($data[0], 100); is ($result, 1, $t); ## Commands are not allowed while in a COPY OUT state $t='do() fails while in a COPY OUT state'; eval { $dbh->do(q{SELECT 'dbdpg_copytest'}); }; ok ($@, $t); ## pg_putline is not allowed as we are in a COPY OUT state $t='pg_putline fails while in a COPY OUT state'; eval { $dbh->pg_putline("99\tBogusberry"); }; ok ($@, $t); $t='pg_getline returned a 1'; $data[1]=$data[2]=$data[3]=''; $result = $dbh->pg_getline($data[1], 100); is ($result, 1, $t); $t='pg_getline returned a 1'; $result = $dbh->pg_getline($data[2], 100); is ($result, 1, $t); $t='pg_getline returns empty on final call'; $result = $dbh->pg_getline($data[3], 100); is ($result, '', $t); $t='getline returned all rows successfuly'; $result = \@data; $expected = ["12\tMulberry\n","13\tStrawberry\n","14\tBlueberry\n",'']; is_deeply ($result, $expected, $t); ## Make sure we can issue normal commands again $dbh->do(q{SELECT 'dbdpg_copytest'}); ## Make sure we are out of the COPY OUT state and pg_getline no longer works $t='pg_getline fails when issued after pg_endcopy called'; eval { $data[5]=''; $dbh->pg_getline($data[5], 100); }; ok ($@, $t); ## pg_endcopy should fail because we are no longer in a COPY state $t='pg_endcopy fails when called twice after COPY OUT'; eval { $dbh->pg_endcopy; }; ok ($@, $t); ## ## Test the new COPY methods ## $dbh->do("DELETE FROM $table"); $t='pg_putcopydata fails if not after a COPY FROM statement'; eval { $dbh->pg_putcopydata("pizza\tpie"); }; like ($@, qr{COPY FROM command}, $t); $t='pg_getcopydata fails if not after a COPY TO statement'; eval { $dbh->pg_getcopydata($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='pg_getcopydata_async fails if not after a COPY TO statement'; eval { $dbh->pg_getcopydata_async($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='pg_putcopyend warns but does not die if not after a COPY statement'; eval { require Test::Warn; }; if ($@) { pass ('Skipping Test::Warn test'); } else { Test::Warn::warning_like (sub { $dbh->pg_putcopyend(); }, qr/until a COPY/, $t); } $t='pg_getcopydata does not work if we are using COPY .. TO'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); eval { $dbh->pg_getcopydata($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='pg_putcopydata does not work if we are using COPY .. FROM'; $dbh->rollback(); $dbh->do("COPY $table TO STDOUT"); eval { $dbh->pg_putcopydata("pizza\tpie"); }; like ($@, qr{COPY FROM command}, $t); $t='pg_putcopydata works and returns a 1 on success'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); $result = $dbh->pg_putcopydata("15\tBlueberry"); is ($result, 1, $t); $t='pg_putcopydata works on second call'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); $result = $dbh->pg_putcopydata("16\tMoreBlueberries"); is ($result, 1, $t); $t='pg_putcopydata fails with invalid data'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); eval { $dbh->pg_putcopydata(); }; ok ($@, $t); $t='Calling pg_getcopydata gives an error when in the middle of COPY .. TO'; eval { $dbh->pg_getcopydata($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='Calling do() gives an error when in the middle of COPY .. FROM'; eval { $dbh->do('SELECT 123'); }; like ($@, qr{call pg_putcopyend}, $t); $t='pg_putcopydata works after a rude non-COPY attempt'; eval { $result = $dbh->pg_putcopydata("17\tMoreBlueberries"); }; is ($@, q{}, $t); is ($result, 1, $t); $t='pg_putcopyend works and returns a 1'; eval { $result = $dbh->pg_putcopyend(); }; is ($@, q{}, $t); is ($result, 1, $t); $t='pg_putcopydata fails after pg_putcopyend is called'; $dbh->commit(); eval { $result = $dbh->pg_putcopydata('root'); }; like ($@, qr{COPY FROM command}, $t); $t='Normal queries work after pg_putcopyend is called'; eval { $dbh->do('SELECT 123'); }; is ($@, q{}, $t); $t='Data from pg_putcopydata was entered correctly'; $result = $dbh->selectall_arrayref("SELECT id2,val2 FROM $table ORDER BY id2"); $expected = [['12','Mulberry'],['13','Strawberry'],[14,'Blueberry'],[17,'MoreBlueberries']]; is_deeply ($result, $expected, $t); $t='pg_getcopydata fails when argument is not a variable'; $dbh->do("COPY $table TO STDOUT"); eval { $dbh->pg_getcopydata('wrongo'); }; like ($@, qr{read-only}, $t); $t='pg_getcopydata works and returns the length of the string'; $data[0] = 'old'; eval { $dbh->pg_getcopydata($data[0]); }; is ($@, q{}, $t); is ($data[0], "13\tStrawberry\n", $t); $t='pg_getcopydata works when argument is a reference'; eval { $dbh->pg_getcopydata(\$data[0]); }; is ($@, q{}, $t); is ($data[0], "14\tBlueberry\n", $t); $t='Calling do() gives an error when in the middle of COPY .. TO'; eval { $dbh->do('SELECT 234'); }; like ($@, qr{pg_getcopydata}, $t); $t='Calling pg_putcopydata gives an errors when in the middle of COPY .. FROM'; eval { $dbh->pg_putcopydata('pie'); }; like ($@, qr{COPY FROM command}, $t); $t='pg_getcopydata returns 0 when no more data'; $dbh->pg_getcopydata(\$data[0]); eval { $result = $dbh->pg_getcopydata(\$data[0]); }; is ($@, q{}, $t); is ($data[0], '', $t); is ($result, -1, $t); $t='Normal queries work after pg_getcopydata runs out'; eval { $dbh->do('SELECT 234'); }; is ($@, q{}, $t); $t='Async queries work after COPY OUT'; $dbh->do('CREATE TEMP TABLE foobar AS SELECT 123::INTEGER AS x'); $dbh->do('COPY foobar TO STDOUT'); 1 while ($dbh->pg_getcopydata($buffer) >= 0); eval { $dbh->do('SELECT 111', { pg_async => PG_ASYNC} ); }; is ($@, q{}, $t); $dbh->pg_result(); $t='Async queries work after COPY IN'; $dbh->do('COPY foobar FROM STDIN'); $dbh->pg_putcopydata(456); $dbh->pg_putcopyend(); eval { $dbh->do('SELECT 222', { pg_async => PG_ASYNC} ); }; is ($@, q{}, $t); $dbh->pg_result(); SKIP: { $pgversion < 80200 and skip ('Server version 8.2 or greater needed for test', 1); $t='pg_getcopydata works when pulling from an empty table into an empty var'; $dbh->do(q{COPY (SELECT 1 FROM pg_class LIMIT 0) TO STDOUT}); eval { my $newvar; $dbh->pg_getcopydata($newvar); }; is ($@, q{}, $t); } # # Make sure rollback and commit reset our internal copystate tracking # $t='commit resets COPY state'; $dbh->do("COPY $table TO STDOUT"); $dbh->commit(); eval { $dbh->do(q{SELECT 'dbdpg_copytest'}); }; ok (!$@, $t); $t='rollback resets COPY state'; $dbh->do("COPY $table TO STDOUT"); $dbh->rollback(); eval { $dbh->do(q{SELECT 'dbdpg_copytest'}); }; ok (!$@, $t); # # Keep old-style calls around for backwards compatibility # $t=q{old-style dbh->func('text', 'putline') still works}; $dbh->do("COPY $table FROM STDIN"); $result = $dbh->func("13\tOlive\n", 'putline'); is ($result, 1, $t); $t=q{old-style dbh->func(var, length, 'getline') still works}; $dbh->pg_endcopy; $dbh->do("COPY $table TO STDOUT"); $result = $dbh->func($data[0], 100, 'getline'); is ($result, 1, $t); 1 while ($result = $dbh->func($data[0], 100, 'getline')); $dbh->do("DROP TABLE $table"); $dbh->commit(); cleanup_database($dbh,'test'); $dbh->disconnect; DBD-Pg-2.19.3/t/12placeholders.t0000644000076400007640000004477211727457207014477 0ustar greggreg#!perl ## Test of placeholders use 5.006; use strict; use warnings; use Test::More; use lib 't','.'; use DBI qw/:sql_types/; use DBD::Pg qw/:pg_types/; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 243; my $t='Connect to database for placeholder testing'; isnt ($dbh, undef, $t); my ($pglibversion,$pgversion) = ($dbh->{pg_lib_version},$dbh->{pg_server_version}); if ($pgversion >= 80100) { $dbh->do('SET escape_string_warning = false'); } my ($result, $SQL, $qresult); # Make sure that quoting works properly. $t='Quoting works properly'; my $E = $pgversion >= 80100 ? q{E} : q{}; my $quo = $dbh->quote('\\\'?:'); is ($quo, qq{${E}'\\\\''?:'}, $t); $t='Quoting works with a function call'; # Make sure that quoting works with a function call. # It has to be in this function, otherwise it doesn't fail the # way described in https://rt.cpan.org/Ticket/Display.html?id=4996. sub checkquote { my $str = shift; return is ($dbh->quote(substr($str, 0, 10)), "'$str'", $t); } checkquote('one'); checkquote('two'); checkquote('three'); checkquote('four'); $t='Fetch returns the correct quoted value'; my $sth = $dbh->prepare(qq{INSERT INTO dbd_pg_test (id,pname) VALUES (?, $quo)}); $sth->execute(100); my $sql = "SELECT pname FROM dbd_pg_test WHERE pname = $quo"; $sth = $dbh->prepare($sql); $sth->execute(); my ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with one bind param where none expected fails'; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with ? placeholder works'; $sql = 'SELECT pname FROM dbd_pg_test WHERE pname = ?'; $sth = $dbh->prepare($sql); $sth->execute('\\\'?:'); ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with :1 placeholder works'; $sql = 'SELECT pname FROM dbd_pg_test WHERE pname = :1'; $sth = $dbh->prepare($sql); $sth->bind_param(':1', '\\\'?:'); $sth->execute(); ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with $1 placeholder works'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = $1 AND pname <> 'foo'}; $sth = $dbh->prepare($sql); $sth->execute('\\\'?:'); ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with quoted ? fails with a placeholder'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = '?'}; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with quoted :1 fails with a placeholder'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = ':1'}; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with quoted ? fails with a placeholder'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = '\\\\' AND pname = '?'}; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with named placeholders works'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar2 AND pname = :foobar AND pname = :foobar2}; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->bind_param(':foobar2', 456); $sth->execute(); }; is ($@, q{}, $t); ## Same, but fiddle with whitespace $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar2 AND pname = :foobar2}; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->bind_param(':foobar2', 456); $sth->execute(); }; is ($@, q{}, $t); $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar AND pname = :foobar2 }; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->bind_param(':foobar2', 456); $sth->execute(); }; is ($@, q{}, $t); $t='Execute with repeated named placeholders works'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar }; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->execute(); }; is ($@, q{}, $t); ## Same thing, different whitespace $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar}; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->execute(); }; is ($@, q{}, $t); $t='Prepare with large number of parameters works'; ## Test large number of placeholders $sql = 'SELECT 1 FROM dbd_pg_test WHERE id IN (' . '?,' x 300 . '?)'; my @args = map { $_ } (1..301); $sth = $dbh->prepare($sql); my $count = $sth->execute(@args); $sth->finish(); is ($count, 1, $t); $sth->finish(); ## Force client encoding, as we cannot use backslashes in client-only encodings my $old_encoding = $dbh->selectall_arrayref('SHOW client_encoding')->[0][0]; if ($old_encoding ne 'UTF8') { $dbh->do(q{SET NAMES 'UTF8'}); } $t='Prepare with backslashes inside quotes works'; $SQL = q{SELECT setting FROM pg_settings WHERE name = 'backslash_quote'}; $count = $dbh->selectall_arrayref($SQL)->[0]; my $backslash = defined $count ? $count->[0] : 0; my $scs = $dbh->{pg_standard_conforming_strings}; $SQL = $scs ? q{SELECT E'\\'?'} : q{SELECT '\\'?'}; $sth = $dbh->prepare($SQL); eval { $sth->execute(); }; my $expected = $backslash eq 'off' ? qr{unsafe} : qr{}; like ($@, $expected, $t); ## Test quoting of geometric types my @geotypes = qw/point line lseg box path polygon circle/; eval { $dbh->do('DROP TABLE dbd_pg_test_geom'); }; $dbh->commit(); $SQL = 'CREATE TABLE dbd_pg_test_geom ('; for my $type (@geotypes) { $SQL .= "x$type $type,"; } $SQL =~ s/,$/)/; $dbh->do($SQL); $dbh->commit(); my %typemap = ( point => PG_POINT, line => PG_LINE, lseg => PG_LSEG, box => PG_BOX, path => PG_PATH, polygon => PG_POLYGON, circle => PG_CIRCLE, ); my $testdata = q{ point datatype integers 12,34 '12,34' (12,34) point datatype floating point numbers 1.34,667 '1.34,667' (1.34,667) point datatype exponential numbers 1e34,9E4 '1e34,9E4' (1e+34,90000) point datatype plus and minus signs 1e+34,-.45 '1e+34,-.45' (1e+34,-0.45) point datatype invalid number 123,abc ERROR: Invalid input for geometric type ERROR: any point datatype invalid format 123 '123' ERROR: any point datatype invalid format 123,456,789 '123,456,789' ERROR: any point datatype invalid format <(2,4),6> ERROR: Invalid input for geometric type ERROR: any point datatype invalid format [(1,2)] ERROR: Invalid input for geometric type ERROR: any line datatype integers 12,34 '12,34' ERROR: not yet implemented line datatype floating point numbers 1.34,667 '1.34,667' ERROR: not yet implemented line datatype exponential numbers 1e34,9E4 '1e34,9E4' ERROR: not yet implemented line datatype plus and minus signs 1e+34,-.45 '1e+34,-.45' ERROR: not yet implemented line datatype invalid number 123,abc ERROR: Invalid input for geometric type ERROR: not yet implemented lseg datatype invalid format 12,34 '12,34' ERROR: any lseg datatype integers (12,34),(56,78) '(12,34),(56,78)' [(12,34),(56,78)] lseg datatype floating point and exponential numbers (1.2,3.4),(5e3,7E1) '(1.2,3.4),(5e3,7E1)' [(1.2,3.4),(5000,70)] box datatype invalid format 12,34 '12,34' ERROR: any box datatype integers (12,34),(56,78) '(12,34),(56,78)' (56,78),(12,34) box datatype floating point and exponential numbers (1.2,3.4),(5e3,7E1) '(1.2,3.4),(5e3,7E1)' (5000,70),(1.2,3.4) path datatype invalid format 12,34 '12,34' ERROR: any path datatype integers (12,34),(56,78) '(12,34),(56,78)' ((12,34),(56,78)) path datatype floating point and exponential numbers (1.2,3.4),(5e3,7E1) '(1.2,3.4),(5e3,7E1)' ((1.2,3.4),(5000,70)) path datatype alternate bracket format [(1.2,3.4),(5e3,7E1)] '[(1.2,3.4),(5e3,7E1)]' [(1.2,3.4),(5000,70)] path datatype many elements (1.2,3.4),(5,6),(7,8),(-9,10) '(1.2,3.4),(5,6),(7,8),(-9,10)' ((1.2,3.4),(5,6),(7,8),(-9,10)) path datatype fails with braces {(1,2),(3,4)} ERROR: Invalid input for path type ERROR: any polygon datatype invalid format 12,34 '12,34' ERROR: any polygon datatype integers (12,34),(56,78) '(12,34),(56,78)' ((12,34),(56,78)) polygon datatype floating point and exponential numbers (1.2,3.4),(5e3,7E1) '(1.2,3.4),(5e3,7E1)' ((1.2,3.4),(5000,70)) polygon datatype many elements (1.2,3.4),(5,6),(7,8),(-9,10) '(1.2,3.4),(5,6),(7,8),(-9,10)' ((1.2,3.4),(5,6),(7,8),(-9,10)) polygon datatype fails with brackets [(1,2),(3,4)] ERROR: Invalid input for geometric type ERROR: any circle datatype invalid format (12,34) '(12,34)' ERROR: any circle datatype integers <(12,34),5> '<(12,34),5>' <(12,34),5> circle datatype floating point and exponential numbers <(-1.2,2E2),3e3> '<(-1.2,2E2),3e3>' <(-1.2,200),3000> circle datatype fails with brackets [(1,2),(3,4)] ERROR: Invalid input for circle type ERROR: any }; $testdata =~ s/^\s+//; my $curtype = ''; for my $line (split /\n\n+/ => $testdata) { my ($text,$input,$quoted,$rows) = split /\n/ => $line; next if ! $text; $t = "Geometric type test: $text"; (my $type) = ($text =~ m{(\w+)}); last if $type eq 'LAST'; if ($curtype ne $type) { $curtype = $type; eval { $dbh->do('DEALLOCATE geotest'); }; $dbh->commit(); $dbh->do(qq{PREPARE geotest($type) AS INSERT INTO dbd_pg_test_geom(x$type) VALUES (\$1)}); $sth = $dbh->prepare(qq{INSERT INTO dbd_pg_test_geom(x$type) VALUES (?)}); $sth->bind_param(1, '', {pg_type => $typemap{$type} }); } $dbh->do('DELETE FROM dbd_pg_test_geom'); eval { $qresult = $dbh->quote($input, {pg_type => $typemap{$type}}); }; if ($@) { if ($quoted !~ /ERROR: (.+)/) { fail ("$t error: $@"); } else { like ($@, qr{$1}, $t); } } else { is ($qresult, $quoted, $t); } $dbh->commit(); eval { $dbh->do("EXECUTE geotest('$input')"); }; if ($@) { if ($rows !~ /ERROR: (.+)/) { fail ("$t error: $@"); } else { ## Do any error for now: i18n worries pass ($t); } } $dbh->commit(); eval { $sth->execute($input); }; if ($@) { if ($rows !~ /ERROR: (.+)/) { fail ($t); } else { ## Do any error for now: i18n worries pass ($t); } } $dbh->commit(); if ($rows !~ /ERROR/) { $SQL = "SELECT x$type FROM dbd_pg_test_geom"; $expected = [[$rows],[$rows]]; $result = $dbh->selectall_arrayref($SQL); is_deeply ($result, $expected, $t); } } $t='Calling do() with non-DML placeholder works'; $sth->finish(); $dbh->commit(); eval { $dbh->do(q{SET search_path TO ?}, undef, 'pg_catalog'); }; is ($@, q{}, $t); $t='Calling do() with DML placeholder works'; $dbh->commit(); eval { $dbh->do(q{SELECT ?::text}, undef, 'public'); }; is ($@, q{}, $t); SKIP: { if ($pglibversion < 80000) { skip ('Skipping specific placeholder test on 7.4-compiled servers', 1); } $t='Calling do() with invalid crowded placeholders fails cleanly'; $dbh->commit(); eval { $dbh->do(q{SELECT ??}, undef, 'public', 'error'); }; is($dbh->state, '42601', $t); } $t='Prepare/execute with non-DML placeholder works'; $dbh->commit(); eval { $sth = $dbh->prepare(q{SET search_path TO ?}); $sth->execute('pg_catalog'); }; is ($@, q{}, $t); $dbh->do(q{SET search_path TO DEFAULT}); $t='Prepare/execute does not allow geometric operators'; $dbh->commit(); eval { $sth = $dbh->prepare(q{SELECT ?- lseg '(1,0),(1,1)'}); $sth->execute(); }; like ($@, qr{unbound placeholder}, $t); $t='Prepare/execute allows geometric operator ?- when dollaronly is set'; $dbh->commit(); $dbh->{pg_placeholder_dollaronly} = 1; eval { $sth = $dbh->prepare(q{SELECT ?- lseg '(1,0),(1,1)'}); $sth->execute(); $sth->finish(); }; is ($@, q{}, $t); $t='Prepare/execute allows geometric operator ?# when dollaronly set'; $dbh->commit(); eval { $sth = $dbh->prepare(q{SELECT lseg'(1,0),(1,1)' ?# lseg '(2,3),(4,5)'}); $sth->execute(); $sth->finish(); }; is ($@, q{}, $t); $t=q{Value of placeholder_dollaronly can be retrieved}; is ($dbh->{pg_placeholder_dollaronly}, 1, $t); $t=q{Prepare/execute does not allow use of raw ? and :foo forms}; $dbh->{pg_placeholder_dollaronly} = 0; eval { $sth = $dbh->prepare(q{SELECT uno ?: dos ? tres :foo bar $1}); $sth->execute(); $sth->finish(); }; like ($@, qr{mix placeholder}, $t); $t='Prepare/execute allows use of raw ? and :foo forms when dollaronly set'; $dbh->{pg_placeholder_dollaronly} = 1; eval { $sth = $dbh->prepare(q{SELECT uno ?: dos ? tres :foo bar $1}, {pg_placeholder_dollaronly => 1}); $sth->{pg_placeholder_dollaronly} = 1; $sth->execute(); $sth->finish(); }; like ($@, qr{unbound placeholder}, $t); $t='Prepare works with pg_placeholder_dollaronly'; $dbh->{pg_placeholder_dollaronly} = 0; eval { $sth = $dbh->prepare(q{SELECT uno ?: dos ? tres :foo bar $1}, {pg_placeholder_dollaronly => 1}); $sth->execute(); $sth->finish(); }; like ($@, qr{unbound placeholder}, $t); $t='Prepare works with identical named placeholders'; eval { $sth = $dbh->prepare(q{SELECT :row, :row, :row, :yourboat}); $sth->finish(); }; is ($@, q{}, $t); SKIP: { skip 'Cannot run some quote tests on very old versions of Postgres', 14 if $pgversion < 80000; $t='Prepare works with placeholders after double slashes'; eval { $dbh->do(q{CREATE OPERATOR // ( PROCEDURE=bit, LEFTARG=int, RIGHTARG=int )}); $sth = $dbh->prepare(q{SELECT ? // ?}); $sth->execute(1,2); $sth->finish(); }; is ($@, q{}, $t); $t='Dollar quotes starting with a number are not treated as valid identifiers'; eval { $sth = $dbh->prepare(q{SELECT $123$ $123$}); $sth->execute(1); $sth->finish(); }; like ($@, qr{Invalid placeholders}, $t); $t='Dollar quotes with invalid characters are not parsed as identifiers'; for my $char (qw!+ / : @ [ `!) { ## six characters eval { $sth = $dbh->prepare(qq{SELECT \$abc${char}\$ 123 \$abc${char}\$}); $sth->execute(); $sth->finish(); }; like ($@, qr{syntax error}, $t); } $t='Dollar quotes with valid characters are parsed as identifiers'; $dbh->rollback(); for my $char (qw{0 9 A Z a z}) { ## six letters eval { $sth = $dbh->prepare(qq{SELECT \$abc${char}\$ 123 \$abc${char}\$}); $sth->execute(); $sth->finish(); }; is ($@, q{}, $t); } for my $ident (qq{\x{5317}}, qq{abc\x{5317}}, qq{_cde\x{5317}}) { ## hi-bit chars eval { $sth = $dbh->prepare(qq{SELECT \$$ident\$ 123 \$$ident\$}); $sth->execute(); $sth->finish(); }; is ($@, q{}, $t); } } SKIP: { skip 'Cannot run backslash_quote test on Postgres < 8.2', 1 if $pgversion < 80200; $t='Backslash quoting inside double quotes is parsed correctly'; $dbh->do(q{SET backslash_quote = 'on'}); $dbh->commit(); eval { $sth = $dbh->prepare(q{SELECT * FROM "\" WHERE a=?}); $sth->execute(1); $sth->finish(); }; like ($@, qr{relation ".*" does not exist}, $t); } $dbh->rollback(); SKIP: { skip 'Cannot adjust standard_conforming_strings for testing on this version of Postgres', 2 if $pgversion < 80200; $t='Backslash quoting inside single quotes is parsed correctly with standard_conforming_strings off'; eval { $dbh->do(q{SET standard_conforming_strings = 'off'}); local $dbh->{Warn} = ''; $sth = $dbh->prepare(q{SELECT '\', ?}); $sth->execute(); $sth->finish(); }; like ($@, qr{unterminated quoted string}, $t); $dbh->rollback(); $t='Backslash quoting inside single quotes is parsed correctly with standard_conforming_strings on'; eval { $dbh->do(q{SET standard_conforming_strings = 'on'}); $sth = $dbh->prepare(q{SELECT '\', ?::int}); $sth->execute(1); $sth->finish(); }; is ($@, q{}, $t); } $t='Valid integer works when quoting with SQL_INTEGER'; my $val; $val = $dbh->quote('123', SQL_INTEGER); is ($val, 123, $t); $t='Invalid integer fails to pass through when quoting with SQL_INTEGER'; $val = -1; eval { $val = $dbh->quote('123abc', SQL_INTEGER); }; like ($@, qr{Invalid integer}, $t); is($val, -1, $t); my $prefix = 'Valid float value works when quoting with SQL_FLOAT'; for my $float ('123','0.00','0.234','23.31562', '1.23e04','6.54e+02','4e-3','NaN','Infinity','-infinity') { $t = "$prefix (value=$float)"; $val = -1; eval { $val = $dbh->quote($float, SQL_FLOAT); }; is ($@, q{}, $t); is ($val, $float, $t); next unless $float =~ /\w/; my $lcfloat = lc $float; $t = "$prefix (value=$lcfloat)"; $val = -1; eval { $val = $dbh->quote($lcfloat, SQL_FLOAT); }; is ($@, q{}, $t); is ($val, $lcfloat, $t); my $ucfloat = uc $float; $t = "$prefix (value=$ucfloat)"; $val = -1; eval { $val = $dbh->quote($ucfloat, SQL_FLOAT); }; is ($@, q{}, $t); is ($val, $ucfloat, $t); } $prefix = 'Invalid float value fails when quoting with SQL_FLOAT'; for my $float ('3abc','123abc','','NaNum','-infinitee') { $t = "$prefix (value=$float)"; $val = -1; eval { $val = $dbh->quote($float, SQL_FLOAT); }; like ($@, qr{Invalid float}, $t); is ($val, -1, $t); } $dbh->rollback(); ## Test placeholders plus binding $t='Bound placeholders enforce data types when not using server side prepares'; $dbh->trace(0); $dbh->{pg_server_prepare} = 0; $sth = $dbh->prepare('SELECT (1+?+?)::integer'); $sth->bind_param(1, 1, SQL_INTEGER); eval { $sth->execute('10foo',20); }; like ($@, qr{Invalid integer}, 'Invalid integer test 2'); ## Test quoting of the "name" type $prefix = q{The 'name' data type does correct quoting}; for my $word (qw/User user USER trigger Trigger/) { $t = qq{$prefix for the word "$word"}; my $got = $dbh->quote($word, { pg_type => PG_NAME }); $expected = qq{"$word"}; is($got, $expected, $t); } for my $word (qw/auser userz user-user/) { $t = qq{$prefix for the word "$word"}; my $got = $dbh->quote($word, { pg_type => PG_NAME }); $expected = qq{$word}; is($got, $expected, $t); } ## Test quoting of booleans my %booltest = ( ## no critic (Lax::ProhibitLeadingZeros::ExceptChmod, ValuesAndExpressions::ProhibitLeadingZeros) undef => 'NULL', 't' => 'TRUE', 'T' => 'TRUE', 'true' => 'TRUE', 'TRUE' => 'TRUE', 1 => 'TRUE', 01 => 'TRUE', '1' => 'TRUE', '0E0' => 'TRUE', '0e0' => 'TRUE', '0 but true' => 'TRUE', '0 BUT TRUE' => 'TRUE', 'f' => 'FALSE', 'F' => 'FALSE', 0 => 'FALSE', 00 => 'FALSE', '0' => 'FALSE', 'false' => 'FALSE', 'FALSE' => 'FALSE', 12 => 'ERROR', '01' => 'ERROR', '00' => 'ERROR', ' false' => 'ERROR', ' TRUE' => 'ERROR', 'FALSEY' => 'ERROR', 'trueish' => 'ERROR', '0E0E0' => 'ERROR', ## Jungle love... '0 but truez' => 'ERROR', ); while (my ($name,$res) = each %booltest) { $name = undef if $name eq 'undef'; $t = sprintf 'Boolean quoting of %s', defined $name ? qq{"$name"} : 'undef'; eval { $result = $dbh->quote($name, {pg_type => PG_BOOL}); }; if ($@) { if ($res eq 'ERROR' and $@ =~ /Invalid boolean/) { pass ($t); } else { fail ("Failure at $t: $@"); } $dbh->rollback(); } else { is ($result, $res, $t); } } ## Begin custom type testing $dbh->rollback(); cleanup_database($dbh,'test'); $dbh->disconnect(); DBD-Pg-2.19.3/t/01connect.t0000644000076400007640000001321111642756716013444 0ustar greggreg#!perl ## Make sure we can connect and disconnect cleanly ## All tests are stopped if we cannot make the first connect use 5.006; use strict; use warnings; use DBI; use DBD::Pg; use Test::More; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); ## Define this here in case we get to the END block before a connection is made. BEGIN { use vars qw/$t $pgversion $pglibversion $pgvstring $pgdefport $helpconnect $dbh $connerror %set/; ($pgversion,$pglibversion,$pgvstring,$pgdefport) = ('?','?','?','?'); } ($helpconnect,$connerror,$dbh) = connect_database(); if (! defined $dbh or $connerror) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 15; pass ('Established a connection to the database'); $pgversion = $dbh->{pg_server_version}; $pglibversion = $dbh->{pg_lib_version}; $pgdefport = $dbh->{pg_default_port}; $pgvstring = $dbh->selectall_arrayref('SELECT VERSION()')->[0][0]; ok ($dbh->disconnect(), 'Disconnect from the database'); # Connect two times. From this point onward, do a simpler connection check $t=q{Second database connection attempt worked}; (undef,$connerror,$dbh) = connect_database(); is ($connerror, '', $t); if ($connerror ne '') { BAIL_OUT 'Second connection to database failed, bailing out'; } ## Grab some important values used for debugging my @vals = qw/array_nulls backslash_quote server_encoding client_encoding standard_conforming_strings/; my $SQL = 'SELECT name,setting FROM pg_settings WHERE name IN (' . (join ',' => map { qq{'$_'} } @vals) . ')'; for (@{$dbh->selectall_arrayref($SQL)}) { $set{$_->[0]} = $_->[1]; } my $dbh2 = connect_database(); pass ('Connected with second database handle'); my $sth = $dbh->prepare('SELECT 123'); ok ($dbh->disconnect(), 'Disconnect with first database handle'); ok ($dbh2->disconnect(), 'Disconnect with second database handle'); ok ($dbh2->disconnect(), 'Disconnect again with second database handle'); eval { $sth->execute(); }; ok ($@, 'Execute fails on a disconnected statement'); # Try out various connection options $ENV{DBI_DSN} ||= ''; SKIP: { my $alias = qr{(database|db|dbname)}; if ($ENV{DBI_DSN} !~ /$alias\s*=\s*\S+/) { skip ('DBI_DSN contains no database option, so skipping connection tests', 7); } $t=q{Connect with invalid option fails}; my $err; (undef,$err,$dbh) = connect_database({ dbreplace => 'dbbarf', nocreate => 1 }); like ($err, qr{DBI connect.+failed:}, $t); for my $opt (qw/db dbname database/) { $t=qq{Connect using string '$opt' works}; $dbh and $dbh->disconnect(); (undef,$err,$dbh) = connect_database({dbreplace => $opt}); $err =~ s/(Previous failure).*/$1/; is ($err, '', $t); } $t=q{Connect with forced uppercase 'DBI:' works}; my ($testdsn,$testuser,$helpconnect,$su,$uid,$testdir,$pg_ctl,$initdb,$error,$version) = get_test_settings(); $testdsn =~ s/^dbi/DBI/i; my $ldbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 0}); ok (ref $ldbh, $t); $ldbh->disconnect(); $t=q{Connect with mixed case 'DbI:' works}; $testdsn =~ s/^dbi/DbI/i; $ldbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 0}); ok (ref $ldbh, $t); $ldbh->disconnect(); if ($ENV{DBI_DSN} =~ /$alias\s*=\s*\"/) { skip ('DBI_DSN already contains quoted database, no need for explicit test', 1); } $t=q{Connect using a quoted database argument}; eval { $dbh and $dbh->disconnect(); (undef,$err,$dbh) = connect_database({dbquotes => 1, nocreate => 1}); }; is ($@, q{}, $t); } END { my $pv = sprintf('%vd', $^V); my $schema = 'dbd_pg_testschema'; my $dsn = exists $ENV{DBI_DSN} ? $ENV{DBI_DSN} : '?'; ## Don't show current dir to the world via CPAN::Reporter results $dsn =~ s{host=/.*(dbdpg_test_database/data/socket)}{host=/$1}; my $ver = defined $DBD::Pg::VERSION ? $DBD::Pg::VERSION : '?'; my $user = exists $ENV{DBI_USER} ? $ENV{DBI_USER} : ''; my $offset = 27; my $extra = ''; for (sort qw/HOST HOSTADDR PORT DATABASE USER PASSWORD PASSFILE OPTIONS REALM REQUIRESSL KRBSRVNAME CONNECT_TIMEOUT SERVICE SSLMODE SYSCONFDIR CLIENTENCODING/) { my $name = "PG$_"; if (exists $ENV{$name} and defined $ENV{$name}) { $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name; } } for my $name (qw/DBI_DRIVER DBI_AUTOPROXY LANG/) { if (exists $ENV{$name} and defined $ENV{$name}) { $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name; } } ## More helpful stuff for (sort keys %set) { $extra .= sprintf "\n%-*s %s", $offset, $_, $set{$_}; } if ($helpconnect) { $extra .= sprintf "\n%-*s ", $offset, 'Adjusted:'; if ($helpconnect & 1) { $extra .= 'DBI_DSN '; } if ($helpconnect & 4) { $extra .= 'DBI_USER'; } if ($helpconnect & 8) { $extra .= 'DBI_USERx2'; } if ($helpconnect & 16) { $extra .= 'initdb'; } } if (defined $connerror and length $connerror) { $connerror =~ s/.+?failed: ([^\n]+).*/$1/s; $connerror =~ s{\n at t/dbdpg.*}{}m; if ($connerror =~ /create semaphores/) { $connerror =~ s/.*(FATAL.*?)HINT.*/$1/sm; } $extra .= "\nError was: $connerror"; } diag "\nDBI Version $DBI::VERSION\n". "DBD::Pg Version $ver\n". "Perl Version $pv\n". "OS $^O\n". "PostgreSQL (compiled) $pglibversion\n". "PostgreSQL (target) $pgversion\n". "PostgreSQL (reported) $pgvstring\n". "Default port $pgdefport\n". "DBI_DSN $dsn\n". "DBI_USER $user\n". "Test schema $schema$extra\n"; } DBD-Pg-2.19.3/t/06bytea.t0000644000076400007640000000550011726451625013120 0ustar greggreg#!perl ## Test bytea handling use 5.006; use strict; use warnings; use Test::More; use DBI ':sql_types'; use DBD::Pg ':pg_types'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 16; isnt ($dbh, undef, 'Connect to database for bytea testing'); my ($pglibversion,$pgversion) = ($dbh->{pg_lib_version},$dbh->{pg_server_version}); if ($pgversion >= 80100) { $dbh->do('SET escape_string_warning = false'); } my ($sth, $t); $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest) VALUES (?,?)}); $t='bytea insert test with string containing null and backslashes'; $sth->bind_param(1, undef, { pg_type => PG_INT4 }); $sth->bind_param(2, undef, { pg_type => PG_BYTEA }); ok ($sth->execute(400, 'aa\\bb\\cc\\\0dd\\'), $t); $t='bytea insert test with string containing a single quote'; ok ($sth->execute(401, '\''), $t); $t='bytea (second) insert test with string containing a single quote'; ok ($sth->execute(402, '\''), $t); my ($binary_in, $binary_out); $t='store binary data in BYTEA column'; for(my $i=0; $i<256; $i++) { $binary_out .= chr($i); } $sth->{pg_server_prepare} = 0; ok ($sth->execute(403, $binary_out), $t); $sth->{pg_server_prepare} = 1; ok ($sth->execute(404, $binary_out), $t); if ($pgversion < 90000) { test_outputs(undef); SKIP: { skip 'No BYTEA output format setting before 9.0', 5 } } else { test_outputs($_) for qw(hex escape); } $sth->finish(); cleanup_database($dbh,'test'); $dbh->disconnect(); sub test_outputs { my $output = shift; $dbh->do(qq{SET bytea_output = '$output'}) if $output; $t='Received correct text from BYTEA column with backslashes'; $t.=" ($output output)" if $output; $sth = $dbh->prepare(q{SELECT bytetest FROM dbd_pg_test WHERE id=?}); $sth->execute(400); my $byte = $sth->fetchall_arrayref()->[0][0]; is ($byte, 'aa\bb\cc\\\0dd\\', $t); $t='Received correct text from BYTEA column with quote'; $t.=" ($output output)" if $output; $sth->execute(402); $byte = $sth->fetchall_arrayref()->[0][0]; is ($byte, '\'', $t); $t='Ensure proper handling of high bit characters'; $t.=" ($output output)" if $output; $sth->execute(403); ($binary_in) = $sth->fetchrow_array(); cmp_ok ($binary_in, 'eq', $binary_out, $t); $sth->execute(404); ($binary_in) = $sth->fetchrow_array(); ok ($binary_in eq $binary_out, $t); $t='quote properly handles bytea strings'; $t.=" ($output output)" if $output; my $string = "abc\123\\def\0ghi"; my $result = $dbh->quote($string, { pg_type => PG_BYTEA }); my $E = $pgversion >= 80100 ? q{E} : q{}; my $expected = qq{${E}'abc\123\\\\\\\\def\\\\000ghi'}; is ($result, $expected, $t); return; } DBD-Pg-2.19.3/t/lib/0000755000076400007640000000000012014741170012213 5ustar greggregDBD-Pg-2.19.3/t/lib/App/0000755000076400007640000000000012014741170012733 5ustar greggregDBD-Pg-2.19.3/t/lib/App/Info/0000755000076400007640000000000012014741170013626 5ustar greggregDBD-Pg-2.19.3/t/lib/App/Info/Handler/0000755000076400007640000000000012014741170015203 5ustar greggregDBD-Pg-2.19.3/t/lib/App/Info/Handler/Prompt.pm0000644000076400007640000001116411642756716017047 0ustar greggregpackage App::Info::Handler::Prompt; =head1 NAME App::Info::Handler::Prompt - Prompting App::Info event handler =head1 SYNOPSIS use App::Info::Category::FooApp; use App::Info::Handler::Print; my $prompter = App::Info::Handler::Print->new; my $app = App::Info::Category::FooApp->new( on_unknown => $prompter ); # Or... my $app = App::Info::Category::FooApp->new( on_confirm => 'prompt' ); =head1 DESCRIPTION App::Info::Handler::Prompt objects handle App::Info events by printing their messages to C and then accepting a new value from C. The new value is validated by any callback supplied by the App::Info concrete subclass that triggered the event. If the value is valid, App::Info::Handler::Prompt assigns the new value to the event request. If it isn't it prints the error message associated with the event request, and then prompts for the data again. Although designed with unknown and confirm events in mind, App::Info::Handler::Prompt handles info and error events as well. It will simply print info event messages to C and print error event messages to C. For more interesting info and error event handling, see L and L. Upon loading, App::Info::Handler::Print registers itself with App::Info::Handler, setting up a single string, "prompt", that can be passed to an App::Info concrete subclass constructor. This string is a shortcut that tells App::Info how to create an App::Info::Handler::Print object for handling events. =cut use strict; use App::Info::Handler; use vars qw($VERSION @ISA); $VERSION = '0.45'; @ISA = qw(App::Info::Handler); # Register ourselves. App::Info::Handler->register_handler ('prompt' => sub { __PACKAGE__->new } ); =head1 INTERFACE =head2 Constructor =head3 new my $prompter = App::Info::Handler::Prompt->new; Constructs a new App::Info::Handler::Prompt object and returns it. No special arguments are required. =cut sub new { my $pkg = shift; my $self = $pkg->SUPER::new(@_); $self->{tty} = -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) ); # We're done! return $self; } my $get_ans = sub { my ($prompt, $tty, $def) = @_; # Print the message. local $| = 1; local $\; print $prompt; # Collect the answer. my $ans; if ($tty) { $ans = ; if (defined $ans ) { chomp $ans; } else { # user hit ctrl-D print "\n"; } } else { print "$def\n" if defined $def; } return $ans; }; sub handler { my ($self, $req) = @_; my $ans; my $type = $req->type; if ($type eq 'unknown' || $type eq 'confirm') { # We'll want to prompt for a new value. my $val = $req->value; my ($def, $dispdef) = defined $val ? ($val, " [$val] ") : ('', ' '); my $msg = $req->message or Carp::croak("No message in request"); $msg .= $dispdef; # Get the answer. $ans = $get_ans->($msg, $self->{tty}, $def); # Just return if they entered an empty string or we couldnt' get an # answer. return 1 unless defined $ans && $ans ne ''; # Validate the answer. my $err = $req->error; while (!$req->value($ans)) { print "$err: '$ans'\n"; $ans = $get_ans->($msg, $self->{tty}, $def); return 1 unless defined $ans && $ans ne ''; } } elsif ($type eq 'info') { # Just print the message. print STDOUT $req->message, "\n"; } elsif ($type eq 'error') { # Just print the message. print STDERR $req->message, "\n"; } else { # This shouldn't happen. Carp::croak("Invalid request type '$type'"); } # Return true to indicate that we've handled the request. return 1; } 1; __END__ =head1 BUGS Please send bug reports to or file them at L. =head1 AUTHOR David Wheeler =head1 SEE ALSO L documents the event handling interface. L handles events by passing their messages Carp module functions. L handles events by printing their messages to a file handle. L describes how to implement custom App::Info event handlers. =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2004, David Wheeler. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-2.19.3/t/lib/App/Info/RDBMS.pm0000644000076400007640000000221511642756716015055 0ustar greggregpackage App::Info::RDBMS; use strict; use App::Info; use vars qw(@ISA $VERSION); @ISA = qw(App::Info); $VERSION = '0.27'; 1; __END__ =head1 NAME App::Info::RDBMS - Information about databases on a system =head1 DESCRIPTION This class is an abstract base class for App::Info subclasses that provide information about relational databases. Its subclasses are required to implement its interface. See L for a complete description and L for an example implementation. =head1 INTERFACE Currently, App::Info::RDBMS adds no more methods than those from its parent class, App::Info. =head1 BUGS Report all bugs via the CPAN Request Tracker at L. =head1 AUTHOR David Wheeler > =head1 SEE ALSO L, L =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2004, David Wheeler. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-2.19.3/t/lib/App/Info/Request.pm0000644000076400007640000001707611642756716015651 0ustar greggregpackage App::Info::Request; =head1 NAME App::Info::Request - App::Info event handler request object =head1 SYNOPSIS # In an App::Info::Handler subclass: sub handler { my ($self, $req) = @_; print "Event Type: ", $req->type; print "Message: ", $req->message; print "Error: ", $req->error; print "Value: ", $req->value; } =head1 DESCRIPTION Objects of this class are passed to the C method of App::Info event handlers. Generally, this class will be of most interest to App::Info::Handler subclass implementers. The L in App::Info each construct a new App::Info::Request object and initialize it with their arguments. The App::Info::Request object is then the sole argument passed to the C method of any and all App::Info::Handler objects in the event handling chain. Thus, if you'd like to create your own App::Info event handler, this is the object you need to be familiar with. Consult the L documentation for details on creating custom event handlers. Each of the App::Info event triggering methods constructs an App::Info::Request object with different attribute values. Be sure to consult the documentation for the L in App::Info, where the values assigned to the App::Info::Request object are documented. Then, in your event handler subclass, check the value returned by the C method to determine what type of event request you're handling to handle the request appropriately. =cut use strict; use vars qw($VERSION); $VERSION = '0.45'; ############################################################################## =head1 INTERFACE The following sections document the App::Info::Request interface. =head2 Constructor =head3 new my $req = App::Info::Request->new(%params); This method is used internally by App::Info to construct new App::Info::Request objects to pass to event handler objects. Generally, you won't need to use it, other than perhaps for testing custom App::Info::Handler classes. The parameters to C are passed as a hash of named parameters that correspond to their like-named methods. The supported parameters are: =over 4 =item type =item message =item error =item value =item callback =back See the object methods documentation below for details on these object attributes. =cut sub new { my $pkg = shift; # Make sure we've got a hash of arguments. Carp::croak("Odd number of parameters in call to " . __PACKAGE__ . "->new() when named parameters expected" ) if @_ % 2; my %params = @_; # Validate the callback. if ($params{callback}) { Carp::croak("Callback parameter '$params{callback}' is not a code ", "reference") unless UNIVERSAL::isa($params{callback}, 'CODE'); } else { # Otherwise just assign a default approve callback. $params{callback} = sub { 1 }; } # Validate type parameter. if (my $t = $params{type}) { Carp::croak("Invalid handler type '$t'") unless $t eq 'error' or $t eq 'info' or $t eq 'unknown' or $t eq 'confirm'; } else { $params{type} = 'info'; } # Return the request object. bless \%params, ref $pkg || $pkg; } ############################################################################## =head2 Object Methods =head3 message my $message = $req->message; Returns the message stored in the App::Info::Request object. The message is typically informational, or an error message, or a prompt message. =cut sub message { $_[0]->{message} } ############################################################################## =head3 error my $error = $req->error; Returns any error message associated with the App::Info::Request object. The error message is typically there to display for users when C returns false. =cut sub error { $_[0]->{error} } ############################################################################## =head3 type my $type = $req->type; Returns a string representing the type of event that triggered this request. The types are the same as the event triggering methods defined in App::Info. As of this writing, the supported types are: =over =item info =item error =item unknown =item confirm =back Be sure to consult the App::Info documentation for more details on the event types. =cut sub type { $_[0]->{type} } ############################################################################## =head3 callback if ($req->callback($value)) { print "Value '$value' is valid.\n"; } else { print "Value '$value' is not valid.\n"; } Executes the callback anonymous subroutine supplied by the App::Info concrete base class that triggered the event. If the callback returns false, then C<$value> is invalid. If the callback returns true, then C<$value> is valid and can be assigned via the C method. Note that the C method itself calls C if it was passed a value to assign. See its documentation below for more information. =cut sub callback { my $self = shift; my $code = $self->{callback}; local $_ = $_[0]; $code->(@_); } ############################################################################## =head3 value my $value = $req->value; if ($req->value($value)) { print "Value '$value' successfully assigned.\n"; } else { print "Value '$value' not successfully assigned.\n"; } When called without an argument, C simply returns the value currently stored by the App::Info::Request object. Typically, the value is the default value for a confirm event, or a value assigned to an unknown event. When passed an argument, C attempts to store the the argument as a new value. However, C calls C on the new value, and if C returns false, then C returns false and does not store the new value. If C returns true, on the other hand, then C goes ahead and stores the new value and returns true. =cut sub value { my $self = shift; if ($#_ >= 0) { # grab the value. my $value = shift; # Validate the value. if ($self->callback($value)) { # The value is good. Assign it and return true. $self->{value} = $value; return 1; } else { # Invalid value. Return false. return; } } # Just return the value. return $self->{value}; } 1; __END__ =head1 BUGS Please send bug reports to or file them at L. =head1 AUTHOR David Wheeler =head1 SEE ALSO L documents the event triggering methods and how they construct App::Info::Request objects to pass to event handlers. L documents how to create custom event handlers, which must make use of the App::Info::Request object passed to their C object methods. The following classes subclass App::Info::Handler, and thus offer good exemplars for using App::Info::Request objects when handling events. =over 4 =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2004, David Wheeler. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-2.19.3/t/lib/App/Info/Util.pm0000644000076400007640000003416211642756716015131 0ustar greggregpackage App::Info::Util; =head1 NAME App::Info::Util - Utility class for App::Info subclasses =head1 SYNOPSIS use App::Info::Util; my $util = App::Info::Util->new; # Subclasses File::Spec. my @paths = $util->paths; # First directory that exists in a list. my $dir = $util->first_dir(@paths); # First directory that exists in a path. $dir = $util->first_path($ENV{PATH}); # First file that exists in a list. my $file = $util->first_file('this.txt', '/that.txt', 'C:\\foo.txt'); # First file found among file base names and directories. my $files = ['this.txt', 'that.txt']; $file = $util->first_cat_file($files, @paths); =head1 DESCRIPTION This class subclasses L and adds its own methods in order to offer utility methods to L classes. Although intended to be used by App::Info subclasses, in truth App::Info::Util's utility may be considered more general, so feel free to use it elsewhere. The methods added in addition to the usual File::Spec suspects are designed to facilitate locating files and directories on the file system, as well as searching those files. The assumption is that, in order to provide useful metadata about a given software package, an App::Info subclass must find relevant files and directories and parse them with regular expressions. This class offers methods that simplify those tasks. =cut use strict; use File::Spec (); use Config; use vars qw(@ISA $VERSION); @ISA = qw(File::Spec); $VERSION = '0.45'; my %path_dems = (MacOS => qr',', MSWin32 => qr';', os2 => qr';', VMS => undef, epoc => undef); my $path_dem = exists $path_dems{$^O} ? $path_dems{$^O} : qr':'; =head1 CONSTRUCTOR =head2 new my $util = App::Info::Util->new; This is a very simple constructor that merely returns an App::Info::Util object. Since, like its File::Spec super class, App::Info::Util manages no internal data itself, all methods may be used as class methods, if one prefers to. The constructor here is provided merely as a convenience. =cut sub new { bless {}, ref $_[0] || $_[0] } =head1 OBJECT METHODS In addition to all of the methods offered by its super class, L, App::Info::Util offers the following methods. =head2 first_dir my @paths = $util->paths; my $dir = $util->first_dir(@dirs); Returns the first file system directory in @paths that exists on the local file system. Only the first item in @paths that exists as a directory will be returned; any other paths leading to non-directories will be ignored. =cut sub first_dir { shift; foreach (@_) { return $_ if -d } return; } =head2 first_path my $path = $ENV{PATH}; $dir = $util->first_path($path); Takes the $path string and splits it into a list of directory paths, based on the path demarcator on the local file system. Then calls C to return the first directoy in the path list that exists on the local file system. The path demarcator is specified for the following file systems: =over 4 =item MacOS: "," =item MSWin32: ";" =item os2: ";" =item VMS: undef This method always returns undef on VMS. Patches welcome. =item epoc: undef This method always returns undef on epoch. Patches welcome. =item Unix: ":" All other operating systems are assumed to be Unix-based. =back =cut sub first_path { return unless $path_dem; shift->first_dir(split /$path_dem/, shift) } =head2 first_file my $file = $util->first_file(@filelist); Examines each of the files in @filelist and returns the first one that exists on the file system. The file must be a regular file -- directories will be ignored. =cut sub first_file { shift; foreach (@_) { return $_ if -f } return; } =head2 first_exe my $exe = $util->first_exe(@exelist); Examines each of the files in @exelist and returns the first one that exists on the file system as an executable file. Directories will be ignored. =cut sub first_exe { shift; foreach (@_) { return $_ if -f && -x } return; } =head2 first_cat_path my $file = $util->first_cat_path('ick.txt', @paths); $file = $util->first_cat_path(['this.txt', 'that.txt'], @paths); The first argument to this method may be either a file or directory base name (that is, a file or directory name without a full path specification), or a reference to an array of file or directory base names. The remaining arguments constitute a list of directory paths. C processes each of these directory paths, concatenates (by the method native to the local operating system) each of the file or directory base names, and returns the first one that exists on the file system. For example, let us say that we were looking for a file called either F or F, and it could be in any of the following paths: F, F, F. The method call looks like this: my $httpd = $util->first_cat_path(['httpd', 'apache'], '/usr/local/bin', '/usr/bin/', '/bin'); If the OS is a Unix variant, C will then look for the first file that exists in this order: =over 4 =item /usr/local/bin/httpd =item /usr/local/bin/apache =item /usr/bin/httpd =item /usr/bin/apache =item /bin/httpd =item /bin/apache =back The first of these complete paths to be found will be returned. If none are found, then undef will be returned. =cut sub first_cat_path { my $self = shift; my $files = ref $_[0] ? shift() : [shift()]; foreach my $p (@_) { foreach my $f (@$files) { my $path = $self->catfile($p, $f); return $path if -e $path; } } return; } =head2 first_cat_dir my $dir = $util->first_cat_dir('ick.txt', @paths); $dir = $util->first_cat_dir(['this.txt', 'that.txt'], @paths); Funtionally identical to C, except that it returns the directory path in which the first file was found, rather than the full concatenated path. Thus, in the above example, if the file found was F, while C would return that value, C would return F instead. =cut sub first_cat_dir { my $self = shift; my $files = ref $_[0] ? shift() : [shift()]; foreach my $p (@_) { foreach my $f (@$files) { my $path = $self->catfile($p, $f); return $p if -e $path; } } return; } =head2 first_cat_exe my $exe = $util->first_cat_exe('ick.txt', @paths); $exe = $util->first_cat_exe(['this.txt', 'that.txt'], @paths); Funtionally identical to C, except that it returns the full path to the first executable file found, rather than simply the first file found. =cut sub first_cat_exe { my $self = shift; my $files = ref $_[0] ? shift() : [shift()]; foreach my $p (@_) { foreach my $f (@$files) { my $path = $self->catfile($p, $f); return $path if -f $path && -x $path; } } return; } =head2 search_file my $file = 'foo.txt'; my $regex = qr/(text\s+to\s+find)/; my $value = $util->search_file($file, $regex); Opens C<$file> and executes the C<$regex> regular expression against each line in the file. Once the line matches and one or more values is returned by the match, the file is closed and the value or values returned. For example, say F contains the line "Version 6.5, patch level 8", and you need to grab each of the three version parts. All three parts can be grabbed like this: my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/; my @nums = $util->search_file($file, $regex); Now C<@nums> will contain the values C<(6, 5, 8)>. Note that in a scalar context, the above search would yeild an array reference: my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/; my $nums = $util->search_file($file, $regex); So now C<$nums> contains C<[6, 5, 8]>. The same does not hold true if the match returns only one value, however. Say F contains the line "king of the who?", and you wish to know who the king is king of. Either of the following two calls would get you the data you need: my $minions = $util->search_file($file, qr/King\s+of\s+(.*)/); my @minions = $util->search_file($file, qr/King\s+of\s+(.*)/); In the first case, because the regular expression contains only one set of parentheses, C will simply return that value: C<$minions> contains the string "the who?". In the latter case, C<@minions> of course contains a single element: C<("the who?")>. Note that a regular expression without parentheses -- that is, one that doesn't grab values and put them into $1, $2, etc., will never successfully match a line in this method. You must include something to parentetically match. If you just want to know the value of what was matched, parenthesize the whole thing and if the value returns, you have a match. Also, if you need to match patterns across lines, try using multiple regular expressions with C, instead. =cut sub search_file { my ($self, $file, $regex) = @_; return unless $file && $regex; open F, "<$file" or Carp::croak "Cannot open $file: $!\n"; my @ret; while () { # If we find a match, we're done. (@ret) = /$regex/ and last; } close F; # If the match returned an more than one value, always return the full # array. Otherwise, return just the first value in a scalar context. return unless @ret; return wantarray ? @ret : $#ret <= 0 ? $ret[0] : \@ret; } =head2 multi_search_file my @regexen = (qr/(one)/, qr/(two)\s+(three)/); my @matches = $util->multi_search_file($file, @regexen); Like C, this mehod opens C<$file> and parses it for regular expresion matches. This method, however, can take a list of regular expressions to look for, and will return the values found for all of them. Regular expressions that match and return multiple values will be returned as array referernces, while those that match and return a single value will return just that single value. For example, say you are parsing a file with lines like the following: #define XML_MAJOR_VERSION 1 #define XML_MINOR_VERSION 95 #define XML_MICRO_VERSION 2 You need to get each of these numbers, but calling C for each of them would be wasteful, as each call to C opens the file and parses it. With C, on the other hand, the file will be opened only once, and, once all of the regular expressions have returned matches, the file will be closed and the matches returned. Thus the above values can be collected like this: my @regexen = ( qr/XML_MAJOR_VERSION\s+(\d+)$/, qr/XML_MINOR_VERSION\s+(\d+)$/, qr/XML_MICRO_VERSION\s+(\d+)$/ ); my @nums = $file->multi_search_file($file, @regexen); The result will be that C<@nums> contains C<(1, 95, 2)>. Note that C tries to do the right thing by only parsing the file until all of the regular expressions have been matched. Thus, a large file with the values you need near the top can be parsed very quickly. As with C, C can take regular expressions that match multiple values. These will be returned as array references. For example, say the file you're parsing has files like this: FooApp Version 4 Subversion 2, Microversion 6 To get all of the version numbers, you can either use three regular expressions, as in the previous example: my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/, qr/Subversion\s+(\d+),/, qr/Microversion\s+(\d$)$/ ); my @nums = $file->multi_search_file($file, @regexen); In which case C<@nums> will contain C<(4, 2, 6)>. Or, you can use just two regular expressions: my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/, qr/Subversion\s+(\d+),\s+Microversion\s+(\d$)$/ ); my @nums = $file->multi_search_file($file, @regexen); In which case C<@nums> will contain C<(4, [2, 6])>. Note that the two parentheses that return values in the second regular expression cause the matches to be returned as an array reference. =cut sub multi_search_file { my ($self, $file, @regexen) = @_; return unless $file && @regexen; my @each = @regexen; open F, "<$file" or Carp::croak "Cannot open $file: $!\n"; my %ret; while (my $line = ) { my @splice; # Process each of the regular expresssions. for (my $i = 0; $i < @each; $i++) { if ((my @ret) = $line =~ /$each[$i]/) { # We have a match! If there's one match returned, just grab # it. If there's more than one, keep it as an array ref. $ret{$each[$i]} = $#ret > 0 ? \@ret : $ret[0]; # We got values for this regex, so not its place in the @each # array. push @splice, $i; } } # Remove any regexen that have already found a match. for (@splice) { splice @each, $_, 1 } # If there are no more regexes, we're done -- no need to keep # processing lines in the file! last unless @each; } close F; return unless %ret; return wantarray ? @ret{@regexen} : \@ret{@regexen}; } =head2 lib_dirs my @dirs = $util->lib_dirs; Returns a list of possible library directories to be searched. These are gathered from the C and C Config settings. These are useful for passing to C to search typical directories for library files. =cut sub lib_dirs { grep { defined and length } map { split ' ' } grep { defined } $Config{libsdirs}, $Config{loclibpth}, '/sw/lib'; } 1; __END__ =head1 BUGS Please send bug reports to or file them at L. =head1 AUTHOR David Wheeler =head1 SEE ALSO L, L, L L =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2004, David Wheeler. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-2.19.3/t/lib/App/Info/RDBMS/0000755000076400007640000000000012014741170014475 5ustar greggregDBD-Pg-2.19.3/t/lib/App/Info/RDBMS/PostgreSQL.pm0000644000076400007640000006026311642756716017067 0ustar greggregpackage App::Info::RDBMS::PostgreSQL; =head1 NAME App::Info::RDBMS::PostgreSQL - Information about PostgreSQL =head1 SYNOPSIS use App::Info::RDBMS::PostgreSQL; my $pg = App::Info::RDBMS::PostgreSQL->new; if ($pg->installed) { print "App name: ", $pg->name, "\n"; print "Version: ", $pg->version, "\n"; print "Bin dir: ", $pg->bin_dir, "\n"; } else { print "PostgreSQL is not installed. :-(\n"; } =head1 DESCRIPTION App::Info::RDBMS::PostgreSQL supplies information about the PostgreSQL database server installed on the local system. It implements all of the methods defined by App::Info::RDBMS. Methods that trigger events will trigger them only the first time they're called (See L for documentation on handling events). To start over (after, say, someone has installed PostgreSQL) construct a new App::Info::RDBMS::PostgreSQL object to aggregate new metadata. Some of the methods trigger the same events. This is due to cross-calling of shared subroutines. However, any one event should be triggered no more than once. For example, although the info event "Executing `pg_config --version`" is documented for the methods C, C, C, C, and C, rest assured that it will only be triggered once, by whichever of those four methods is called first. =cut use strict; use App::Info::RDBMS; use App::Info::Util; use vars qw(@ISA $VERSION); @ISA = qw(App::Info::RDBMS); $VERSION = '0.45'; use constant WIN32 => $^O eq 'MSWin32'; my $u = App::Info::Util->new; my @EXES = qw(postgres createdb createlang createuser dropdb droplang dropuser initdb pg_dump pg_dumpall pg_restore postmaster vacuumdb psql); =head1 INTERFACE =head2 Constructor =head3 new my $pg = App::Info::RDBMS::PostgreSQL->new(@params); Returns an App::Info::RDBMS::PostgreSQL object. See L for a complete description of argument parameters. When it called, C searches the file system for an executable named for the list returned by C, usually F, in the list of directories returned by C. If found, F will be called by the object methods below to gather the data necessary for each. If F cannot be found, then PostgreSQL is assumed not to be installed, and each of the object methods will return C. C also takes a number of optional parameters in addition to those documented for App::Info. These parameters allow you to specify alternate names for PostgreSQL executables (other than F, which you specify via the C parameter). These parameters are: =over =item search_postgres_names =item search_createdb_names =item search_createlang_names =item search_createuser_names =item search_dropd_names =item search_droplang_names =item search_dropuser_names =item search_initdb_names =item search_pg_dump_names =item search_pg_dumpall_names =item search_pg_restore_names =item search_postmaster_names =item search_psql_names =item search_vacuumdb_names =back B =over 4 =item info Looking for pg_config =item confirm Path to pg_config? =item unknown Path to pg_config? =back =cut sub new { # Construct the object. my $self = shift->SUPER::new(@_); # Find pg_config. $self->info("Looking for pg_config"); my @paths = $self->search_bin_dirs; my @exes = $self->search_exe_names; if (my $cfg = $u->first_cat_exe(\@exes, @paths) and !$ENV{DBDPG_TESTINITDB}) { # We found it. Confirm. $self->{pg_config} = $self->confirm( key => 'pg_config', prompt => "Path to pg_config?", value => $cfg, callback => sub { -x }, error => 'Not an executable'); } else { # Handle an unknown value. $self->{pg_config} = $self->unknown( key => 'pg_config', prompt => "Path to pg_config?", callback => sub { -x }, error => 'Not an executable'); } # Set up search defaults. for my $exe (@EXES) { my $attr = "search_$exe\_names"; if (exists $self->{$attr}) { $self->{$attr} = [$self->{$attr}] unless ref $self->{$attr} eq 'ARRAY'; } else { $self->{$attr} = []; } } return $self; } # We'll use this code reference as a common way of collecting data. my $get_data = sub { return unless $_[0]->{pg_config}; $_[0]->info(qq{Executing `"$_[0]->{pg_config}" $_[1]`}); my $info = `"$_[0]->{pg_config}" $_[1]`; chomp $info; return $info; }; ############################################################################## =head2 Class Method =head3 key_name my $key_name = App::Info::RDBMS::PostgreSQL->key_name; Returns the unique key name that describes this class. The value returned is the string "PostgreSQL". =cut sub key_name { 'PostgreSQL' } ############################################################################## =head2 Object Methods =head3 installed print "PostgreSQL is ", ($pg->installed ? '' : 'not '), "installed.\n"; Returns true if PostgreSQL is installed, and false if it is not. App::Info::RDBMS::PostgreSQL determines whether PostgreSQL is installed based on the presence or absence of the F application on the file system as found when C constructed the object. If PostgreSQL does not appear to be installed, then all of the other object methods will return empty values. =cut sub installed { return $_[0]->{pg_config} ? 1 : undef } ############################################################################## =head3 name my $name = $pg->name; Returns the name of the application. App::Info::RDBMS::PostgreSQL parses the name from the system call C<`pg_config --version`>. B =over 4 =item info Executing `pg_config --version` =item error Failed to find PostgreSQL version with `pg_config --version` Unable to parse name from string Unable to parse version from string Failed to parse PostgreSQL version parts from string =item unknown Enter a valid PostgreSQL name =back =cut # This code reference is used by name(), version(), major_version(), # minor_version(), and patch_version() to aggregate the data they need. my $get_version = sub { my $self = shift; $self->{'--version'} = 1; my $data = $get_data->($self, '--version'); unless ($data) { $self->error("Failed to find PostgreSQL version with ". "`$self->{pg_config} --version`"); return; } chomp $data; my ($name, $version) = split /\s+/, $data, 2; # Check for and assign the name. $name ? $self->{name} = $name : $self->error("Unable to parse name from string '$data'"); # Parse the version number. if ($version) { my ($x, $y, $z) = $version =~ /(\d+)\.(\d+).(\d+)/; if (defined $x and defined $y and defined $z) { # Beta/devel/release candidates are treated as patch level "0" @{$self}{qw(version major minor patch)} = ($version, $x, $y, $z); } elsif ($version =~ /(\d+)\.(\d+)/) { # New versions, such as "7.4", are treated as patch level "0" @{$self}{qw(version major minor patch)} = ($version, $1, $2, 0); } else { $self->error("Failed to parse PostgreSQL version parts from " . "string '$version'"); } } else { $self->error("Unable to parse version from string '$data'"); } }; sub name { my $self = shift; return unless $self->{pg_config}; # Load data. $get_version->($self) unless $self->{'--version'}; # Handle an unknown name. $self->{name} ||= $self->unknown( key => 'name' ); # Return the name. return $self->{name}; } ############################################################################## =head3 version my $version = $pg->version; Returns the PostgreSQL version number. App::Info::RDBMS::PostgreSQL parses the version number from the system call C<`pg_config --version`>. B =over 4 =item info Executing `pg_config --version` =item error Failed to find PostgreSQL version with `pg_config --version` Unable to parse name from string Unable to parse version from string Failed to parse PostgreSQL version parts from string =item unknown Enter a valid PostgreSQL version number =back =cut sub version { my $self = shift; return unless $self->{pg_config}; # Load data. $get_version->($self) unless $self->{'--version'}; # Handle an unknown value. unless ($self->{version}) { # Create a validation code reference. my $chk_version = sub { # Try to get the version number parts. my ($x, $y, $z) = /^(\d+)\.(\d+).(\d+)$/; # Return false if we didn't get all three. return unless $x and defined $y and defined $z; # Save all three parts. @{$self}{qw(major minor patch)} = ($x, $y, $z); # Return true. return 1; }; $self->{version} = $self->unknown( key => 'version number', callback => $chk_version); } return $self->{version}; } ############################################################################## =head3 major version my $major_version = $pg->major_version; Returns the PostgreSQL major version number. App::Info::RDBMS::PostgreSQL parses the major version number from the system call C<`pg_config --version`>. For example, C returns "7.1.2", then this method returns "7". B =over 4 =item info Executing `pg_config --version` =item error Failed to find PostgreSQL version with `pg_config --version` Unable to parse name from string Unable to parse version from string Failed to parse PostgreSQL version parts from string =item unknown Enter a valid PostgreSQL major version number =back =cut # This code reference is used by major_version(), minor_version(), and # patch_version() to validate a version number entered by a user. my $is_int = sub { /^\d+$/ }; sub major_version { my $self = shift; return unless $self->{pg_config}; # Load data. $get_version->($self) unless exists $self->{'--version'}; # Handle an unknown value. $self->{major} = $self->unknown( key => 'major version number', callback => $is_int) unless $self->{major}; return $self->{major}; } ############################################################################## =head3 minor version my $minor_version = $pg->minor_version; Returns the PostgreSQL minor version number. App::Info::RDBMS::PostgreSQL parses the minor version number from the system call C<`pg_config --version`>. For example, if C returns "7.1.2", then this method returns "2". B =over 4 =item info Executing `pg_config --version` =item error Failed to find PostgreSQL version with `pg_config --version` Unable to parse name from string Unable to parse version from string Failed to parse PostgreSQL version parts from string =item unknown Enter a valid PostgreSQL minor version number =back =cut sub minor_version { my $self = shift; return unless $self->{pg_config}; # Load data. $get_version->($self) unless exists $self->{'--version'}; # Handle an unknown value. $self->{minor} = $self->unknown( key => 'minor version number', callback => $is_int) unless defined $self->{minor}; return $self->{minor}; } ############################################################################## =head3 patch version my $patch_version = $pg->patch_version; Returns the PostgreSQL patch version number. App::Info::RDBMS::PostgreSQL parses the patch version number from the system call C<`pg_config --version`>. For example, if C returns "7.1.2", then this method returns "1". B =over 4 =item info Executing `pg_config --version` =item error Failed to find PostgreSQL version with `pg_config --version` Unable to parse name from string Unable to parse version from string Failed to parse PostgreSQL version parts from string =item unknown Enter a valid PostgreSQL minor version number =back =cut sub patch_version { my $self = shift; return unless $self->{pg_config}; # Load data. $get_version->($self) unless exists $self->{'--version'}; # Handle an unknown value. $self->{patch} = $self->unknown( key => 'patch version number', callback => $is_int) unless defined $self->{patch}; return $self->{patch}; } ############################################################################## =head3 executable my $exe = $pg->executable; Returns the full path to the PostgreSQL server executable, which is named F. This method does not use the executable names returned by C; those executable names are used to search for F only (in C). When it called, C checks for an executable named F in the directory returned by C. Note that C is simply an alias for C. B =over 4 =item info Looking for postgres executable =item confirm Path to postgres executable? =item unknown Path to postgres executable? =back =cut my $find_exe = sub { my ($self, $key) = @_; my $exe = $key . (WIN32 ? '.exe' : ''); my $meth = "search_$key\_names"; # Find executable. $self->info("Looking for $key"); unless ($self->{$key}) { my $bin = $self->bin_dir or return; if (my $exe = $u->first_cat_exe([$self->$meth(), $exe], $bin)) { # We found it. Confirm. $self->{$key} = $self->confirm( key => $key, prompt => "Path to $key executable?", value => $exe, callback => sub { -x }, error => 'Not an executable' ); } else { # Handle an unknown value. $self->{$key} = $self->unknown( key => $key, prompt => "Path to $key executable?", callback => sub { -x }, error => 'Not an executable' ); } } return $self->{$key}; }; for my $exe (@EXES) { no strict 'refs'; *{$exe} = sub { shift->$find_exe($exe) }; *{"search_$exe\_names"} = sub { @{ shift->{"search_$exe\_names"} } } } *executable = \&postgres; ############################################################################## =head3 bin_dir my $bin_dir = $pg->bin_dir; Returns the PostgreSQL binary directory path. App::Info::RDBMS::PostgreSQL gathers the path from the system call C<`pg_config --bindir`>. B =over 4 =item info Executing `pg_config --bindir` =item error Cannot find bin directory =item unknown Enter a valid PostgreSQL bin directory =back =cut # This code reference is used by bin_dir(), lib_dir(), and so_lib_dir() to # validate a directory entered by the user. my $is_dir = sub { -d }; sub bin_dir { my $self = shift; return unless $self->{pg_config}; unless (exists $self->{bin_dir} ) { if (my $dir = $get_data->($self, '--bindir')) { $self->{bin_dir} = $dir; } else { # Handle an unknown value. $self->error("Cannot find bin directory"); $self->{bin_dir} = $self->unknown( key => 'bin directory', callback => $is_dir) } } return $self->{bin_dir}; } ############################################################################## =head3 inc_dir my $inc_dir = $pg->inc_dir; Returns the PostgreSQL include directory path. App::Info::RDBMS::PostgreSQL gathers the path from the system call C<`pg_config --includedir`>. B =over 4 =item info Executing `pg_config --includedir` =item error Cannot find include directory =item unknown Enter a valid PostgreSQL include directory =back =cut sub inc_dir { my $self = shift; return unless $self->{pg_config}; unless (exists $self->{inc_dir} ) { if (my $dir = $get_data->($self, '--includedir')) { $self->{inc_dir} = $dir; } else { # Handle an unknown value. $self->error("Cannot find include directory"); $self->{inc_dir} = $self->unknown( key => 'include directory', callback => $is_dir) } } return $self->{inc_dir}; } ############################################################################## =head3 lib_dir my $lib_dir = $pg->lib_dir; Returns the PostgreSQL library directory path. App::Info::RDBMS::PostgreSQL gathers the path from the system call C<`pg_config --libdir`>. B =over 4 =item info Executing `pg_config --libdir` =item error Cannot find library directory =item unknown Enter a valid PostgreSQL library directory =back =cut sub lib_dir { my $self = shift; return unless $self->{pg_config}; unless (exists $self->{lib_dir} ) { if (my $dir = $get_data->($self, '--libdir')) { $self->{lib_dir} = $dir; } else { # Handle an unknown value. $self->error("Cannot find library directory"); $self->{lib_dir} = $self->unknown( key => 'library directory', callback => $is_dir) } } return $self->{lib_dir}; } ############################################################################## =head3 so_lib_dir my $so_lib_dir = $pg->so_lib_dir; Returns the PostgreSQL shared object library directory path. App::Info::RDBMS::PostgreSQL gathers the path from the system call C<`pg_config --pkglibdir`>. B =over 4 =item info Executing `pg_config --pkglibdir` =item error Cannot find shared object library directory =item unknown Enter a valid PostgreSQL shared object library directory =back =cut # Location of dynamically loadable modules. sub so_lib_dir { my $self = shift; return unless $self->{pg_config}; unless (exists $self->{so_lib_dir} ) { if (my $dir = $get_data->($self, '--pkglibdir')) { $self->{so_lib_dir} = $dir; } else { # Handle an unknown value. $self->error("Cannot find shared object library directory"); $self->{so_lib_dir} = $self->unknown( key => 'shared object library directory', callback => $is_dir) } } return $self->{so_lib_dir}; } ############################################################################## =head3 configure options my $configure = $pg->configure; Returns the options with which the PostgreSQL server was configured. App::Info::RDBMS::PostgreSQL gathers the configure data from the system call C<`pg_config --configure`>. B =over 4 =item info Executing `pg_config --configure` =item error Cannot find configure information =item unknown Enter PostgreSQL configuration options =back =cut sub configure { my $self = shift; return unless $self->{pg_config}; unless (exists $self->{configure} ) { if (my $conf = $get_data->($self, '--configure')) { $self->{configure} = $conf; } else { # Configure can be empty, so just make sure it exists and is # defined. Don't prompt. $self->{configure} = ''; } } return $self->{configure}; } ############################################################################## =head3 home_url my $home_url = $pg->home_url; Returns the PostgreSQL home page URL. =cut sub home_url { "http://www.postgresql.org/" } ############################################################################## =head3 download_url my $download_url = $pg->download_url; Returns the PostgreSQL download URL. =cut sub download_url { "http://www.postgresql.org/mirrors-ftp.html" } ############################################################################## =head3 search_exe_names my @search_exe_names = $app->search_exe_names; Returns a list of possible names for F executable. By default, only F is returned (or F on Win32). Note that this method is not used to search for the PostgreSQL server executable, only F. =cut sub search_exe_names { my $self = shift; my $exe = 'pg_config'; $exe .= '.exe' if WIN32; return ($self->SUPER::search_exe_names, $exe); } ############################################################################## =head3 search_bin_dirs my @search_bin_dirs = $app->search_bin_dirs; Returns a list of possible directories in which to search an executable. Used by the C constructor to find an executable to execute and collect application info. The found directory will also be returned by the C method. The list of directories by default consists of the path as defined by C<< File::Spec->path >>, as well as the following directories: =over 4 =item $ENV{POSTGRES_HOME}/bin (if $ENV{POSTGRES_HOME} exists) =item $ENV{POSTGRES_LIB}/../bin (if $ENV{POSTGRES_LIB} exists) =item /usr/local/pgsql/bin =item /usr/local/postgres/bin =item /opt/pgsql/bin =item /usr/local/bin =item /usr/local/sbin =item /usr/bin =item /usr/sbin =item /bin =item C:\Program Files\PostgreSQL\bin =back =cut sub search_bin_dirs { return shift->SUPER::search_bin_dirs, ( exists $ENV{POSTGRES_HOME} ? ($u->catdir($ENV{POSTGRES_HOME}, "bin")) : () ), ( exists $ENV{POSTGRES_LIB} ? ($u->catdir($ENV{POSTGRES_LIB}, $u->updir, "bin")) : () ), $u->path, qw(/usr/local/pgsql/bin /usr/local/postgres/bin /usr/lib/postgresql/bin /opt/pgsql/bin /usr/local/bin /usr/local/sbin /usr/bin /usr/sbin /bin), 'C:\Program Files\PostgreSQL\bin'; } ############################################################################## =head2 Other Executable Methods These methods function just like the C method, except that they return different executables. PostgreSQL comes with a fair number of them; we provide these methods to provide a path to a subset of them. Each method, when called, checks for an executable in the directory returned by C. The name of the executable must be one of the names returned by the corresponding C method. The available executable methods are: =over =item postgres =item createdb =item createlang =item createuser =item dropdb =item droplang =item dropuser =item initdb =item pg_dump =item pg_dumpall =item pg_restore =item postmaster =item psql =item vacuumdb =back And the corresponding search names methods are: =over =item search_postgres_names =item search_createdb_names =item search_createlang_names =item search_createuser_names =item search_dropd_names =item search_droplang_names =item search_dropuser_names =item search_initdb_names =item search_pg_dump_names =item search_pg_dumpall_names =item search_pg_restore_names =item search_postmaster_names =item search_psql_names =item search_vacuumdb_names =back B =over 4 =item info Looking for executable =item confirm Path to executable? =item unknown Path to executable? =back =cut 1; __END__ =head1 BUGS Please send bug reports to or file them at L. =head1 AUTHOR David Wheeler based on code by Sam Tregar . =head1 SEE ALSO L documents the event handling interface. L is the App::Info::RDBMS::PostgreSQL parent class. L is the L driver for connecting to PostgreSQL databases. L is the PostgreSQL home page. =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2004, David Wheeler. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-2.19.3/t/lib/App/Info/Handler.pm0000644000076400007640000002466311642756716015576 0ustar greggregpackage App::Info::Handler; =head1 NAME App::Info::Handler - App::Info event handler base class =head1 SYNOPSIS use App::Info::Category::FooApp; use App::Info::Handler; my $app = App::Info::Category::FooApp->new( on_info => ['default'] ); =head1 DESCRIPTION This class defines the interface for subclasses that wish to handle events triggered by App::Info concrete subclasses. The different types of events triggered by App::Info can all be handled by App::Info::Handler (indeed, by default they're all handled by a single App::Info::Handler object), and App::Info::Handler subclasses may be designed to handle whatever events they wish. If you're interested in I an App::Info event handler, this is probably not the class you should look at, since all it does is define a simple handler that does nothing with an event. Look to the L included in this distribution to do more interesting things with App::Info events. If, on the other hand, you're interested in implementing your own event handlers, read on! =cut use strict; use vars qw($VERSION); $VERSION = '0.45'; my %handlers; =head1 INTERFACE This section documents the public interface of App::Info::Handler. =head2 Class Method =head3 register_handler App::Info::Handler->register_handler( $key => $code_ref ); This class method may be used by App::Info::Handler subclasses to register themselves with App::Info::Handler. Multiple registrations are supported. The idea is that a subclass can define different functionality by specifying different strings that represent different modes of constructing an App::Info::Handler subclass object. The keys are case-sensitve, and should be unique across App::Info::Handler subclasses so that many subclasses can be loaded and used separately. If the C<$key> is already registered, C will throw an exception. The values are code references that, when executed, return the appropriate App::Info::Handler subclass object. =cut sub register_handler { my ($pkg, $key, $code) = @_; Carp::croak("Handler '$key' already exists") if $handlers{$key}; $handlers{$key} = $code; } # Register ourself. __PACKAGE__->register_handler('default', sub { __PACKAGE__->new } ); ############################################################################## =head2 Constructor =head3 new my $handler = App::Info::Handler->new; $handler = App::Info::Handler->new( key => $key); Constructs an App::Info::Handler object and returns it. If the key parameter is provided and has been registered by an App::Info::Handler subclass via the C class method, then the relevant code reference will be executed and the resulting App::Info::Handler subclass object returned. This approach provides a handy shortcut for having C behave as an abstract factory method, returning an object of the subclass appropriate to the key parameter. =cut sub new { my ($pkg, %p) = @_; my $class = ref $pkg || $pkg; $p{key} ||= 'default'; if ($class eq __PACKAGE__ && $p{key} ne 'default') { # We were called directly! Handle it. Carp::croak("No such handler '$p{key}'") unless $handlers{$p{key}}; return $handlers{$p{key}}->(); } else { # A subclass called us -- just instantiate and return. return bless \%p, $class; } } =head2 Instance Method =head3 handler $handler->handler($req); App::Info::Handler defines a single instance method that must be defined by its subclasses, C. This is the method that will be executed by an event triggered by an App::Info concrete subclass. It takes as its single argument an App::Info::Request object, and returns a true value if it has handled the event request. Returning a false value declines the request, and App::Info will then move on to the next handler in the chain. The C method implemented in App::Info::Handler itself does nothing more than return a true value. It thus acts as a very simple default event handler. See the App::Info::Handler subclasses for more interesting handling of events, or create your own! =cut sub handler { 1 } 1; __END__ =head1 SUBCLASSING I hatched the idea of the App::Info event model with its subclassable handlers as a way of separating the aggregation of application metadata from writing a user interface for handling certain conditions. I felt it a better idea to allow people to create their own user interfaces, and instead to provide only a few examples. The App::Info::Handler class defines the API interface for handling these conditions, which App::Info refers to as "events". There are various types of events defined by App::Info ("info", "error", "unknown", and "confirm"), but the App::Info::Handler interface is designed to be flexible enough to handle any and all of them. If you're interested in creating your own App::Info event handler, this is the place to learn how. =head2 The Interface To create an App::Info event handler, all one need do is subclass App::Info::Handler and then implement the C constructor and the C method. The C constructor can do anything you like, and take any arguments you like. However, I do recommend that the first thing you do in your implementation is to call the super constructor: sub new { my $pkg = shift; my $self = $pkg->SUPER::new(@_); # ... other stuff. return $self; } Although the default C constructor currently doesn't do much, that may change in the future, so this call will keep you covered. What it does do is take the parameterized arguments and assign them to the App::Info::Handler object. Thus if you've specified a "mode" argument, where clients can construct objects of you class like this: my $handler = FooHandler->new( mode => 'foo' ); You can access the mode parameter directly from the object, like so: sub new { my $pkg = shift; my $self = $pkg->SUPER::new(@_); if ($self->{mode} eq 'foo') { # ... } return $self; } Just be sure not to use a parameter key name required by App::Info::Handler itself. At the moment, the only parameter accepted by App::Info::Handler is "key", so in general you'll be pretty safe. Next, I recommend that you take advantage of the C method to create some shortcuts for creating handlers of your class. For example, say we're creating a handler subclass FooHandler. It has two modes, a default "foo" mode and an advanced "bar" mode. To allow both to be constructed by stringified shortcuts, the FooHandler class implementation might start like this: package FooHandler; use strict; use App::Info::Handler; use vars qw(@ISA); @ISA = qw(App::Info::Handler); foreach my $c (qw(foo bar)) { App::Info::Handler->register_handler ( $c => sub { __PACKAGE__->new( mode => $c) } ); } The strings "foo" and "bar" can then be used by clients as shortcuts to have App::Info objects automatically create and use handlers for certain events. For example, if a client wanted to use a "bar" event handler for its info events, it might do this: use App::Info::Category::FooApp; use FooHandler; my $app = App::Info::Category::FooApp->new(on_info => ['bar']); Take a look at App::Info::Handler::Print and App::Info::Handler::Carp to see concrete examples of C usage. The final step in creating a new App::Info event handler is to implement the C method itself. This method takes a single argument, an App::Info::Request object, and is expected to return true if it handled the request, and false if it did not. The App::Info::Request object contains all the metadata relevant to a request, including the type of event that triggered it; see L for its documentation. Use the App::Info::Request object however you like to handle the request however you like. You are, however, expected to abide by a a few guidelines: =over 4 =item * For error and info events, you are expected (but not required) to somehow display the info or error message for the user. How your handler chooses to do so is up to you and the handler. =item * For unknown and confirm events, you are expected to prompt the user for a value. If it's a confirm event, offer the known value (found in C<< $req->value >>) as a default. =item * For unknown and confirm events, you are expected to call C<< $req->callback >> and pass in the new value. If C<< $req->callback >> returns a false value, you are expected to display the error message in C<< $req->error >> and prompt the user again. Note that C<< $req->value >> calls C<< $req->callback >> internally, and thus assigns the value and returns true if C<< $req->callback >> returns true, and does not assign the value and returns false if C<< $req->callback >> returns false. =item * For unknown and confirm events, if you've collected a new value and C<< $req->callback >> returns true for that value, you are expected to assign the value by passing it to C<< $req->value >>. This allows App::Info to give the value back to the calling App::Info concrete subclass. =back Probably the easiest way to get started creating new App::Info event handlers is to check out the simple handlers provided with the distribution and follow their logical examples. Consult the App::Info documentation of the L for details on how App::Info constructs the App::Info::Request object for each event type. =head1 BUGS Please send bug reports to or file them at L. =head1 AUTHOR David Wheeler =head1 SEE ALSO L thoroughly documents the client interface for setting event handlers, as well as the event triggering interface for App::Info concrete subclasses. L documents the interface for the request objects passed to App::Info::Handler C methods. The following App::Info::Handler subclasses offer examples for event handler authors, and, of course, provide actual event handling functionality for App::Info clients. =over 4 =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2004, David Wheeler. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-2.19.3/t/lib/App/Info.pm0000644000076400007640000013475611642756716014226 0ustar greggregpackage App::Info; =head1 NAME App::Info - Information about software packages on a system =head1 SYNOPSIS use App::Info::Category::FooApp; my $app = App::Info::Category::FooApp->new; if ($app->installed) { print "App name: ", $app->name, "\n"; print "Version: ", $app->version, "\n"; print "Bin dir: ", $app->bin_dir, "\n"; } else { print "App not installed on your system. :-(\n"; } =head1 DESCRIPTION App::Info is an abstract base class designed to provide a generalized interface for subclasses that provide metadata about software packages installed on a system. The idea is that these classes can be used in Perl application installers in order to determine whether software dependencies have been fulfilled, and to get necessary metadata about those software packages. App::Info provides an event model for handling events triggered by App::Info subclasses. The events are classified as "info", "error", "unknown", and "confirm" events, and multiple handlers may be specified to handle any or all of these event types. This allows App::Info clients to flexibly handle events in any way they deem necessary. Implementing new event handlers is straight-forward, and use the triggering of events by App::Info subclasses is likewise kept easy-to-use. A few L are provided with the distribution, but others are invited to write their own subclasses and contribute them to the CPAN. Contributors are welcome to extend their subclasses to provide more information relevant to the application for which data is to be provided (see L for an example), but are encouraged to, at a minimum, implement the abstract methods defined here and in the category abstract base classes (e.g., L and L). See L for more information on implementing new subclasses. =cut use strict; use Carp (); use App::Info::Handler; use App::Info::Request; use vars qw($VERSION); $VERSION = '0.45'; ############################################################################## ############################################################################## # This code ref is used by the abstract methods to throw an exception when # they're called directly. my $croak = sub { my ($caller, $meth) = @_; $caller = ref $caller || $caller; if ($caller eq __PACKAGE__) { $meth = __PACKAGE__ . '::' . $meth; Carp::croak(__PACKAGE__ . " is an abstract base class. Attempt to " . " call non-existent method $meth"); } else { Carp::croak("Class $caller inherited from the abstract base class " . __PACKAGE__ . ", but failed to redefine the $meth() " . "method. Attempt to call non-existent method " . "${caller}::$meth"); } }; ############################################################################## # This code reference is used by new() and the on_* error handler methods to # set the error handlers. my $set_handlers = sub { my $on_key = shift; # Default is to do nothing. return unless $on_key; my $ref = ref $on_key; if ($ref) { $on_key = [$on_key] unless $ref eq 'ARRAY'; # Make sure they're all handlers. foreach my $h (@$on_key) { if (my $r = ref $h) { Carp::croak("$r object is not an App::Info::Handler") unless UNIVERSAL::isa($h, 'App::Info::Handler'); } else { # Look up the handler. $h = App::Info::Handler->new( key => $h); } } # Return 'em! return @$on_key; } else { # Look up the handler. return App::Info::Handler->new( key => $on_key); } }; ############################################################################## ############################################################################## =head1 INTERFACE This section documents the public interface of App::Info. =head2 Constructor =head3 new my $app = App::Info::Category::FooApp->new(@params); Constructs an App::Info object and returns it. The @params arguments define attributes that can be used to help the App::Info object search for application information on the file system, as well as how the App::Info object will respond to certain events. The event parameters correspond to their like-named methods. See the L<"Event Handler Object Methods"> section for more information on App::Info events and how to handle them. The search parameters that can be passed to C are: =over =item search_exe_names An array reference of possible names for binary executables. These may be used by subclases to search for application programs that can be used to retreive application information, such as version numbers. The subclasses generally provide reasonable defaults for most cases. =item search_bin_dirs An array reference of local directories in which to search for executables. These may be used to search for the value of the C attribute in addition to and in preference to the defaults used by each subclass. =item search_lib_names An array reference of possible names for library files. These may be used by subclases to search for library files for the application. The subclasses generally provide reasonable defaults for most cases. =item search_so_lib_names An array reference of possible names for shared object library files. These may be used by subclases to search for shared object library files for the application. The subclasses generally provide reasonable defaults for most cases. =item search_lib_dirs An array reference of local directories in which to search for libraries. These may be used to search for the value of the C and C attributes in addition to and in preference to the defaults used by each subclass. =item search_inc_names An array reference of possible names for include files. These may be used by subclases to search for include files for the application. The subclasses generally provide reasonable defaults for most cases. =item search_inc_dirs An array reference of local directories in which to search for include files. These may be used to search for the value of the C attribute in addition to and in preference to the defaults used by each subclass. =back The parameters to C for the different types of App::Info events are: =over 4 =item on_info =item on_error =item on_unknown =item on_confirm =back When passing event handlers to C, the list of handlers for each type should be an anonymous array, for example: my $app = App::Info::Category::FooApp->new( on_info => \@handlers ); =cut sub new { my ($pkg, %p) = @_; my $class = ref $pkg || $pkg; # Fail if the method isn't overridden. $croak->($pkg, 'new') if $class eq __PACKAGE__; # Set up handlers. for (qw(on_error on_unknown on_info on_confirm)) { $p{$_} = [$set_handlers->($p{$_})]; } # Set up search defaults. for (qw(bin_dirs lib_dirs inc_dirs exe_names lib_names inc_names so_lib_names)) { local $_ = "search_$_"; if (exists $p{$_}) { $p{$_} = [$p{$_}] unless ref $p{$_} eq 'ARRAY'; } else { $p{$_} = []; } } # Do it! return bless \%p, $class; } ############################################################################## ############################################################################## =head2 Metadata Object Methods These are abstract methods in App::Info and must be provided by its subclasses. They provide the essential metadata of the software package supported by the App::Info subclass. =head3 key_name my $key_name = $app->key_name; Returns a string that uniquely identifies the software for which the App::Info subclass provides data. This value should be unique across all App::Info classes. Typically, it's simply the name of the software. =cut sub key_name { $croak->(shift, 'key_name') } =head3 installed if ($app->installed) { print "App is installed.\n" } else { print "App is not installed.\n" } Returns a true value if the application is installed, and a false value if it is not. =cut sub installed { $croak->(shift, 'installed') } ############################################################################## =head3 name my $name = $app->name; Returns the name of the application. =cut sub name { $croak->(shift, 'name') } ############################################################################## =head3 version my $version = $app->version; Returns the full version number of the application. =cut ############################################################################## sub version { $croak->(shift, 'version') } =head3 major_version my $major_version = $app->major_version; Returns the major version number of the application. For example, if C returns "7.1.2", then this method returns "7". =cut sub major_version { $croak->(shift, 'major_version') } ############################################################################## =head3 minor_version my $minor_version = $app->minor_version; Returns the minor version number of the application. For example, if C returns "7.1.2", then this method returns "1". =cut sub minor_version { $croak->(shift, 'minor_version') } ############################################################################## =head3 patch_version my $patch_version = $app->patch_version; Returns the patch version number of the application. For example, if C returns "7.1.2", then this method returns "2". =cut sub patch_version { $croak->(shift, 'patch_version') } ############################################################################## =head3 bin_dir my $bin_dir = $app->bin_dir; Returns the full path the application's bin directory, if it exists. =cut sub bin_dir { $croak->(shift, 'bin_dir') } ############################################################################## =head3 executable my $executable = $app->executable; Returns the full path the application's bin directory, if it exists. =cut sub executable { $croak->(shift, 'executable') } ############################################################################## =head3 inc_dir my $inc_dir = $app->inc_dir; Returns the full path the application's include directory, if it exists. =cut sub inc_dir { $croak->(shift, 'inc_dir') } ############################################################################## =head3 lib_dir my $lib_dir = $app->lib_dir; Returns the full path the application's lib directory, if it exists. =cut sub lib_dir { $croak->(shift, 'lib_dir') } ############################################################################## =head3 so_lib_dir my $so_lib_dir = $app->so_lib_dir; Returns the full path the application's shared library directory, if it exists. =cut sub so_lib_dir { $croak->(shift, 'so_lib_dir') } ############################################################################## =head3 home_url my $home_url = $app->home_url; The URL for the software's home page. =cut sub home_url { $croak->(shift, 'home_url') } ############################################################################## =head3 download_url my $download_url = $app->download_url; The URL for the software's download page. =cut sub download_url { $croak->(shift, 'download_url') } ############################################################################## ############################################################################## =head2 Search Attributes These methods return lists of things to look for on the local file system when searching for appliation programs, library files, and include files. They are empty by default, since each subclass generally relies on its own settings, but you can add your own as preferred search parameters by specifying them as parameters to the C constructor. =head3 exe_names my @search_exe_names = $app->search_exe_names; Returns a list of possible names for an executable. Typically used by the C constructor to search fo an executable to execute and collect application info. =cut sub search_exe_names { @{shift->{search_exe_names}} } ############################################################################## =head3 search_bin_dirs my @search_bin_dirs = $app->search_bin_dirs; Returns a list of possible directories in which to search an executable. Typically used by the C constructor to find an executable to execute and collect application info. The found directory will also generally then be returned by the C method. =cut sub search_bin_dirs { @{shift->{search_bin_dirs}} } ############################################################################## =head3 lib_names my @search_lib_names = $app->search_lib_names; Returns a list of possible names for library files. Typically used by the C method to find library files. =cut sub search_lib_names { @{shift->{search_lib_names}} } ############################################################################## =head3 so_lib_names my @search_so_lib_names = $app->search_so_lib_names; Returns a list of possible names for library files. Typically used by the C method to find shared object library files. =cut sub search_so_lib_names { @{shift->{search_so_lib_names}} } ############################################################################## =head3 search_lib_dirs my @search_lib_dirs = $app->search_lib_dirs; Returns a list of possible directories in which to search for libraries. Typically used by the C and C methods to find library files. =cut sub search_lib_dirs { @{shift->{search_lib_dirs}} } ############################################################################## =head3 inc_names my @search_inc_names = $app->search_inc_names; Returns a list of possible names for include files. Typically used by the C method to find include files. =cut sub search_inc_names { @{shift->{search_inc_names}} } ############################################################################## =head3 search_inc_dirs my @search_inc_dirs = $app->search_inc_dirs; Returns a list of possible directories in which to search for includes. Typically used by the C method to find include files. =cut sub search_inc_dirs { @{shift->{search_inc_dirs}} } ############################################################################## ############################################################################## =head2 Event Handler Object Methods These methods provide control over App::Info event handling. Events can be handled by one or more objects of subclasses of App::Info::Handler. The first to return a true value will be the last to execute. This approach allows handlers to be stacked, and makes it relatively easy to create new handlers. L for information on writing event handlers. Each of the event handler methods takes a list of event handlers as its arguments. If none are passed, the existing list of handlers for the relevant event type will be returned. If new handlers are passed in, they will be returned. The event handlers may be specified as one or more objects of the App::Info::Handler class or subclasses, as one or more strings that tell App::Info construct such handlers itself, or a combination of the two. The strings can only be used if the relevant App::Info::Handler subclasses have registered strings with App::Info. For example, the App::Info::Handler::Print class included in the App::Info distribution registers the strings "stderr" and "stdout" when it starts up. These strings may then be used to tell App::Info to construct App::Info::Handler::Print objects that print to STDERR or to STDOUT, respectively. See the App::Info::Handler subclasses for what strings they register with App::Info. =head3 on_info my @handlers = $app->on_info; $app->on_info(@handlers); Info events are triggered when the App::Info subclass wants to send an informational status message. By default, these events are ignored, but a common need is for such messages to simply print to STDOUT. Use the L class included with the App::Info distribution to have info messages print to STDOUT: use App::Info::Handler::Print; $app->on_info('stdout'); # Or: my $stdout_handler = App::Info::Handler::Print->new('stdout'); $app->on_info($stdout_handler); =cut sub on_info { my $self = shift; @{ $self->{on_info} } = $set_handlers->(\@_) if @_; return @{ $self->{on_info} }; } =head3 on_error my @handlers = $app->on_error; $app->on_error(@handlers); Error events are triggered when the App::Info subclass runs into an unexpected but not fatal problem. (Note that fatal problems will likely throw an exception.) By default, these events are ignored. A common way of handling these events is to print them to STDERR, once again using the L class included with the App::Info distribution: use App::Info::Handler::Print; my $app->on_error('stderr'); # Or: my $stderr_handler = App::Info::Handler::Print->new('stderr'); $app->on_error($stderr_handler); Another approach might be to turn such events into fatal exceptions. Use the included L class for this purpose: use App::Info::Handler::Carp; my $app->on_error('croak'); # Or: my $croaker = App::Info::Handler::Carp->new('croak'); $app->on_error($croaker); =cut sub on_error { my $self = shift; @{ $self->{on_error} } = $set_handlers->(\@_) if @_; return @{ $self->{on_error} }; } =head3 on_unknown my @handlers = $app->on_unknown; $app->on_uknown(@handlers); Unknown events are trigged when the App::Info subclass cannot find the value to be returned by a method call. By default, these events are ignored. A common way of handling them is to have the application prompt the user for the relevant data. The App::Info::Handler::Prompt class included with the App::Info distribution can do just that: use App::Info::Handler::Prompt; my $app->on_unknown('prompt'); # Or: my $prompter = App::Info::Handler::Prompt; $app->on_unknown($prompter); See L for information on how it works. =cut sub on_unknown { my $self = shift; @{ $self->{on_unknown} } = $set_handlers->(\@_) if @_; return @{ $self->{on_unknown} }; } =head3 on_confirm my @handlers = $app->on_confirm; $app->on_confirm(@handlers); Confirm events are triggered when the App::Info subclass has found an important piece of information (such as the location of the executable it'll use to collect information for the rest of its methods) and wants to confirm that the information is correct. These events will most often be triggered during the App::Info subclass object construction. Here, too, the App::Info::Handler::Prompt class included with the App::Info distribution can help out: use App::Info::Handler::Prompt; my $app->on_confirm('prompt'); # Or: my $prompter = App::Info::Handler::Prompt; $app->on_confirm($prompter); =cut sub on_confirm { my $self = shift; @{ $self->{on_confirm} } = $set_handlers->(\@_) if @_; return @{ $self->{on_confirm} }; } ############################################################################## ############################################################################## =head1 SUBCLASSING As an abstract base class, App::Info is not intended to be used directly. Instead, you'll use concrete subclasses that implement the interface it defines. These subclasses each provide the metadata necessary for a given software package, via the interface outlined above (plus any additional methods the class author deems sensible for a given application). This section describes the facilities App::Info provides for subclassing. The goal of the App::Info design has been to make subclassing straight-forward, so that developers can focus on gathering the data they need for their application and minimize the work necessary to handle unknown values or to confirm values. As a result, there are essentially three concepts that developers need to understand when subclassing App::Info: organization, utility methods, and events. =head2 Organization The organizational idea behind App::Info is to name subclasses by broad software categories. This approach allows the categories themselves to function as abstract base classes that extend App::Info, so that they can specify more methods for all of their base classes to implement. For example, App::Info::HTTPD has specified the C abstract method that its subclasses must implement. So as you get ready to implement your own subclass, think about what category of software you're gathering information about. New categories can be added as necessary. =head2 Utility Methods Once you've decided on the proper category, you can start implementing your App::Info concrete subclass. As you do so, take advantage of App::Info::Util, wherein I've tried to encapsulate common functionality to make subclassing easier. I found that most of what I was doing repetitively was looking for files and directories, and searching through files. Thus, App::Info::Util subclasses L in order to offer easy access to commonly-used methods from that class, e.g., C. Plus, it has several of its own methods to assist you in finding files and directories in lists of files and directories, as well as methods for searching through files and returning the values found in those files. See L for more information, and the App::Info subclasses in this distribution for usage examples. I recommend the use of a package-scoped lexical App::Info::Util object. That way it's nice and handy when you need to carry out common tasks. If you find you're doing something over and over that's not already addressed by an App::Info::Util method, consider submitting a patch to App::Info::Util to add the functionality you need. =head2 Events Use the methods described below to trigger events. Events are designed to provide a simple way for App::Info subclass developers to send status messages and errors, to confirm data values, and to request a value when the class caonnot determine a value itself. Events may optionally be handled by module users who assign App::Info::Handler subclass objects to your App::Info subclass object using the event handling methods described in the L<"Event Handler Object Methods"> section. =cut ############################################################################## # This code reference is used by the event methods to manage the stack of # event handlers that may be available to handle each of the events. my $handler = sub { my ($self, $meth, $params) = @_; # Sanity check. We really want to keep control over this. Carp::croak("Cannot call protected method $meth()") unless UNIVERSAL::isa($self, scalar caller(1)); # Create the request object. $params->{type} ||= $meth; my $req = App::Info::Request->new(%$params); # Do the deed. The ultimate handling handler may die. foreach my $eh (@{$self->{"on_$meth"}}) { last if $eh->handler($req); } # Return the request. return $req; }; ############################################################################## =head3 info $self->info(@message); Use this method to display status messages for the user. You may wish to use it to inform users that you're searching for a particular file, or attempting to parse a file or some other resource for the data you need. For example, a common use might be in the object constructor: generally, when an App::Info object is created, some important initial piece of information is being sought, such as an executable file. That file may be in one of many locations, so it makes sense to let the user know that you're looking for it: $self->info("Searching for executable"); Note that, due to the nature of App::Info event handlers, your informational message may be used or displayed any number of ways, or indeed not at all (as is the default behavior). The C<@message> will be joined into a single string and stored in the C attribute of the App::Info::Request object passed to info event handlers. =cut sub info { my $self = shift; # Execute the handler sequence. my $req = $handler->($self, 'info', { message => join '', @_ }); } ############################################################################## =head3 error $self->error(@error); Use this method to inform the user that something unexpected has happened. An example might be when you invoke another program to parse its output, but it's output isn't what you expected: $self->error("Unable to parse version from `/bin/myapp -c`"); As with all events, keep in mind that error events may be handled in any number of ways, or not at all. The C<@erorr> will be joined into a single string and stored in the C attribute of the App::Info::Request object passed to error event handlers. If that seems confusing, think of it as an "error message" rather than an "error error." :-) =cut sub error { my $self = shift; # Execute the handler sequence. my $req = $handler->($self, 'error', { message => join '', @_ }); } ############################################################################## =head3 unknown my $val = $self->unknown(@params); Use this method when a value is unknown. This will give the user the option -- assuming the appropriate handler handles the event -- to provide the needed data. The value entered will be returned by C. The parameters are as follows: =over 4 =item key The C parameter uniquely identifies the data point in your class, and is used by App::Info to ensure that an unknown event is handled only once, no matter how many times the method is called. The same value will be returned by subsequent calls to C as was returned by the first call, and no handlers will be activated. Typical values are "version" and "lib_dir". =item prompt The C parameter is the prompt to be displayed should an event handler decide to prompt for the appropriate value. Such a prompt might be something like "Path to your httpd executable?". If this parameter is not provided, App::Info will construct one for you using your class' C method and the C parameter. The result would be something like "Enter a valid FooApp version". The C parameter value will be stored in the C attribute of the App::Info::Request object passed to event handlers. =item callback Assuming a handler has collected a value for your unknown data point, it might make sense to validate the value. For example, if you prompt the user for a directory location, and the user enters one, it makes sense to ensure that the directory actually exists. The C parameter allows you to do this. It is a code reference that takes the new value or values as its arguments, and returns true if the value is valid, and false if it is not. For the sake of convenience, the first argument to the callback code reference is also stored in C<$_> .This makes it easy to validate using functions or operators that, er, operate on C<$_> by default, but still allows you to get more information from C<@_> if necessary. For the directory example, a good callback might be C. The C parameter code reference will be stored in the C attribute of the App::Info::Request object passed to event handlers. =item error The error parameter is the error message to display in the event that the C code reference returns false. This message may then be used by the event handler to let the user know what went wrong with the data she entered. For example, if the unknown value was a directory, and the user entered a value that the C identified as invalid, a message to display might be something like "Invalid directory path". Note that if the C parameter is not provided, App::Info will supply the generic error message "Invalid value". This value will be stored in the C attribute of the App::Info::Request object passed to event handlers. =back This may be the event method you use most, as it should be called in every metadata method if you cannot provide the data needed by that method. It will typically be the last part of the method. Here's an example demonstrating each of the above arguments: my $dir = $self->unknown( key => 'lib_dir', prompt => "Enter lib directory path", callback => sub { -d }, error => "Not a directory"); =cut sub unknown { my ($self, %params) = @_; my $key = delete $params{key} or Carp::croak("No key parameter passed to unknown()"); # Just return the value if we've already handled this value. Ideally this # shouldn't happen. return $self->{__unknown__}{$key} if exists $self->{__unknown__}{$key}; # Create a prompt and error message, if necessary. $params{message} = delete $params{prompt} || "Enter a valid " . $self->key_name . " $key"; $params{error} ||= 'Invalid value'; # Execute the handler sequence. my $req = $handler->($self, "unknown", \%params); # Mark that we've provided this value and then return it. $self->{__unknown__}{$key} = $req->value; return $self->{__unknown__}{$key}; } ############################################################################## =head3 confirm my $val = $self->confirm(@params); This method is very similar to C, but serves a different purpose. Use this method for significant data points where you've found an appropriate value, but want to ensure it's really the correct value. A "significant data point" is usually a value essential for your class to collect metadata values. For example, you might need to locate an executable that you can then call to collect other data. In general, this will only happen once for an object -- during object construction -- but there may be cases in which it is needed more than that. But hopefully, once you've confirmed in the constructor that you've found what you need, you can use that information to collect the data needed by all of the metadata methods and can assume that they'll be right because that first, significant data point has been confirmed. Other than where and how often to call C, its use is quite similar to that of C. Its parameters are as follows: =over =item key Same as for C, a string that uniquely identifies the data point in your class, and ensures that the event is handled only once for a given key. The same value will be returned by subsequent calls to C as was returned by the first call for a given key. =item prompt Same as for C. Although C is called to confirm a value, typically the prompt should request the relevant value, just as for C. The difference is that the handler I use the C parameter as the default should the user not provide a value. The C parameter will be stored in the C attribute of the App::Info::Request object passed to event handlers. =item value The value to be confirmed. This is the value you've found, and it will be provided to the user as the default option when they're prompted for a new value. This value will be stored in the C attribute of the App::Info::Request object passed to event handlers. =item callback Same as for C. Because the user can enter data to replace the default value provided via the C parameter, you might want to validate it. Use this code reference to do so. The callback will be stored in the C attribute of the App::Info::Request object passed to event handlers. =item error Same as for C: an error message to display in the event that a value entered by the user isn't validated by the C code reference. This value will be stored in the C attribute of the App::Info::Request object passed to event handlers. =back Here's an example usage demonstrating all of the above arguments: my $exe = $self->confirm( key => 'shell', prompt => 'Path to your shell?', value => '/bin/sh', callback => sub { -x }, error => 'Not an executable'); =cut sub confirm { my ($self, %params) = @_; my $key = delete $params{key} or Carp::croak("No key parameter passed to confirm()"); return $self->{__confirm__}{$key} if exists $self->{__confirm__}{$key}; # Create a prompt and error message, if necessary. $params{message} = delete $params{prompt} || "Enter a valid " . $self->key_name . " $key"; $params{error} ||= 'Invalid value'; # Execute the handler sequence. my $req = $handler->($self, "confirm", \%params); # Mark that we've confirmed this value. $self->{__confirm__}{$key} = $req->value; return $self->{__confirm__}{$key} } 1; __END__ =head2 Event Examples Below I provide some examples demonstrating the use of the event methods. These are meant to emphasize the contexts in which it's appropriate to use them. Let's start with the simplest, first. Let's say that to find the version number for an application, you need to search a file for the relevant data. Your App::Info concrete subclass might have a private method that handles this work, and this method is the appropriate place to use the C and, if necessary, C methods. sub _find_version { my $self = shift; # Try to find the revelant file. We cover this method below. # Just return if we cant' find it. my $file = $self->_find_file('version.conf') or return; # Send a status message. $self->info("Searching '$file' file for version"); # Search the file. $util is an App::Info::Util object. my $ver = $util->search_file($file, qr/^Version\s+(.*)$/); # Trigger an error message, if necessary. We really think we'll have the # value, but we have to cover our butts in the unlikely event that we're # wrong. $self->error("Unable to find version in file '$file'") unless $ver; # Return the version number. return $ver; } Here we've used the C method to display a status message to let the user know what we're doing. Then we used the C method when something unexpected happened, which in this case was that we weren't able to find the version number in the file. Note the C<_find_file()> method we've thrown in. This might be a method that we call whenever we need to find a file that might be in one of a list of directories. This method, too, will be an appropriate place for an C method call. But rather than call the C method when the file can't be found, you might want to give an event handler a chance to supply that value for you. Use the C method for a case such as this: sub _find_file { my ($self, $file) = @_; # Send a status message. $self->info("Searching for '$file' file"); # Look for the file. See App::Info:Utility for its interface. my @paths = qw(/usr/conf /etc/conf /foo/conf); my $found = $util->first_cat_path($file, @paths); # If we didn't find it, trigger an unknown event to # give a handler a chance to get the value. $found ||= $self->unknown( key => "file_$file", prompt => "Location of '$file' file?", callback => sub { -f }, error => "Not a file"); # Now return the file name, regardless of whether we found it or not. return $found; } Note how in this method, we've tried to locate the file ourselves, but if we can't find it, we trigger an unknown event. This allows clients of our App::Info subclass to try to establish the value themselves by having an App::Info::Handler subclass handle the event. If a value is found by an App::Info::Handler subclass, it will be returned by C and we can continue. But we can't assume that the unknown event will even be handled, and thus must expect that an unknown value may remain unknown. This is why the C<_find_version()> method above simply returns if C<_find_file()> doesn't return a file name; there's no point in searching through a file that doesn't exist. Attentive readers may be left to wonder how to decide when to use C and when to use C. To a large extent, this decision must be based on one's own understanding of what's most appropriate. Nevertheless, I offer the following simple guidelines: Use C when you expect something to work and then it just doesn't (as when a file exists and should contain the information you seek, but then doesn't). Use C when you're less sure of your processes for finding the value, and also for any of the values that should be returned by any of the L. And of course, C would be more appropriate when you encounter an unexpected condition and don't think that it could be handled in any other way. Now, more than likely, a method such C<_find_version()> would be called by the C method, which is a metadata method mandated by the App::Info abstract base class. This is an appropriate place to handle an unknown version value. Indeed, every one of your metadata methods should make use of the C method. The C method then should look something like this: sub version { my $self = shift; unless (exists $self->{version}) { # Try to find the version number. $self->{version} = $self->_find_version || $self->unknown( key => 'version', prompt => "Enter the version number"); } # Now return the version number. return $self->{version}; } Note how this method only tries to find the version number once. Any subsequent calls to C will return the same value that was returned the first time it was called. Of course, thanks to the C parameter in the call to C, we could have have tried to enumerate the version number every time, as C will return the same value every time it is called (as, indeed, should C<_find_version()>. But by checking for the C key in C<$self> ourselves, we save some of the overhead. But as I said before, every metadata method should make use of the C method. Thus, the C method might looks something like this: sub major { my $self = shift; unless (exists $self->{major}) { # Try to get the major version from the full version number. ($self->{major}) = $self->version =~ /^(\d+)\./; # Handle an unknown value. $self->{major} = $self->unknown( key => 'major', prompt => "Enter major version", callback => sub { /^\d+$/ }, error => "Not a number") unless defined $self->{major}; } return $self->{version}; } Finally, the C method should be used to verify core pieces of data that significant numbers of other methods rely on. Typically such data are executables or configuration files from which will be drawn other metadata. Most often, such major data points will be sought in the object constructor. Here's an example: sub new { # Construct the object so that handlers will work properly. my $self = shift->SUPER::new(@_); # Try to find the executable. $self->info("Searching for executable"); if (my $exe = $util->first_exe('/bin/myapp', '/usr/bin/myapp')) { # Confirm it. $self->{exe} = $self->confirm( key => 'binary', prompt => 'Path to your executable?', value => $exe, callback => sub { -x }, error => 'Not an executable'); } else { # Handle an unknown value. $self->{exe} = $self->unknown( key => 'binary', prompt => 'Path to your executable?', callback => sub { -x }, error => 'Not an executable'); } # We're done. return $self; } By now, most of what's going on here should be quite familiar. The use of the C method is quite similar to that of C. Really the only difference is that the value is known, but we need verification or a new value supplied if the value we found isn't correct. Such may be the case when multiple copies of the executable have been installed on the system, we found F, but the user may really be interested in F. Thus the C event gives the user the chance to change the value if the confirm event is handled. The final thing to note about this constructor is the first line: my $self = shift->SUPER::new(@_); The first thing an App::Info subclass should do is execute this line to allow the super class to construct the object first. Doing so allows any event handling arguments to set up the event handlers, so that when we call C or C the event will be handled as the client expects. If we needed our subclass constructor to take its own parameter argumente, the approach is to specify the same C<< key => $arg >> syntax as is used by App::Info's C method. Say we wanted to allow clients of our App::Info subclass to pass in a list of alternate executable locations for us to search. Such an argument would most make sense as an array reference. So we specify that the key be C and allow the user to construct an object like this: my $app = App::Info::Category::FooApp->new( alt_paths => \@paths ); This approach allows the super class constructor arguments to pass unmolested (as long as we use unique keys!): my $app = App::Info::Category::FooApp->new( on_error => \@handlers, alt_paths => \@paths ); Then, to retrieve these paths inside our C constructor, all we need do is access them directly from the object: my $self = shift->SUPER::new(@_); my $alt_paths = $self->{alt_paths}; =head2 Subclassing Guidelines To summarize, here are some guidelines for subclassing App::Info. =over 4 =item * Always subclass an App::Info category subclass. This will help to keep the App::Info namespace well-organized. New categories can be added as needed. =item * When you create the C constructor, always call C. This ensures that the event handling methods methods defined by the App::Info base classes (e.g., C) will work properly. =item * Use a package-scoped lexical App::Info::Util object to carry out common tasks. If you find you're doing something over and over that's not already addressed by an App::Info::Util method, and you think that others might find your solution useful, consider submitting a patch to App::Info::Util to add the functionality you need. See L for complete documentation of its interface. =item * Use the C event triggering method to send messages to users of your subclass. =item * Use the C event triggering method to alert users of unexpected conditions. Fatal errors should still be fatal; use C to throw exceptions for fatal errors. =item * Use the C event triggering method when a metadata or other important value is unknown and you want to give any event handlers the chance to provide the data. =item * Use the C event triggering method when a core piece of data is known (such as the location of an executable in the C constructor) and you need to make sure that you have the I information. =item * Be sure to implement B of the abstract methods defined by App::Info and by your category abstract base class -- even if they don't do anything. Doing so ensures that all App::Info subclasses share a common interface, and can, if necessary, be used without regard to subclass. Any method not implemented but called on an object will generate a fatal exception. =back Otherwise, have fun! There are a lot of software packages for which relevant information might be collected and aggregated into an App::Info concrete subclass (witness all of the Automake macros in the world!), and folks who are knowledgeable about particular software packages or categories of software are warmly invited to contribute. As more subclasses are implemented, it will make sense, I think, to create separate distributions based on category -- or even, when necessary, on a single software package. Broader categories can then be aggregated in Bundle distributions. But I get ahead of myself... =head1 BUGS Please send bug reports to or file them at L. =head1 AUTHOR David Wheeler =head1 SEE ALSO The following classes define a few software package categories in which App::Info subclasses can be placed. Check them out for ideas on how to create new category subclasses. =over 4 =item L =item L =item L =back The following classes implement the App::Info interface for various software packages. Check them out for examples of how to implement new App::Info concrete subclasses. =over =item L =item L =item L =item L =back L provides utility methods for App::Info subclasses. L defines an interface for event handlers to subclass. Consult its documentation for information on creating custom event handlers. The following classes implement the App::Info::Handler interface to offer some simple event handling. Check them out for examples of how to implement new App::Info::Handler subclasses. =over 4 =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2004, David Wheeler. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-2.19.3/t/00_signature.t0000644000076400007640000000137511642756716014162 0ustar greggreg#!perl ## Test that our SIGNATURE file is valid - requires TEST_SIGNATURE env use 5.006; use strict; use warnings; use Test::More; select(($|=1,select(STDERR),$|=1)[1]); if (!$ENV{TEST_SIGNATURE}) { plan skip_all => 'Set the environment variable TEST_SIGNATURE to enable this test'; } plan tests => 1; SKIP: { if (!eval { require Module::Signature; 1 }) { skip ('Must have Module::Signature to test SIGNATURE file', 1); } elsif ( !-e 'SIGNATURE' ) { fail ('SIGNATURE file was not found'); } elsif ( ! -s 'SIGNATURE') { fail ('SIGNATURE file was empty'); } else { my $ret = Module::Signature::verify(); if ($ret eq Module::Signature::SIGNATURE_OK()) { pass ('Valid SIGNATURE file'); } else { fail ('Invalid SIGNATURE file'); } } } DBD-Pg-2.19.3/t/08async.t0000644000076400007640000002265211642756716013150 0ustar greggreg#!perl ## Test asynchronous queries use 5.006; use strict; use warnings; use Test::More; use Time::HiRes qw/sleep/; use DBD::Pg ':async'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } my $pglibversion = $dbh->{pg_lib_version}; if ($pglibversion < 80000) { cleanup_database($dbh,'test'); $dbh->disconnect; plan skip_all => 'Cannot run asynchronous queries with pre-8.0 libraries.'; } plan tests => 67; isnt ($dbh, undef, 'Connect to database for async testing'); my ($t,$sth,$res); my $pgversion = $dbh->{pg_server_version}; my $table = 'dbd_pg_test1'; ## First, test out do() in all its variants $t=q{Method do() works as expected with no args }; eval { $res = $dbh->do('SELECT 123'); }; is ($@, q{}, $t); is ($res, 1, $t); $t=q{Method do() works as expected with an unused attribute }; eval { $res = $dbh->do('SELECT 123', {pg_nosuch => 'arg'}); }; is ($@, q{}, $t); is ($res, 1, $t); $t=q{Method do() works as expected with an unused attribute and a non-prepared param }; eval { $res = $dbh->do('SET random_page_cost TO ?', undef, '2.2'); }; is ($@, q{}, $t); is ($res, '0E0', $t); $t=q{Method do() works as expected with an unused attribute and multiple real bind params }; eval { $res = $dbh->do('SELECT count(*) FROM pg_class WHERE reltuples IN (?,?,?)', undef, 1,2,3); }; is ($@, q{}, $t); is ($res, 1, $t); $t=q{Cancelling a non-async do() query gives an error }; eval { $res = $dbh->pg_cancel(); }; like ($@, qr{No asynchronous query is running}, $t); $t=q{Method do() works as expected with an asychronous flag }; eval { $res = $dbh->do('SELECT 123', {pg_async => PG_ASYNC}); }; is ($@, q{}, $t); is ($res, '0E0', $t); $t=q{Database attribute "async_status" returns 1 after async query}; $res = $dbh->{pg_async_status}; is ($res, +1, $t); sleep 1; $t=q{Cancelling an async do() query works }; eval { $res = $dbh->pg_cancel(); }; is ($@, q{}, $t); $t=q{Database method pg_cancel returns a false value when cancellation works but finished}; is ($res, q{}, $t); $t=q{Database attribute "async_status" returns -1 after pg_cancel}; $res = $dbh->{pg_async_status}; is ($res, -1, $t); $t=q{Running do() after a cancelled query works}; eval { $res = $dbh->do('SELECT 123'); }; is ($@, q{}, $t); $t=q{Database attribute "async_status" returns 0 after normal query run}; $res = $dbh->{pg_async_status}; is ($res, 0, $t); $t=q{Method pg_ready() fails after a non-async query}; eval { $dbh->pg_ready(); }; like ($@, qr{No async}, $t); $res = $dbh->do('SELECT 123', {pg_async => PG_ASYNC}); $t=q{Method pg_ready() works after a non-async query}; ## Sleep a sub-second to make sure the server has caught up sleep 0.2; eval { $res = $dbh->pg_ready(); }; is ($@, q{}, $t); $t=q{Database method pg_ready() returns 1 after a completed async do()}; is ($res, 1, $t); $res = $dbh->pg_ready(); $t=q{Database method pg_ready() returns true when called a second time}; is ($res, 1, $t); $t=q{Database method pg_ready() returns 1 after a completed async do()}; is ($res, 1, $t); $t=q{Cancelling an async do() query works }; eval { $res = $dbh->pg_cancel(); }; is ($@, q{}, $t); $t=q{Database method pg_cancel() returns expected false value for completed value}; is ($res, q{}, $t); $t=q{Method do() runs after pg_cancel has cleared the async query}; eval { $dbh->do('SELECT 456'); }; is ($@, q{}, $t); $dbh->do(q{SELECT 'async2'}, {pg_async => PG_ASYNC}); $t=q{Method do() fails when async query has not been cleared}; eval { $dbh->do(q{SELECT 'async_blocks'}); }; like ($@, qr{previous async}, $t); $t=q{Database method pg_result works as expected}; eval { $res = $dbh->pg_result(); }; is ($@, q{}, $t); $t=q{Database method pg_result() returns correct value}; is ($res, 1, $t); $t=q{Database method pg_result() fails when called twice}; eval { $dbh->pg_result(); }; like ($@, qr{No async}, $t); $t=q{Database method pg_cancel() fails when called after pg_result()}; eval { $dbh->pg_cancel(); }; like ($@, qr{No async}, $t); $t=q{Database method pg_ready() fails when called after pg_result()}; eval { $dbh->pg_ready(); }; like ($@, qr{No async}, $t); $t=q{Database method do() works after pg_result()}; eval { $dbh->do('SELECT 123'); }; is ($@, q{}, $t); SKIP: { if ($pgversion < 80200) { skip ('Need pg_sleep() to perform rest of async tests: your Postgres is too old', 14); } eval { $dbh->do('SELECT pg_sleep(0)'); }; is ($@, q{}, 'Calling pg_sleep works as expected'); my $time = time(); eval { $res = $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); }; $time = time()-$time; $t = q{Database method do() returns right away when in async mode}; cmp_ok ($time, '<=', 1, $t); $t=q{Method pg_ready() returns false when query is still running}; $res = $dbh->pg_ready(); is ($res, 0, $t); pass ('Sleeping to allow query to finish'); sleep(3); $t=q{Method pg_ready() returns true when query is finished}; $res = $dbh->pg_ready(); ok ($res, $t); $t=q{Method do() will not work if async query not yet cleared}; eval { $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); }; like ($@, qr{previous async}, $t); $t=q{Database method pg_cancel() works while async query is running}; eval { $res = $dbh->pg_cancel(); }; is ($@, q{}, $t); $t=q{Database method pg_cancel returns false when query has already finished}; ok (!$res, $t); $t=q{Database method pg_result() fails after async query has been cancelled}; eval { $res = $dbh->pg_result(); }; like ($@, qr{No async}, $t); $t=q{Database method do() cancels the previous async when requested}; eval { $res = $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC + PG_OLDQUERY_CANCEL}); }; is ($@, q{}, $t); $t=q{Database method pg_result works when async query is still running}; eval { $res = $dbh->pg_result(); }; is ($@, q{}, $t); ## Now throw in some execute after the do() $sth = $dbh->prepare('SELECT 567'); $t = q{Running execute after async do() gives an error}; $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); eval { $res = $sth->execute(); }; like ($@, qr{previous async}, $t); $t = q{Running execute after async do() works when told to cancel}; $sth = $dbh->prepare('SELECT 678', {pg_async => PG_OLDQUERY_CANCEL}); eval { $sth->execute(); }; is ($@, q{}, $t); $t = q{Running execute after async do() works when told to wait}; $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); $sth = $dbh->prepare('SELECT 678', {pg_async => PG_OLDQUERY_WAIT}); eval { $sth->execute(); }; is ($@, q{}, $t); $sth->finish(); } ## end of pg_sleep skip $t=q{Method execute() works when prepare has PG_ASYNC flag}; $sth = $dbh->prepare('SELECT 123', {pg_async => PG_ASYNC}); eval { $sth->execute(); }; is ($@, q{}, $t); $t=q{Database attribute "async_status" returns 1 after prepare async}; $res = $dbh->{pg_async_status}; is ($res, 1, $t); $t=q{Method do() fails when previous async prepare has been executed}; eval { $dbh->do('SELECT 123'); }; like ($@, qr{previous async}, $t); $t=q{Method execute() fails when previous async prepare has been executed}; eval { $sth->execute(); }; like ($@, qr{previous async}, $t); $t=q{Database method pg_cancel works if async query has already finished}; sleep 0.5; eval { $res = $sth->pg_cancel(); }; is ($@, q{}, $t); $t=q{Statement method pg_cancel() returns a false value when cancellation works but finished}; is ($res, q{}, $t); $t=q{Method do() fails when previous execute async has not been cleared}; $sth->execute(); $sth->finish(); ## Ideally, this would clear out the async, but it cannot at the moment eval { $dbh->do('SELECT 345'); }; like ($@, qr{previous async}, $t); $dbh->pg_cancel; $t=q{Directly after pg_cancel(), pg_async_status is -1}; is ($dbh->{pg_async_status}, -1, $t); $t=q{Method execute() works when prepare has PG_ASYNC flag}; $sth->execute(); $t=q{After async execute, pg_async_status is 1}; is ($dbh->{pg_async_status}, 1, $t); $t=q{Method pg_result works after a prepare/execute call}; eval { $res = $dbh->pg_result; }; is ($@, q{}, $t); $t=q{Method pg_result() returns expected result after prepare/execute select}; is ($res, 1, $t); $t=q{Method fetchall_arrayref works after pg_result}; eval { $res = $sth->fetchall_arrayref(); }; is ($@, q{}, $t); $t=q{Method fetchall_arrayref returns correct result after pg_result}; is_deeply ($res, [[123]], $t); $dbh->do('CREATE TABLE dbd_pg_test5(id INT, t TEXT)'); $dbh->commit(); $sth->execute(); $t=q{Method prepare() works when passed in PG_OLDQUERY_CANCEL}; my $sth2; my $SQL = 'INSERT INTO dbd_pg_test5(id) SELECT 123 UNION SELECT 456'; eval { $sth2 = $dbh->prepare($SQL, {pg_async => PG_ASYNC + PG_OLDQUERY_CANCEL}); }; is ($@, q{}, $t); $t=q{Fetch on cancelled statement handle fails}; eval { $sth->fetch(); }; like ($@, qr{no statement executing}, $t); $t=q{Method execute works after async + cancel prepare}; eval { $sth2->execute(); }; is ($@, q{}, $t); $t=q{Statement method pg_result works on async statement handle}; eval { $res = $sth2->pg_result(); }; is ($@, q{}, $t); $t=q{Statement method pg_result returns correct result after execute}; is ($res, 2, $t); $sth2->execute(); $t=q{Database method pg_result works on async statement handle}; eval { $res = $sth2->pg_result(); }; is ($@, q{}, $t); $t=q{Database method pg_result returns correct result after execute}; is ($res, 2, $t); $dbh->do('DROP TABLE dbd_pg_test5'); ## TODO: More pg_sleep tests with execute cleanup_database($dbh,'test'); $dbh->disconnect; DBD-Pg-2.19.3/t/dbdpg_test_setup.pl0000644000076400007640000005124412014735701015352 0ustar greggreg ## Helper file for the DBD::Pg tests use strict; use warnings; use Data::Dumper; use DBI; use Cwd; use 5.006; select(($|=1,select(STDERR),$|=1)[1]); my $testfh; if (exists $ENV{TEST_OUTPUT}) { my $file = $ENV{TEST_OUTPUT}; open $testfh, '>>', $file or die qq{Could not append file "$file": $!\n}; Test::More->builder->failure_output($testfh); Test::More->builder->todo_output($testfh); } my @schemas = ( 'dbd_pg_testschema', 'dbd_pg_testschema2', ); my @tables = ( 'dbd_pg_test5', 'dbd_pg_test4', 'dbd_pg_test3', 'dbd_pg_testschema2.dbd_pg_test3', 'dbd_pg_testschema2.dbd_pg_test2', 'dbd_pg_test2', 'dbd_pg_test1', 'dbd_pg_test', 'dbd_pg_test_geom', ); my @sequences = ( 'dbd_pg_testsequence', 'dbd_pg_testschema2.dbd_pg_testsequence2', 'dbd_pg_testschema2.dbd_pg_testsequence3', ); ## Schema used for testing: my $S = 'dbd_pg_testschema'; ## File written so we don't have to retry connections: my $helpfile = 'README.testdatabase'; use vars qw/$fh/; sub connect_database { ## Connect to the database (unless 'dbh' is passed in) ## Setup all the tables (unless 'nocreate' is passed in) ## Returns three values: ## 1. helpconnect for use by 01connect.t ## 2. Any error generated ## 3. The database handle, or undef my $arg = shift || {}; ref $arg and ref $arg eq 'HASH' or die qq{Need a hashref!\n}; my $dbh = $arg->{dbh} || ''; my $alias = qr{(database|db|dbname)}; my $info; my $olddir = getcwd; my $debug = $ENV{DBDPG_DEBUG} || 0; ## We'll try various ways to get to a database to test with ## First, check to see if we've been here before and left directions my ($testdsn,$testuser,$helpconnect,$su,$uid,$testdir,$pg_ctl,$initdb,$error,$version) = get_test_settings(); if ($debug) { diag "Test settings: dsn: $testdsn user: $testuser helpconnect: $helpconnect su: $su uid: $uid testdir: $testdir pg_ctl: $pg_ctl initdb: $initdb error: $error version: $version "; } ## Did we fail last time? Fail this time too, but quicker! if ($testdsn =~ /FAIL!/) { return $helpconnect, "Previous failure ($error)", undef; } ## We may want to force an initdb call if (!$helpconnect and $ENV{DBDPG_TESTINITDB}) { goto INITDB; } ## Got a working DSN? Give it an attempt if ($testdsn and $testuser) { ## Used by t/01connect.t if ($arg->{dbreplace}) { $testdsn =~ s/$alias\s*=/$arg->{dbreplace}=/; } if ($arg->{dbquotes}) { $testdsn =~ s/$alias\s*=([\-\w]+)/'db="'.lc $2.'"'/e; } goto GOTDBH if eval { $dbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 1}); 1; }; if ($@ =~ /invalid connection option/ or $@ =~ /failed:.*"dbbarf"/) { return $helpconnect, $@, undef; } if ($arg->{nocreate}) { return $helpconnect, '', undef; } ## If this was created by us, try and restart it if (16 == $helpconnect) { ## Bypass if the testdir has been removed if (! -e $testdir) { $arg->{nocreate} and return $helpconnect, '', undef; warn "Test directory $testdir has been removed, will create a new one\n"; } else { if (-e "$testdir/data/postmaster.pid") { ## Assume it's up, and move on } else { if ($arg->{norestart}) { return $helpconnect, '', undef; } warn "Restarting test database $testdsn at $testdir\n"; my $option = ''; if ($^O !~ /Win32/) { my $sockdir = "$testdir/data/socket"; if (! -e $sockdir) { mkdir $sockdir; if ($uid) { if (! chown $uid, -1, $sockdir) { warn "chown of $sockdir failed!\n"; } } } $option = q{-o '-k socket'}; if ($version <= 8.0) { $option = q{-o '-k dbdpg_test_database/data/socket'}; } } my $COM = qq{$pg_ctl $option -l $testdir/dbdpg_test.logfile -D $testdir/data start}; if ($su) { $COM = qq{su -m $su -c "$COM"}; chdir $testdir; } $info = ''; eval { $info = qx{$COM}; }; my $err = $@; $su and chdir $olddir; if ($err or $info !~ /\w/) { $err = "Could not startup new database ($err) ($info)"; return $helpconnect, $err, undef; } ## Wait for it to startup and verify the connection sleep 1; } my $loop = 1; STARTUP: { eval { $dbh = DBI->connect($testdsn, $testuser, '', {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; if ($@ =~ /starting up/ or $@ =~ /PGSQL\.\d+/) { if ($loop++ < 20) { sleep 1; redo STARTUP; } } } if ($@) { return $helpconnect, $@, $dbh; } ## We've got a good connection, so do final tweaks and return goto GOTDBH; } ## end testdir exists } ## end error and we created this database } ## end got testdsn and testuser ## No previous info (or failed attempt), so try to connect and possible create our own cluster $testdsn ||= $ENV{DBI_DSN}; $testuser ||= $ENV{DBI_USER}; if (! $testdsn) { $helpconnect = 1; $testdsn = $^O =~ /Win32/ ? 'dbi:Pg:host=localhost' : 'dbi:Pg:'; } if (! $testuser) { $testuser = 'postgres'; } ## From here on out, we don't return directly, but save it first GETHANDLE: { eval { $dbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; last GETHANDLE if ! $@; ## Made it! ## If the error was because of the user, try a few others if ($@ =~ /postgres/) { if ($helpconnect) { $testdsn .= 'dbname=postgres'; $helpconnect += 2; } $helpconnect += 4; $testuser = $^O =~ /openbsd/ ? '_postgresql' : $^O =~ /bsd/i ? 'pgsql' : 'postgres'; eval { $dbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; last GETHANDLE if ! $@; ## Made it! ## Final user tweak: set to postgres for Beastie if ($testuser ne 'postgres') { $helpconnect += 8; $testuser = 'postgres'; eval { $dbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; last GETHANDLE if ! $@; ## Made it! } } ## Cannot connect to an existing database, so we'll create our own if ($arg->{nocreate}) { return $helpconnect, '', undef; } INITDB: my $testport; $helpconnect = 16; ## Use the initdb found by App::Info $initdb = $ENV{PGINITDB} || ''; if (!$initdb or ! -e $initdb) { $initdb = 'initdb'; } ## Make sure initdb exists and is working properly $ENV{LANG} = 'C'; $info = ''; eval { $info = qx{$initdb --version 2>&1}; }; last GETHANDLE if $@; ## Fail - initdb bad $version = 0; if (!defined $info or ($info !~ /(Postgres)/i and $info !~ /run as root/)) { if (defined $info) { if ($info !~ /\w/) { $@ = 'initdb not found: cannot run full tests without a Postgres database'; } else { $@ = "Bad initdb output: $info"; } } else { my $msg = 'Failed to run initdb (executable probably not available)'; exists $ENV{PGINITDB} and $msg .= " ENV was: $ENV{PGINITDB}"; $msg .= " Final call was: $initdb"; $@ = $msg; } last GETHANDLE; ## Fail - initdb bad } elsif ($info =~ /(\d+\.\d+)/) { $version = $1; } else { die "No version from initdb?! ($info)\n"; } ## Make sure pg_ctl is available as well before we go further if (! -e $pg_ctl) { $pg_ctl = 'pg_ctl'; } $info = ''; eval { $info = qx{$pg_ctl --help 2>&1}; }; last GETHANDLE if $@; ## Fail - pg_ctl bad if (!defined $info or ($info !~ /\@postgresql\.org/ and $info !~ /run as root/)) { $@ = defined $initdb ? "Bad pg_ctl output: $info" : 'Bad pg_ctl output'; last GETHANDLE; ## Fail - pg_ctl bad } ## initdb and pg_ctl seems to be available, let's use them to fire up a cluster warn "Please wait, creating new database for testing\n"; $info = ''; eval { $info = qx{$initdb --locale=C -E UTF8 -D $testdir/data 2>&1}; }; last GETHANDLE if $@; ## Fail - initdb bad ## initdb and pg_ctl cannot be run as root, so let's handle that if ($info =~ /run as root/ or $info =~ /unprivilegierte/) { my $founduser = 0; $su = $testuser = ''; ## Figure out a valid directory - returns empty if nothing available $testdir = find_tempdir(); if (!$testdir) { return $helpconnect, 'Unable to create a temp directory', undef; } my $readme = "$testdir/README"; if (open $fh, '>', $readme) { print $fh "This is a test directory for DBD::Pg and may be removed\n"; print $fh "You may want to ensure the postmaster has been stopped first.\n"; print $fh "Check the data/postmaster.pid file\n"; close $fh or die qq{Could not close "$readme": $!\n}; } ## Likely candidates for running this my @userlist = (qw/postgres postgresql pgsql _postgres/); ## Start with whoever owns this file, unless it's us my $username = getpwuid ((stat($0))[4]); unshift @userlist, $username if defined $username and $username ne getpwent; my %doneuser; for (@userlist) { $testuser = $_; next if $doneuser{$testuser}++; $uid = (getpwnam $testuser)[2]; next if !defined $uid; next unless chown $uid, -1, $testdir; next unless chown $uid, -1, $readme; $su = $testuser; $founduser++; $info = ''; $olddir = getcwd; eval { chdir $testdir; $info = qx{su -m $testuser -c "$initdb --locale=C -E UTF8 -D $testdir/data 2>&1"}; }; my $err = $@; chdir $olddir; last if !$err; } if (!$founduser) { $@ = 'Unable to find a user to run initdb as'; last GETHANDLE; ## Fail - no user } if (! -e "$testdir/data") { $@ = 'Could not create a test database via initdb'; last GETHANDLE; ## Fail - no datadir created } ## At this point, both $su and $testuser are set } if ($info =~ /FATAL/) { $@ = "initdb gave a FATAL error: $info"; last GETHANDLE; ## Fail - FATAL } if ($info =~ /but is not empty/) { ## Assume this is already good to go } elsif ($info !~ /pg_ctl/) { $@ = "initdb did not give a pg_ctl string: $info"; last GETHANDLE; ## Fail - bad output } ## Which user do we connect as? if (!$su and $info =~ /owned by user "(.+?)"/) { $testuser = $1; } ## Now we need to find an open port to use $testport = 5442; ## If we've got netstat available, we'll trust that $info = ''; eval { $info = qx{netstat -na 2>&1}; }; if ($@) { warn "netstat call failed, trying port $testport\n"; } else { ## Start at 5440 and go up until we are free $testport = 5440; my $maxport = 5470; { last if $info !~ /PGSQL\.$testport$/m and $info !~ /\b127\.0\.0\.1:$testport\b/m; last if ++$testport >= $maxport; redo; } if ($testport >= $maxport) { $@ = "No free ports found for testing: tried 5440 to $maxport\n"; last GETHANDLE; ## Fail - no free ports } } $@ = ''; $debug and diag "Port to use: $testport"; my $conf = "$testdir/data/postgresql.conf"; my $cfh; ## If there is already a pid file, do not modify the config ## We assume a previous run put it there, so we extract the port if (-e "$testdir/data/postmaster.pid") { $debug and diag qq{File "$testdir/data/postmaster.pid" exists}; open my $cfh, '<', $conf or die qq{Could not open "$conf": $!\n}; while (<$cfh>) { if (/^\s*port\s*=\s*(\d+)/) { $testport = $1; $debug and diag qq{Found port $testport inside conf file\n}; } } close $cfh or die qq{Could not close "$conf": $!\n}; ## Assume it's up, and move on } else { ## Change to this new port and fire it up if (! open $cfh, '>>', $conf) { $@ = qq{Could not open "$conf": $!}; $debug and diag qq{Failed to open "$conf"}; last GETHANDLE; ## Fail - no conf file } $debug and diag qq{Writing to "$conf"}; print $cfh "\n\n## DBD::Pg testing parameters\n"; print $cfh "port=$testport\n"; print $cfh "max_connections=4\n"; if ($version >= 8.0) { print $cfh "log_statement = 'all'\n"; print $cfh "log_line_prefix = '%m [%p] '\n"; } else { print $cfh "silent_mode = true\n"; } if ($version == 8.1) { print {$cfh} "redirect_stderr = on\n"; } if ($version >= 8.3) { print {$cfh} "logging_collector = on\n"; } print $cfh "log_min_messages = 'DEBUG1'\n"; print $cfh "listen_addresses='127.0.0.1'\n" if $^O =~ /Win32/; print $cfh "\n"; close $cfh or die qq{Could not close "$conf": $!\n}; ## Attempt to start up the test server $info = ''; my $option = ''; if ($^O !~ /Win32/) { my $sockdir = "$testdir/data/socket"; if (! -e $sockdir) { mkdir $sockdir; if ($su) { if (! chown $uid, -1, $sockdir) { warn "chown of $sockdir failed!\n"; } } } $option = q{-o '-k socket'}; if ($version <= 8.0) { $option = q{-o '-k dbdpg_test_database/data/socket'}; } } my $COM = qq{$pg_ctl $option -l $testdir/dbdpg_test.logfile -D $testdir/data start}; $olddir = getcwd; if ($su) { chdir $testdir; $COM = qq{su -m $su -c "$COM"}; } $debug and diag qq{Running: $COM}; eval { $info = qx{$COM}; }; my $err = $@; $su and chdir $olddir; if ($err or $info !~ /\w/) { $@ = "Could not startup new database ($COM) ($err) ($info)"; last GETHANDLE; ## Fail - startup failed } sleep 1; } ## Attempt to connect to this server $testdsn = "dbi:Pg:dbname=postgres;port=$testport"; if ($^O =~ /Win32/) { $testdsn .= ';host=localhost'; } else { $testdsn .= ";host=$testdir/data/socket"; } $debug and diag qq{Test DSN: $testdsn}; my $loop = 1; STARTUP: { eval { $dbh = DBI->connect($testdsn, $testuser, '', {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; ## Regardless of the error, try again. ## We used to check the message, but LANG problems may complicate that. if ($@) { if ($@ =~ /database "postgres" does not exist/) { ## Old server, so let's create a postgres database manually sleep 2; (my $tempdsn = $testdsn) =~ s/postgres/template1/; eval { $dbh = DBI->connect($tempdsn, $testuser, '', {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; $dbh->do('CREATE DATABASE postgres'); $dbh->disconnect(); if ($@) { die "Could not connect: $@\n"; } } if ($loop++ < 5) { sleep 1; redo STARTUP; } } last GETHANDLE; ## Made it! } } ## end of GETHANDLE ## At this point, we've got a connection, or have failed ## Either way, we record for future runs my $connerror = $@; if (open $fh, '>', $helpfile) { print $fh "## This is a temporary file created for testing DBD::Pg\n"; print $fh '## Created: ' . scalar localtime() . "\n"; print $fh "## Feel free to remove it!\n"; print $fh "## Helpconnect: $helpconnect\n"; print $fh "## pg_ctl: $pg_ctl\n"; print $fh "## initdb: $initdb\n"; print $fh "## Version: $version\n"; if ($connerror) { print $fh "## DSN: FAIL!\n"; print $fh "## ERROR: $connerror\n"; } else { print $fh "## DSN: $testdsn\n"; print $fh "## User: $testuser\n"; print $fh "## Testdir: $testdir\n" if 16 == $helpconnect; print $fh "## Testowner: $su\n" if $su; print $fh "## Testowneruid: $uid\n" if $uid; } close $fh or die qq{Could not close "$helpfile": $!\n}; } $connerror and return $helpconnect, $connerror, undef; GOTDBH: ## This allows things like data_sources() to work if we did an initdb $ENV{DBI_DSN} = $testdsn; $ENV{DBI_USER} = $testuser; if ($arg->{quickreturn}) { return $helpconnect, '', $dbh; } my $SQL = 'SELECT usesuper FROM pg_user WHERE usename = current_user'; my $bga = $dbh->selectall_arrayref($SQL)->[0][0]; if ($bga) { $dbh->do(q{SET LC_MESSAGES = 'C'}); } if ($arg->{nosetup}) { return $helpconnect, '', $dbh unless schema_exists($dbh, $S); $dbh->do("SET search_path TO $S"); } else { cleanup_database($dbh); eval { $dbh->do("CREATE SCHEMA $S"); }; if ($@ =~ /Permission denied/ and $helpconnect != 16) { ## Okay, this ain't gonna work, let's try initdb goto INITDB; } $@ and return $helpconnect, $@, undef; $dbh->do("SET search_path TO $S"); $dbh->do('CREATE SEQUENCE dbd_pg_testsequence'); # If you add columns to this, please do not use reserved words! $SQL = q{ CREATE TABLE dbd_pg_test ( id integer not null primary key, lii integer unique not null default nextval('dbd_pg_testsequence'), pname varchar(20) default 'Testing Default' , val text, score float CHECK(score IN ('1','2','3')), Fixed character(5), pdate timestamp default now(), testarray text[][], testarray2 int[], testarray3 bool[], "CaseTest" boolean, expo numeric(6,2), bytetest bytea ) }; $dbh->{Warn} = 0; $dbh->do($SQL); $dbh->{Warn} = 1; $dbh->do(q{COMMENT ON COLUMN dbd_pg_test.id IS 'Bob is your uncle'}); } ## end setup $dbh->commit() unless $dbh->{AutoCommit}; if ($arg->{disconnect}) { $dbh->disconnect(); return $helpconnect, '', undef; } $dbh->{AutoCommit} = 0 unless $arg->{AutoCommit}; return $helpconnect, '', $dbh; } ## end of connect_database sub find_tempdir { if (eval { require File::Temp; 1; }) { return File::Temp::tempdir('dbdpg_testdatabase_XXXXXX', TMPDIR => 1, CLEANUP => 0); } ## Who doesn't have File::Temp?! :) my $found = 0; for my $num (1..100) { my $tempdir = "/tmp/dbdpg_testdatabase_ABCDEF$num"; next if -e $tempdir; mkdir $tempdir or return ''; return $tempdir; } return ''; } ## end of find_tempdir sub get_test_settings { ## Returns test database information from the testfile if it exists ## Defaults to ENV variables or blank ## Find the best candidate for the pg_ctl program my $pg_ctl = 'pg_ctl'; if (exists $ENV{PGINITDB} and -e $ENV{PGINITDB}) { ($pg_ctl = $ENV{PGINITDB}) =~ s/initdb/pg_ctl/; } my ($testdsn, $testuser, $testdir, $error) = ('','','','?'); my ($helpconnect, $su, $uid, $initdb, $version) = (0,'','','default',0); my $inerror = 0; if (-e $helpfile) { open $fh, '<', $helpfile or die qq{Could not open "$helpfile": $!\n}; while (<$fh>) { if ($inerror) { $error .= "\n$_"; } /DSN: (.+)/ and $testdsn = $1; /User: (\S+)/ and $testuser = $1; /Helpconnect: (\d+)/ and $helpconnect = $1; /Testowner: (\w+)/ and $su = $1; /Testowneruid: (\d+)/ and $uid = $1; /Testdir: (.+)/ and $testdir = $1; /pg_ctl: (.+)/ and $pg_ctl = $1; /initdb: (.+)/ and $initdb = $1; /ERROR: (.+)/ and $error = $1 and $inerror = 1; /Version: (.+)/ and $version = $1; } close $fh or die qq{Could not close "$helpfile": $!\n}; } if (!$testdir) { my $dir = getcwd(); $testdir = "$dir/dbdpg_test_database"; } return $testdsn, $testuser, $helpconnect, $su, $uid, $testdir, $pg_ctl, $initdb, $error, $version; } ## end of get_test_settings sub schema_exists { my ($dbh,$schema) = @_; my $SQL = 'SELECT 1 FROM pg_catalog.pg_namespace WHERE nspname = ?'; my $sth = $dbh->prepare_cached($SQL); my $count = $sth->execute($schema); $sth->finish(); return $count < 1 ? 0 : 1; } ## end of schema_exists sub relation_exists { my ($dbh,$schema,$name) = @_; my $SQL = 'SELECT 1 FROM pg_catalog.pg_class c, pg_catalog.pg_namespace n '. 'WHERE n.oid=c.relnamespace AND n.nspname = ? AND c.relname = ?'; my $sth = $dbh->prepare_cached($SQL); my $count = $sth->execute($schema,$name); $sth->finish(); return $count < 1 ? 0 : 1; } ## end of relation_exists sub cleanup_database { ## Clear out any testing objects in the current database my $dbh = shift; my $type = shift || 0; return unless defined $dbh and ref $dbh and $dbh->ping(); ## For now, we always run and disregard the type $dbh->rollback() if ! $dbh->{AutoCommit}; for my $name (@tables) { my $schema = ($name =~ s/(.+)\.(.+)/$2/) ? $1 : $S; next if ! relation_exists($dbh,$schema,$name); $dbh->do("DROP TABLE $schema.$name"); } for my $name (@sequences) { my $schema = ($name =~ s/(.+)\.(.+)/$2/) ? $1 : $S; next if ! relation_exists($dbh,$schema,$name); $dbh->do("DROP SEQUENCE $schema.$name"); } for my $schema (@schemas) { next if ! schema_exists($dbh,$schema); $dbh->do("DROP SCHEMA $schema CASCADE"); } $dbh->commit() if ! $dbh->{AutoCommit}; return; } ## end of cleanup_database sub shutdown_test_database { my ($testdsn,$testuser,$helpconnect,$su,$uid,$testdir,$pg_ctl,$initdb) = get_test_settings(); if (-e $testdir and -e "$testdir/data/postmaster.pid") { my $COM = qq{$pg_ctl -D $testdir/data -m fast stop}; my $olddir = getcwd; if ($su) { $COM = qq{su $su -m -c "$COM"}; chdir $testdir; } eval { qx{$COM}; }; $su and chdir $olddir; } ## Remove the test directory entirely return if $ENV{DBDPG_TESTINITDB}; return if ! eval { require File::Path; 1; }; warn "Removing test database directory\n"; File::Path::rmtree($testdir); return; } ## end of shutdown_test_database 1; DBD-Pg-2.19.3/t/04misc.t0000644000076400007640000002513112014740370012734 0ustar greggreg#!perl ## Various stuff that does not go elsewhere use 5.006; use strict; use warnings; use Test::More; use Data::Dumper; use DBI; use DBD::Pg; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 70; isnt ($dbh, undef, 'Connect to database for miscellaneous tests'); my $t = q{Method 'server_trace_flag' is available without a database handle}; my $num; eval { $num = DBD::Pg->parse_trace_flag('NONE'); }; is ($@, q{}, $t); $t='Method "server_trace_flag" returns undef on bogus argument'; is ($num, undef, $t); $t=q{Method "server_trace_flag" returns 0x00000100 for DBI value 'SQL'}; $num = DBD::Pg->parse_trace_flag('SQL'); is ($num, 0x00000100, $t); $t=q{Method "server_trace_flag" returns 0x01000000 for DBD::Pg flag 'pglibpq'}; $num = DBD::Pg->parse_trace_flag('pglibpq'); is ($num, 0x01000000, $t); $t=q{Database handle method "server_trace_flag" returns undef on bogus argument}; $num = $dbh->parse_trace_flag('NONE'); is ($num, undef, $t); $t=q{Database handle method "server_trace_flag" returns 0x00000100 for DBI value 'SQL'}; $num = $dbh->parse_trace_flag('SQL'); is ($num, 0x00000100, $t); $t=q{Database handle method 'server_trace_flags' returns 0x01000100 for 'SQL|pglibpq'}; $num = $dbh->parse_trace_flags('SQL|pglibpq'); is ($num, 0x01000100, $t); $t=q{Database handle method 'server_trace_flags' returns 0x03000100 for 'SQL|pglibpq|pgstart'}; $num = $dbh->parse_trace_flags('SQL|pglibpq|pgstart'); is ($num, 0x03000100, $t); my $flagexp = 24; my $sth = $dbh->prepare('SELECT 1'); for my $flag (qw/pglibpq pgstart pgend pgprefix pglogin pgquote/) { my $hex = 2**$flagexp++; $t = qq{Database handle method "server_trace_flag" returns $hex for flag $flag}; $num = $dbh->parse_trace_flag($flag); is ($num, $hex, $t); $t = qq{Database handle method 'server_trace_flags' returns $hex for flag $flag}; $num = $dbh->parse_trace_flags($flag); is ($num, $hex, $t); $t = qq{Statement handle method "server_trace_flag" returns $hex for flag $flag}; $num = $sth->parse_trace_flag($flag); is ($num, $hex, $t); $t = qq{Statement handle method 'server_trace_flags' returns $hex for flag $flag}; $num = $sth->parse_trace_flag($flag); is ($num, $hex, $t); } SKIP: { eval { require File::Temp; }; $@ and skip ('Must have File::Temp to complete trace flag testing', 9); my ($fh,$filename) = File::Temp::tempfile('dbdpg_test_XXXXXX', SUFFIX => 'tst', UNLINK => 1); my ($flag, $info, $expected, $SQL); $t=q{Trace flag 'SQL' works as expected}; $flag = $dbh->parse_trace_flags('SQL'); $dbh->trace($flag, $filename); $SQL = q{SELECT 'dbdpg_flag_testing'}; $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = qq{begin;\n\n$SQL;\n\ncommit;\n\n}; is ($info, $expected, $t); $t=q{Trace flag 'pglibpq' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flag('pglibpq'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{PQexec PQresultStatus PQresultErrorField PQclear PQexec PQresultStatus PQresultErrorField PQntuples PQclear PQtransactionStatus PQtransactionStatus PQexec PQresultStatus PQresultErrorField PQclear }; is ($info, $expected, $t); $t=q{Trace flag 'pgstart' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pgstart'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Begin pg_quickexec (query: SELECT 'dbdpg_flag_testing' async: 0 async_status: 0) Begin _result (sql: begin) Begin _sqlstate Begin _sqlstate Begin dbd_db_commit Begin pg_db_rollback_commit (action: commit AutoCommit: 0 BegunWork: 0) Begin PGTransactionStatusType Begin _result (sql: commit) Begin _sqlstate }; is ($info, $expected, $t); $t=q{Trace flag 'pgprefix' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pgstart|pgprefix'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{dbdpg: Begin pg_quickexec (query: SELECT 'dbdpg_flag_testing' async: 0 async_status: 0) dbdpg: Begin _result (sql: begin) dbdpg: Begin _sqlstate dbdpg: Begin _sqlstate dbdpg: Begin dbd_db_commit dbdpg: Begin pg_db_rollback_commit (action: commit AutoCommit: 0 BegunWork: 0) dbdpg: Begin PGTransactionStatusType dbdpg: Begin _result (sql: commit) dbdpg: Begin _sqlstate }; is ($info, $expected, $t); $t=q{Trace flag 'pgend' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pgend'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{End _sqlstate (imp_dbh->sqlstate: 00000) End _sqlstate (status: 1) End _result End _sqlstate (imp_dbh->sqlstate: 00000) End _sqlstate (status: 2) End pg_quickexec (rows: 1, txn_status: 2) End _sqlstate (imp_dbh->sqlstate: 00000) End _sqlstate (status: 1) End _result End pg_db_rollback_commit (result: 1) }; is ($info, $expected, $t); $t=q{Trace flag 'pglogin' returns undef if no activity}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pglogin'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; $info = <$fh>; } $expected = undef; is ($info, $expected, $t); $t=q{Trace flag 'pglogin' works as expected with DBD::Pg->parse_trace_flag()}; $dbh->disconnect(); my $flagval = DBD::Pg->parse_trace_flag('pglogin'); seek $fh, 0, 0; truncate $fh, tell($fh); DBI->trace($flagval, $filename); $dbh = connect_database({nosetup => 1}); $dbh->do($SQL); $dbh->disconnect(); $dbh = connect_database({nosetup => 1}); $dbh->disconnect(); DBI->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Login connection string: Connection complete Disconnection complete }; $info =~ s/(Login connection string: ).+/$1/g; is ($info, "$expected$expected", $t); $t=q{Trace flag 'pglogin' works as expected with DBD::Pg->parse_trace_flag()}; seek $fh, 0, 0; truncate $fh, tell($fh); DBI->trace($flagval, $filename); $dbh = connect_database({nosetup => 1}); $dbh->disconnect(); DBI->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Login connection string: Connection complete Disconnection complete }; $info =~ s/(Login connection string: ).+/$1/g; is ($info, "$expected", $t); $t=q{Trace flag 'pgprefix' and 'pgstart' appended to 'pglogin' work as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); DBI->trace($flagval, $filename); $dbh = connect_database({nosetup => 1}); $dbh->do($SQL); $flagval += $dbh->parse_trace_flags('pgprefix|pgstart'); $dbh->trace($flagval); $dbh->do($SQL); $dbh->trace(0); $dbh->rollback(); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Login connection string: Connection complete dbdpg: Begin pg_quickexec (query: SELECT 'dbdpg_flag_testing' async: 0 async_status: 0) dbdpg: Begin _sqlstate }; $info =~ s/(Login connection string: ).+/$1/g; is ($info, "$expected", $t); } ## end trace flag testing using File::Temp # # Test of the "data_sources" method # $t='The "data_sources" method did not throw an exception'; my @result; eval { @result = DBI->data_sources('Pg'); }; is ($@, q{}, $t); $t='The "data_sources" method returns a template1 listing'; if (! defined $result[0]) { fail ('The data_sources() method returned an empty list'); } else { is (grep (/^dbi:Pg:dbname=template1$/, @result), '1', $t); } $t='The "data_sources" method returns undef when fed a bogus second argument'; @result = DBI->data_sources('Pg','foobar'); is (scalar @result, 0, $t); $t='The "data_sources" method returns information when fed a valid port as the second arg'; my $port = $dbh->{pg_port}; @result = DBI->data_sources('Pg',"port=$port"); isnt ($result[0], undef, $t); SKIP: { $t=q{The "data_sources" method returns information when 'dbi:Pg' is uppercased}; if (! exists $ENV{DBI_DSN} or $ENV{DBI_DSN} !~ /pg/i) { skip 'Cannot test data_sources() DBI_DSN munging unless DBI_DSN is set', 2; } my $orig = $ENV{DBI_DSN}; $ENV{DBI_DSN} =~ s/DBI:PG/DBI:PG/i; @result = DBI->data_sources('Pg'); like ((join '' => @result), qr{template0}, $t); $t=q{The "data_sources" method returns information when 'DBI:' is mixed case}; $ENV{DBI_DSN} =~ s/DBI:PG/dBi:pg/i; @result = DBI->data_sources('Pg'); like ((join '' => @result), qr{template0}, $t); $ENV{DBI_DSN} = $orig; } # # Test the use of $DBDPG_DEFAULT # $t=qq{Using \$DBDPG_DEFAULT ($DBDPG_DEFAULT) works}; $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id, pname) VALUES (?,?)}); eval { $sth->execute(600,$DBDPG_DEFAULT); }; $sth->execute(602,123); is ($@, q{}, $t); # # Test transaction status changes # $t='Raw ROLLBACK via do() resets the transaction status correctly'; $dbh->{AutoCommit} = 1; $dbh->begin_work(); $dbh->do('SELECT 123'); eval { $dbh->do('ROLLBACK'); }; is ($@, q{}, $t); eval { $dbh->begin_work(); }; is ($@, q{}, $t); $t='Using dbh->commit() resets the transaction status correctly'; eval { $dbh->commit(); }; is ($@, q{}, $t); eval { $dbh->begin_work(); }; is ($@, q{}, $t); $t='Raw COMMIT via do() resets the transaction status correctly'; eval { $dbh->do('COMMIT'); }; is ($@, q{}, $t); eval { $dbh->begin_work(); }; is ($@, q{}, $t); $t='Calling COMMIT via prepare/execute resets the transaction status correctly'; $sth = $dbh->prepare('COMMIT'); $sth->execute(); eval { $dbh->begin_work(); }; is ($@, q{}, $t); ## Check for problems in pg_st_split_statement by having it parse long strings my $problem; diag 'Checking pg_st_split_statement. This may take a while...'; for my $length (0..16384) { my $sql = sprintf 'SELECT %*d', $length + 3, $length; my $cur_len = $dbh->selectrow_array($sql); next if $cur_len == $length; $problem = "length $length gave us a select of $cur_len"; last; } if (defined $problem) { fail ("pg_st_split_statment failed: $problem"); } else { pass ('pg_st_split_statement gave no problems with various lengths'); } ## Check for problems with insane number of placeholders for my $ph (1..13) { my $total = 2**$ph; $t = "prepare/execute works with $total placeholders"; my $sql = 'SELECT count(*) FROM pg_class WHERE relpages IN (' . ('?,' x $total); $sql =~ s/.$/\)/; $sth = $dbh->prepare($sql); my @arr = (1..$total); my $count = $sth->execute(@arr); is $count, 1, $t; $sth->finish(); } cleanup_database($dbh,'test'); $dbh->disconnect(); DBD-Pg-2.19.3/t/20savepoints.t0000644000076400007640000000336611642756716014221 0ustar greggreg#!perl ## Test savepoint functionality use 5.006; use strict; use warnings; use Test::More; use DBI ':sql_types'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 3; isnt ($dbh, undef, 'Connect to database for savepoint testing'); my $pgversion = $dbh->{pg_server_version}; my $t; SKIP: { skip ('Cannot test savepoints on pre-8.0 servers', 2) if $pgversion < 80000; my $str = 'Savepoint Test'; my $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id,pname) VALUES (?,?)'); ## Create 500 without a savepoint $sth->execute(500,$str); ## Create 501 inside a savepoint and roll it back $dbh->pg_savepoint('dbd_pg_test_savepoint'); $sth->execute(501,$str); $dbh->pg_rollback_to('dbd_pg_test_savepoint'); $dbh->pg_rollback_to('dbd_pg_test_savepoint'); ## Yes, we call it twice ## Create 502 after the rollback: $sth->execute(502,$str); $dbh->commit; $t='Only row 500 and 502 should be committed'; my $ids = $dbh->selectcol_arrayref('SELECT id FROM dbd_pg_test WHERE pname = ?',undef,$str); ok (eq_set($ids, [500, 502]), $t); ## Create 503, then release the savepoint $dbh->pg_savepoint('dbd_pg_test_savepoint'); $sth->execute(503,$str); $dbh->pg_release('dbd_pg_test_savepoint'); ## Create 504 outside of any savepoint $sth->execute(504,$str); $dbh->commit; $t='Implicit rollback on deallocate should rollback to last savepoint'; $ids = $dbh->selectcol_arrayref('SELECT id FROM dbd_pg_test WHERE pname = ?',undef,$str); ok (eq_set($ids, [500, 502, 503, 504]), $t); } $dbh->do('DELETE FROM dbd_pg_test'); $dbh->commit(); cleanup_database($dbh,'test'); $dbh->disconnect(); DBD-Pg-2.19.3/t/99cleanup.t0000644000076400007640000000124711642756716013471 0ustar greggreg#!perl ## Cleanup all database objects we may have created ## Shutdown the test database if we created one ## Remove the entire directory if it was created as a tempdir use 5.006; use strict; use warnings; use Test::More tests => 1; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database({nosetup => 1, nocreate => 1, norestart => 1}); SKIP: { if (! $dbh) { skip ('Connection to database failed, cannot cleanup', 1); } isnt ($dbh, undef, 'Connect to database for cleanup'); cleanup_database($dbh); } $dbh->disconnect() if defined $dbh and ref $dbh; shutdown_test_database(); unlink 'README.testdatabase'; DBD-Pg-2.19.3/t/02attribs.t0000644000076400007640000013611111726405720013456 0ustar greggreg#!perl ## Test all handle attributes: database, statement, and generic ("any") use 5.006; use strict; use warnings; use Data::Dumper; use Test::More; use DBI ':sql_types'; use DBD::Pg ':pg_types'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my ($helpconnect,$connerror,$dbh) = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 249; isnt ($dbh, undef, 'Connect to database for handle attributes testing'); my ($pglibversion,$pgversion) = ($dbh->{pg_lib_version},$dbh->{pg_server_version}); my $attributes_tested = q{ d = database handle specific s = statement handle specific a = any type of handle (but we usually use database) In order: d Statement (must be the first one tested) d CrazyDiamond (bogus) d private_dbdpg_* d AutoCommit d Driver d Name d RowCacheSize d Username d PrintWarn d pg_INV_READ d pg_INV_WRITE d pg_protocol d pg_errorlevel d pg_bool_tf d pg_db d pg_user d pg_pass d pg_port d pg_default_port d pg_options d pg_socket d pg_pid d pg_standard_conforming strings d pg_enable_utf8 d Warn d pg_prepare_now - tested in 03smethod.t d pg_server_prepare - tested in 03smethod.t d pg_prepare_now - tested in 03smethod.t d pg_placeholder_dollaronly - tested in 12placeholders.t s NUM_OF_FIELDS, NUM_OF_PARAMS s NAME, NAME_lc, NAME_uc, NAME_hash, NAME_lc_hash, NAME_uc_hash s TYPE, PRECISION, SCALE, NULLABLE s CursorName s Database s ParamValues s ParamTypes s RowsInCache s pg_size s pg_type s pg_oid_status s pg_cmd_status a Active a Executed a Kids a ActiveKids a CachedKids a Type a ChildHandles a CompatMode a PrintError a RaiseError a HandleError a HandleSetErr a ErrCount a ShowErrorStatement a TraceLevel a FetchHashKeyName a ChopBlanks a LongReadLen a LongTruncOk a TaintIn a TaintOut a Taint a Profile (not tested) a ReadOnly d InactiveDestroy (must be the last one tested) }; my ($attrib,$SQL,$sth,$warning,$result,$expected,$t); # Get the DSN and user from the test file, if it exists my ($testdsn, $testuser) = get_test_settings(); # # Test of the database handle attribute "Statement" # $SQL = 'SELECT 123'; $sth = $dbh->prepare($SQL); $sth->finish(); $t='DB handle attribute "Statement" returns the last prepared query'; $attrib = $dbh->{Statement}; is ($attrib, $SQL, $t); # # Test of bogus database/statement handle attributes # ## DBI switched from error to warning in 1.43 $t='Error or warning when setting an invalid database handle attribute'; $warning=q{}; eval { local $SIG{__WARN__} = sub { $warning = shift; }; $dbh->{CrazyDiamond}=1; }; isnt ($warning, q{}, $t); $t='Setting a private attribute on a database handle does not throw an error'; eval { $dbh->{private_dbdpg_CrazyDiamond}=1; }; is ($@, q{}, $t); $sth = $dbh->prepare('SELECT 123'); $t='Error or warning when setting an invalid statement handle attribute'; $warning=q{}; eval { local $SIG{__WARN__} = sub { $warning = shift; }; $sth->{CrazyDiamond}=1; }; isnt ($warning, q{}, $t); $t='Setting a private attribute on a statement handle does not throw an error'; eval { $sth->{private_dbdpg_CrazyDiamond}=1; }; is ($@, q{}, $t); # # Test of the database handle attribute "AutoCommit" # $t='Commit after deleting all rows from dbd_pg_test'; $dbh->do('DELETE FROM dbd_pg_test'); ok ($dbh->commit(), $t); $t='Connect to database with second database handle, AutoCommit on'; my $dbh2 = connect_database({AutoCommit => 1}); isnt ($dbh2, undef, $t); $t='Insert a row into the database with first database handle'; ok ($dbh->do(q{INSERT INTO dbd_pg_test (id, pname, val) VALUES (1, 'Coconut', 'Mango')}), $t); $t='Second database handle cannot see insert from first'; my $rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 1}))[0]; is ($rows, 0, $t); $t='Insert a row into the database with second database handle'; ok ($dbh->do(q{INSERT INTO dbd_pg_test (id, pname, val) VALUES (2, 'Grapefruit', 'Pomegranate')}), $t); $t='First database handle can see insert from second'; $rows = ($dbh->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 2}))[0]; cmp_ok ($rows, '==', 1, $t); ok ($dbh->commit, 'Commit transaction with first database handle'); $t='Second database handle can see insert from first'; $rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 1}))[0]; is ($rows, 1, $t); ok ($dbh2->disconnect(), 'Disconnect with second database handle'); # # Test of the database handle attribute "Driver" # $t='$dbh->{Driver}{Name} returns correct value of "Pg"'; $attrib = $dbh->{Driver}->{Name}; is ($attrib, 'Pg', $t); # # Test of the database handle attribute "Name" # SKIP: { $t='DB handle attribute "Name" returns same value as DBI_DSN'; if (! length $testdsn or $testdsn !~ /^dbi:Pg:(.+)/) { skip (q{Cannot test DB handle attribute "Name" invalid DBI_DSN}, 1); } $expected = $1 || $ENV{PGDATABASE}; defined $expected and length $expected or skip ('Cannot test unless database name known', 1); $attrib = $dbh->{Name}; $expected =~ s/(db|database)=/dbname=/; is ($attrib, $expected, $t); } # # Test of the database handle attribute "RowCacheSize" # $t='DB handle attribute "RowCacheSize" returns undef'; $attrib = $dbh->{RowCacheSize}; is ($attrib, undef, $t); $t='Setting DB handle attribute "RowCacheSize" has no effect'; $dbh->{RowCacheSize} = 42; $attrib = $dbh->{RowCacheSize}; is ($attrib, undef, $t); # # Test of the database handle attribute "Username" # $t='DB handle attribute "Username" returns the same value as DBI_USER'; $attrib = $dbh->{Username}; is ($attrib, $testuser, $t); # # Test of the "PrintWarn" database handle attribute # $t='DB handle attribute "PrintWarn" defaults to on'; my $value = $dbh->{PrintWarn}; is ($value, 1, $t); { local $SIG{__WARN__} = sub { $warning = shift; }; $dbh->do(q{SET client_min_messages = 'NOTICE'}); $t='DB handle attribute "PrintWarn" works when on'; $warning = q{}; eval { $dbh->do('CREATE TEMP TABLE dbd_pg_test_temp(id INT PRIMARY KEY)'); }; is ($@, q{}, $t); $t='DB handle attribute "PrintWarn" shows warnings when on'; like ($warning, qr{dbd_pg_test_temp}, $t); $t='DB handle attribute "PrintWarn" works when on'; $dbh->rollback(); $dbh->{PrintWarn}=0; $warning = q{}; eval { $dbh->do('CREATE TEMP TABLE dbd_pg_test_temp(id INT PRIMARY KEY)'); }; is ($@, q{}, $t); $t='DB handle attribute "PrintWarn" shows warnings when on'; is ($warning, q{}, $t); $dbh->{PrintWarn}=1; $dbh->rollback(); } # # Test of the database handle attributes "pg_INV_WRITE" and "pg_INV_READ" # (these are used by the lo_* database handle methods) # $t='Database handle attribute "pg_INV_WRITE" returns a number'; like ($dbh->{pg_INV_WRITE}, qr/^\d+$/, $t); $t='Database handle attribute "pg_INV_READ" returns a number'; like ($dbh->{pg_INV_READ}, qr/^\d+$/, $t); # # Test of the database handle attribute "pg_protocol" # $t='Database handle attribute "pg_protocol" returns a number'; like ($dbh->{pg_protocol}, qr/^\d+$/, $t); # # Test of the database handle attribute "pg_errorlevel" # $t='Database handle attribute "pg_errorlevel" returns the default (1)'; is ($dbh->{pg_errorlevel}, 1, $t); $t='Database handle attribute "pg_errorlevel" defaults to 1 if invalid'; $dbh->{pg_errorlevel} = 3; is ($dbh->{pg_errorlevel}, 1, $t); # # Test of the database handle attribute "pg_bool_tf" # $t='DB handle method "pg_bool_tf" starts as 0'; $result = $dbh->{pg_bool_tf}=0; is ($result, 0, $t); $t=q{DB handle method "pg_bool_tf" returns '1' for true when on}; $sth = $dbh->prepare('SELECT ?::bool'); $sth->bind_param(1,1,SQL_BOOLEAN); $sth->execute(); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, '1', $t); $t=q{DB handle method "pg_bool_tf" returns '0' for false when on}; $sth->execute(0); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, '0', $t); $t=q{DB handle method "pg_bool_tf" returns 't' for true when on}; $dbh->{pg_bool_tf}=1; $sth->execute(1); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, 't', $t); $t=q{DB handle method "pg_bool_tf" returns 'f' for true when on}; $sth->execute(0); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, 'f', $t); ## Test of all the informational pg_* database handle attributes $t='DB handle attribute "pg_db" returns at least one character'; $result = $dbh->{pg_protocol}; like ($result, qr/^\d+$/, $t); $t='DB handle attribute "pg_db" returns at least one character'; $result = $dbh->{pg_db}; ok (length $result, $t); $t='DB handle attribute "pg_user" returns a value'; $result = $dbh->{pg_user}; ok (defined $result, $t); $t='DB handle attribute "pg_pass" returns a value'; $result = $dbh->{pg_pass}; ok (defined $result, $t); $t='DB handle attribute "pg_port" returns a number'; $result = $dbh->{pg_port}; like ($result, qr/^\d+$/, $t); $t='DB handle attribute "pg_default_port" returns a number'; $result = $dbh->{pg_default_port}; like ($result, qr/^\d+$/, $t); $t='DB handle attribute "pg_options" returns a value'; $result = $dbh->{pg_options}; ok (defined $result, $t); $t='DB handle attribute "pg_socket" returns a value'; $result = $dbh->{pg_socket}; like ($result, qr/^\d+$/, $t); $t='DB handle attribute "pg_pid" returns a value'; $result = $dbh->{pg_pid}; like ($result, qr/^\d+$/, $t); SKIP: { if ($pgversion < 80200) { skip ('Cannot test standard_conforming_strings on pre 8.2 servers', 3); } $t='DB handle attribute "pg_standard_conforming_strings" returns a valid value'; my $oldscs = $dbh->{pg_standard_conforming_strings}; like ($oldscs, qr/^on|off$/, $t); $t='DB handle attribute "pg_standard_conforming_strings" returns correct value'; $dbh->do('SET standard_conforming_strings = on'); $result = $dbh->{pg_standard_conforming_strings}; is ($result, 'on', $t); $t='DB handle attribute "pg_standard_conforming_strings" returns correct value'; $dbh->do('SET standard_conforming_strings = off'); $result = $dbh->{pg_standard_conforming_strings}; $dbh->do("SET standard_conforming_strings = $oldscs"); is ($result, 'off', $t); } ## If Encode is available, we will insert some non-ASCII into the test table ## Since this will fail with client encodings such as BIG5, we force UTF8 my $old_encoding = $dbh->selectall_arrayref('SHOW client_encoding')->[0][0]; if ($old_encoding ne 'UTF8') { $dbh->do(q{SET NAMES 'UTF8'}); } # Attempt to test whether or not we can get unicode out of the database SKIP: { eval { require Encode; }; skip ('Encode module is needed for unicode tests', 5) if $@; my $server_encoding = $dbh->selectall_arrayref('SHOW server_encoding')->[0][0]; skip ('Cannot reliably test unicode without a UTF8 database', 5) if $server_encoding ne 'UTF8'; $SQL = 'SELECT id, pname FROM dbd_pg_test WHERE id = ?'; $sth = $dbh->prepare($SQL); $sth->execute(1); local $dbh->{pg_enable_utf8} = 1; $t='Quote method returns correct utf-8 characters'; my $utf8_str = chr(0x100).'dam'; # LATIN CAPITAL LETTER A WITH MACRON is ($dbh->quote( $utf8_str ), "'$utf8_str'", $t); $t='Able to insert unicode character into the database'; $SQL = "INSERT INTO dbd_pg_test (id, pname, val) VALUES (40, '$utf8_str', 'Orange')"; is ($dbh->do($SQL), '1', $t); $t='Able to read unicode (utf8) data from the database'; $sth->execute(40); my ($id, $name) = $sth->fetchrow_array(); ok (Encode::is_utf8($name), $t); $t='Unicode (utf8) data returned from database is not corrupted'; is (length($name), 4, $t); $t='ASCII text returned from database does have utf8 bit set'; $sth->finish(); $sth->execute(1); my ($id2, $name2) = $sth->fetchrow_array(); ok (!Encode::is_utf8($name2), $t); $sth->finish(); } # # Use the handle attribute "Warn" to check inheritance # undef $sth; $t='Attribute "Warn" attribute set on by default'; ok ($dbh->{Warn}, $t); $t='Statement handle inherits the "Warn" attribute'; $SQL = 'SELECT 123'; $sth = $dbh->prepare($SQL); $sth->finish(); ok ($sth->{Warn}, $t); $t='Able to turn off the "Warn" attribute in the database handle'; $dbh->{Warn} = 0; ok (! $dbh->{Warn}, $t); # # Test of the the following statement handle attributes: # NUM_OF_PARAMS, NUM_OF_FIELDS # NAME, NAME_lc, NAME_uc, NAME_hash, NAME_lc_hash, NAME_uc_hash # TYPE, PRECISION, SCALE, NULLABLE # ## First, all pre-execute checks: $t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with no placeholders'; $sth = $dbh->prepare('SELECT 123'); is ($sth->{'NUM_OF_PARAMS'}, 0, $t); $t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with three placeholders'; $sth = $dbh->prepare('SELECT 123 FROM pg_class WHERE relname=? AND reltuples=? and relpages=?'); is ($sth->{'NUM_OF_PARAMS'}, 3, $t); $t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with one placeholder'; $sth = $dbh->prepare('SELECT 123 AS "Sheep", CAST(id AS float) FROM dbd_pg_test WHERE id=?'); is ($sth->{'NUM_OF_PARAMS'}, 1, $t); $t='Statement handle attribute "NUM_OF_FIELDS" returns undef before execute'; is ($sth->{'NUM_OF_FIELDS'}, undef, $t); $t='Statement handle attribute "NAME" returns undef before execute'; is ($sth->{'NAME'}, undef, $t); $t='Statement handle attribute "NAME_lc" returns undef before execute'; is ($sth->{'NAME_lc'}, undef, $t); $t='Statement handle attribute "NAME_uc" returns undef before execute'; is ($sth->{'NAME_uc'}, undef, $t); $t='Statement handle attribute "NAME_hash" returns undef before execute'; is ($sth->{'NAME_hash'}, undef, $t); $t='Statement handle attribute "NAME_lc_hash" returns undef before execute'; is ($sth->{'NAME_lc_hash'}, undef, $t); $t='Statement handle attribute "NAME_uc_hash" returns undef before execute'; is ($sth->{'NAME_uc_hash'}, undef, $t); $t='Statement handle attribute "TYPE" returns undef before execute'; is ($sth->{'TYPE'}, undef, $t); $t='Statement handle attribute "PRECISION" returns undef before execute'; is ($sth->{'PRECISION'}, undef, $t); $t='Statement handle attribute "SCALE" returns undef before execute'; is ($sth->{'SCALE'}, undef, $t); $t='Statement handle attribute "NULLABLE" returns undef before execute'; is ($sth->{'NULLABLE'}, undef, $t); ## Now, some post-execute checks: $t='Statement handle attribute "NUM_OF_PARAMS" works correctly after execute'; $sth->execute(12); is ($sth->{'NUM_OF_PARAMS'}, 1, $t); $t='Statement handle attribute "NUM_OF_FIELDS" works correctly for SELECT statements'; is ($sth->{'NUM_OF_FIELDS'}, 2, $t); $t='Statement handle attribute "NAME" works correctly for SELECT statements'; my $colnames = ['Sheep', 'id']; is_deeply ($sth->{'NAME'}, $colnames, $t); $t='Statement handle attribute "NAME_lc" works correctly for SELECT statements'; $colnames = ['sheep', 'id']; is_deeply ($sth->{'NAME_lc'}, $colnames, $t); $t='Statement handle attribute "NAME_uc" works correctly for SELECT statements'; $colnames = ['SHEEP', 'ID']; is_deeply ($sth->{'NAME_uc'}, $colnames, $t); $t='Statement handle attribute "NAME_hash" works correctly for SELECT statements'; $colnames = {'Sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_lc_hash" works correctly for SELECT statements'; $colnames = {'sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_lc_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_uc_hash" works correctly for SELECT statements'; $colnames = {'SHEEP' => 0, ID => 1}; is_deeply ($sth->{'NAME_uc_hash'}, $colnames, $t); $t='Statement handle attribute "TYPE" works correctly for SELECT statements'; $colnames = [4, 6]; is_deeply ($sth->{'TYPE'}, $colnames, $t); $t='Statement handle attribute "PRECISION" works correctly'; $colnames = [4, 8]; is_deeply ($sth->{'PRECISION'}, $colnames, $t); $t='Statement handle attribute "SCALE" works correctly'; $colnames = [undef,undef]; is_deeply ($sth->{'SCALE'}, $colnames, $t); $t='Statement handle attribute "NULLABLE" works correctly'; $colnames = [2,2]; is_deeply ($sth->{NULLABLE}, $colnames, $t); ## Post-finish tasks: $sth->finish(); $t='Statement handle attribute "NUM_OF_PARAMS" works correctly after finish'; is ($sth->{'NUM_OF_PARAMS'}, 1, $t); $t='Statement handle attribute "NUM_OF_FIELDS" works correctly after finish'; is ($sth->{'NUM_OF_FIELDS'}, 2, $t); $t='Statement handle attribute "NAME" returns undef after finish'; is_deeply ($sth->{'NAME'}, undef, $t); $t='Statement handle attribute "NAME_lc" returns values after finish'; $colnames = ['sheep', 'id']; is_deeply ($sth->{'NAME_lc'}, $colnames, $t); $t='Statement handle attribute "NAME_uc" returns values after finish'; $colnames = ['SHEEP', 'ID']; is_deeply ($sth->{'NAME_uc'}, $colnames, $t); $t='Statement handle attribute "NAME_hash" works correctly after finish'; $colnames = {'Sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_lc_hash" works correctly after finish'; $colnames = {'sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_lc_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_uc_hash" works correctly after finish'; $colnames = {'SHEEP' => 0, ID => 1}; is_deeply ($sth->{'NAME_uc_hash'}, $colnames, $t); $t='Statement handle attribute "TYPE" returns undef after finish'; is_deeply ($sth->{'TYPE'}, undef, $t); $t='Statement handle attribute "PRECISION" works correctly after finish'; is_deeply ($sth->{'PRECISION'}, undef, $t); $t='Statement handle attribute "SCALE" works correctly after finish'; is_deeply ($sth->{'SCALE'}, undef, $t); $t='Statement handle attribute "NULLABLE" works correctly after finish'; is_deeply ($sth->{NULLABLE}, undef, $t); ## Test UPDATE queries $t='Statement handle attribute "NUM_OF_FIELDS" returns undef for updates'; $sth = $dbh->prepare('UPDATE dbd_pg_test SET id = 99 WHERE id = ?'); $sth->execute(1); is_deeply ($sth->{'NUM_OF_FIELDS'}, undef, $t); $t='Statement handle attribute "NAME" returns empty arrayref for updates'; is_deeply ($sth->{'NAME'}, [], $t); ## These cause assertion errors, may be a DBI bug. ## Commenting out for now until we can examine closer ## Please see: http://www.nntp.perl.org/group/perl.cpan.testers/2008/08/msg2012293.html #$t='Statement handle attribute "NAME_lc" returns empty arrayref for updates'; #is_deeply ($sth->{'NAME_lc'}, [], $t); #$t='Statement handle attribute "NAME_uc" returns empty arrayref for updates'; #is_deeply ($sth->{'NAME_uc'}, [], $t); #$t='Statement handle attribute "NAME_hash" returns empty hashref for updates'; #is_deeply ($sth->{'NAME_hash'}, {}, $t); #$t='Statement handle attribute "NAME_uc_hash" returns empty hashref for updates'; #is_deeply ($sth->{'NAME_lc_hash'}, {}, $t); #$t='Statement handle attribute "NAME_uc_hash" returns empty hashref for updates'; #is_deeply ($sth->{'NAME_uc_hash'}, {}, $t); $t='Statement handle attribute "TYPE" returns empty arrayref for updates'; is_deeply ($sth->{'TYPE'}, [], $t); $t='Statement handle attribute "PRECISION" returns empty arrayref for updates'; is_deeply ($sth->{'PRECISION'}, [], $t); $t='Statement handle attribute "SCALE" returns empty arrayref for updates'; is_deeply ($sth->{'SCALE'}, [], $t); $t='Statement handle attribute "NULLABLE" returns empty arrayref for updates'; is_deeply ($sth->{'NULLABLE'}, [], $t); $dbh->do('UPDATE dbd_pg_test SET id = 1 WHERE id = 99'); ## Test UPDATE,INSERT, and DELETE with RETURNING SKIP: { if ($pgversion < 80200) { skip ('Cannot test RETURNING clause on pre 8.2 servers', 33); } $t='Statement handle attribute "NUM_OF_FIELDS" returns correct value for RETURNING updates'; $sth = $dbh->prepare('UPDATE dbd_pg_test SET id = 99 WHERE id = ? RETURNING id, expo, "CaseTest"'); $sth->execute(1); is_deeply ($sth->{'NUM_OF_FIELDS'}, 3, $t); $t='Statement handle attribute "NAME" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME'}, ['id','expo','CaseTest'], $t); $t='Statement handle attribute "NAME_lc" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_lc'}, ['id','expo','casetest'], $t); $t='Statement handle attribute "NAME_uc" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_uc'}, ['ID','EXPO','CASETEST'], $t); $t='Statement handle attribute "NAME_hash" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_hash'}, {id=>0, expo=>1, CaseTest=>2}, $t); $t='Statement handle attribute "NAME_lc_hash" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_lc_hash'}, {id=>0, expo=>1, casetest=>2}, $t); $t='Statement handle attribute "NAME_uc_hash" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_uc_hash'}, {ID=>0, EXPO=>1, CASETEST=>2}, $t); $t='Statement handle attribute "TYPE" returns correct info for RETURNING updates'; is_deeply ($sth->{'TYPE'}, [4,3,16], $t); $t='Statement handle attribute "PRECISION" returns correct info for RETURNING updates'; is_deeply ($sth->{'PRECISION'}, [4,6,1], $t); $t='Statement handle attribute "SCALE" returns correct info for RETURNING updates'; is_deeply ($sth->{'SCALE'}, [undef,2,undef], $t); $t='Statement handle attribute "NULLABLE" returns empty arrayref for updates'; is_deeply ($sth->{'NULLABLE'}, [0,1,1], $t); $dbh->do('UPDATE dbd_pg_test SET id = 1 WHERE id = 99'); $t='Statement handle attribute "NUM_OF_FIELDS" returns correct value for RETURNING inserts'; $sth = $dbh->prepare('INSERT INTO dbd_pg_test(id) VALUES(?) RETURNING id, lii, expo, "CaseTest"'); $sth->execute(88); is_deeply ($sth->{'NUM_OF_FIELDS'}, 4, $t); $t='Statement handle attribute "NAME" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME'}, ['id','lii','expo','CaseTest'], $t); $t='Statement handle attribute "NAME_lc" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_lc'}, ['id','lii','expo','casetest'], $t); $t='Statement handle attribute "NAME_uc" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_uc'}, ['ID','LII','EXPO','CASETEST'], $t); $t='Statement handle attribute "NAME_hash" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_hash'}, {id=>0, lii=>1, expo=>2, CaseTest=>3}, $t); $t='Statement handle attribute "NAME_lc_hash" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_lc_hash'}, {id=>0, lii=>1, expo=>2, casetest=>3}, $t); $t='Statement handle attribute "NAME_uc_hash" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_uc_hash'}, {ID=>0, LII=>1, EXPO=>2, CASETEST=>3}, $t); $t='Statement handle attribute "TYPE" returns correct info for RETURNING inserts'; is_deeply ($sth->{'TYPE'}, [4,4,3,16], $t); $t='Statement handle attribute "PRECISION" returns correct info for RETURNING inserts'; is_deeply ($sth->{'PRECISION'}, [4,4,6,1], $t); $t='Statement handle attribute "SCALE" returns correct info for RETURNING inserts'; is_deeply ($sth->{'SCALE'}, [undef,undef,2,undef], $t); $t='Statement handle attribute "NULLABLE" returns empty arrayref for inserts'; is_deeply ($sth->{'NULLABLE'}, [0,0,1,1], $t); $t='Statement handle attribute "NUM_OF_FIELDS" returns correct value for RETURNING updates'; $sth = $dbh->prepare('DELETE FROM dbd_pg_test WHERE id = 88 RETURNING id, lii, expo, "CaseTest"'); $sth->execute(); is_deeply ($sth->{'NUM_OF_FIELDS'}, 4, $t); $t='Statement handle attribute "NAME" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME'}, ['id','lii','expo','CaseTest'], $t); $t='Statement handle attribute "NAME_lc" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME_lc'}, ['id','lii','expo','casetest'], $t); $t='Statement handle attribute "NAME_uc" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME_uc'}, ['ID','LII','EXPO','CASETEST'], $t); $t='Statement handle attribute "NAME_hash" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME_hash'}, {id=>0, lii=>1, expo=>2, CaseTest=>3}, $t); $t='Statement handle attribute "NAME_lc_hash" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME_lc_hash'}, {id=>0, lii=>1, expo=>2, casetest=>3}, $t); $t='Statement handle attribute "NAME_uc_hash" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME_uc_hash'}, {ID=>0, LII=>1, EXPO=>2, CASETEST=>3}, $t); $t='Statement handle attribute "TYPE" returns correct info for RETURNING deletes'; is_deeply ($sth->{'TYPE'}, [4,4,3,16], $t); $t='Statement handle attribute "PRECISION" returns correct info for RETURNING deletes'; is_deeply ($sth->{'PRECISION'}, [4,4,6,1], $t); $t='Statement handle attribute "SCALE" returns correct info for RETURNING deletes'; is_deeply ($sth->{'SCALE'}, [undef,undef,2,undef], $t); $t='Statement handle attribute "NULLABLE" returns empty arrayref for deletes'; is_deeply ($sth->{'NULLABLE'}, [0,0,1,1], $t); } $t='Statement handle attribute "NUM_OF_FIELDS" returns correct value for SHOW commands'; $sth = $dbh->prepare('SHOW random_page_cost'); $sth->execute(); is_deeply ($sth->{'NUM_OF_FIELDS'}, 1, $t); $t='Statement handle attribute "NAME" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME'}, ['random_page_cost'], $t); $t='Statement handle attribute "NAME_lc" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME_lc'}, ['random_page_cost'], $t); $t='Statement handle attribute "NAME_uc" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME_uc'}, ['RANDOM_PAGE_COST'], $t); $t='Statement handle attribute "NAME_hash" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME_hash'}, {random_page_cost=>0}, $t); $t='Statement handle attribute "NAME_lc_hash" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME_lc_hash'}, {random_page_cost=>0}, $t); $t='Statement handle attribute "NAME_uc_hash" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME_uc_hash'}, {RANDOM_PAGE_COST=>0}, $t); $t='Statement handle attribute "TYPE" returns correct info for SHOW commands'; is_deeply ($sth->{'TYPE'}, [-1], $t); $t='Statement handle attribute "PRECISION" returns correct info for SHOW commands'; is_deeply ($sth->{'PRECISION'}, [undef], $t); $t='Statement handle attribute "SCALE" returns correct info for SHOW commands'; is_deeply ($sth->{'SCALE'}, [undef], $t); $t='Statement handle attribute "NULLABLE" returns "unknown" (2) for SHOW commands'; is_deeply ($sth->{'NULLABLE'}, [2], $t); # # Test of the statement handle attribute "CursorName" # $t='Statement handle attribute "CursorName" returns undef'; $attrib = $sth->{CursorName}; is ($attrib, undef, $t); # # Test of the statement handle attribute "Database" # $t='Statement handle attribute "Database" matches the database handle'; $attrib = $sth->{Database}; is ($attrib, $dbh, $t); # # Test of the statement handle attribute "ParamValues" # $t='Statement handle attribute "ParamValues" works before execute'; $sth = $dbh->prepare('SELECT id FROM dbd_pg_test WHERE id=? AND val=? AND pname=?'); $sth->bind_param(1, 99); $sth->bind_param(2, undef); $sth->bind_param(3, 'Sparky'); $attrib = $sth->{ParamValues}; $expected = {1 => '99', 2 => undef, 3 => 'Sparky'}; is_deeply ($attrib, $expected, $t); $t='Statement handle attribute "ParamValues" works after execute'; $sth->execute(); $attrib = $sth->{ParamValues}; is_deeply ($attrib, $expected, $t); # # Test of the statement handle attribute "ParamTypes" # $t='Statement handle attribute "ParamTypes" works before execute'; $sth = $dbh->prepare('SELECT id FROM dbd_pg_test WHERE id=? AND val=? AND lii=?'); $sth->bind_param(1, 1, SQL_INTEGER); $sth->bind_param(2, 'TMW', SQL_VARCHAR); $attrib = $sth->{ParamTypes}; $expected = {1 => {TYPE => SQL_INTEGER}, 2 => {TYPE => SQL_VARCHAR}, 3 => undef}; is_deeply ($attrib, $expected, $t); $t='Statement handle attributes "ParamValues" and "ParamTypes" can be pased back to bind_param'; eval { my $vals = $sth->{ParamValues}; my $types = $sth->{ParamTypes}; $sth->bind_param($_, $vals->{$_}, $types->{$_} ) for keys %$types; }; is( $@, q{}, $t); $t='Statement handle attribute "ParamTypes" works before execute with named placeholders'; $sth = $dbh->prepare('SELECT id FROM dbd_pg_test WHERE id=:foobar AND val=:foobar2 AND lii=:foobar3'); $sth->bind_param(':foobar', 1, {pg_type => PG_INT4}); $sth->bind_param(':foobar2', 'TMW', {pg_type => PG_TEXT}); $attrib = $sth->{ParamTypes}; $expected = {':foobar' => {TYPE => SQL_INTEGER}, ':foobar2' => {TYPE => SQL_LONGVARCHAR}, ':foobar3' => undef}; is_deeply ($attrib, $expected, $t); $t='Statement handle attributes "ParamValues" and "ParamTypes" can be passed back to bind_param'; eval { my $vals = $sth->{ParamValues}; my $types = $sth->{ParamTypes}; $sth->bind_param($_, $vals->{$_}, $types->{$_} ) for keys %$types; }; is( $@, q{}, $t); $t='Statement handle attribute "ParamTypes" works after execute'; $sth->bind_param(':foobar3', 3, {pg_type => PG_INT2}); $sth->execute(); $attrib = $sth->{ParamTypes}; $expected->{':foobar3'} = {TYPE => SQL_SMALLINT}; is_deeply ($attrib, $expected, $t); $t='Statement handle attribute "ParamTypes" returns correct values'; $sth->bind_param(':foobar2', 3, {pg_type => PG_CIRCLE}); $attrib = $sth->{ParamTypes}{':foobar2'}; $expected = {pg_type => PG_CIRCLE}; is_deeply ($attrib, $expected, $t); # # Test of the statement handle attribute "RowsInCache" # $t='Statement handle attribute "RowsInCache" returns undef'; $attrib = $sth->{RowsInCache}; is ($attrib, undef, $t); # # Test of the statement handle attribute "pg_size" # $t='Statement handle attribute "pg_size" works'; $SQL = q{SELECT id, pname, val, score, Fixed, pdate, "CaseTest" FROM dbd_pg_test}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->{pg_size}; $expected = [qw(4 -1 -1 8 -1 8 1)]; is_deeply ($result, $expected, $t); # # Test of the statement handle attribute "pg_type" # $t='Statement handle attribute "pg_type" works'; $sth->execute(); $result = $sth->{pg_type}; $expected = [qw(int4 varchar text float8 bpchar timestamp bool)]; is_deeply ($result, $expected, $t); $sth->finish(); # # Test of the statement handle attribute "pg_oid_status" # $t='Statement handle attribute "pg_oid_status" returned a numeric value after insert'; $SQL = q{INSERT INTO dbd_pg_test (id, val) VALUES (?, 'lemon')}; $sth = $dbh->prepare($SQL); $sth->bind_param('$1','',SQL_INTEGER); $sth->execute(500); $result = $sth->{pg_oid_status}; like ($result, qr/^\d+$/, $t); # # Test of the statement handle attribute "pg_cmd_status" # ## INSERT DELETE UPDATE SELECT for ( q{INSERT INTO dbd_pg_test (id,val) VALUES (400, 'lime')}, q{DELETE FROM dbd_pg_test WHERE id=1}, q{UPDATE dbd_pg_test SET id=2 WHERE id=2}, q{SELECT * FROM dbd_pg_test}, ) { $expected = substr($_,0,6); $t=qq{Statement handle attribute "pg_cmd_status" works for '$expected'}; $sth = $dbh->prepare($_); $sth->execute(); $result = $sth->{pg_cmd_status}; $sth->finish(); like ($result, qr/^$expected/, $t); } ## From this point forward, it is safe to use the client's native encoding again if ($old_encoding ne 'UTF8') { $dbh->do(qq{SET NAMES '$old_encoding'}); } # # Test of the handle attribute "Active" # $t='Database handle attribute "Active" is true while connected'; $attrib = $dbh->{Active}; is ($attrib, 1, $t); $t='Statement handle attribute "Active" is false before SELECT'; $sth = $dbh->prepare('SELECT 123 UNION SELECT 456'); $attrib = $sth->{Active}; is ($attrib, '', $t); $t='Statement handle attribute "Active" is true after SELECT'; $sth->execute(); $attrib = $sth->{Active}; is ($attrib, 1, $t); $t='Statement handle attribute "Active" is true when rows remaining'; my $row = $sth->fetchrow_arrayref(); $attrib = $sth->{Active}; is ($attrib, 1, $t); $t='Statement handle attribute "Active" is false after finish called'; $sth->finish(); $attrib = $sth->{Active}; is ($attrib, '', $t); # # Test of the handle attribute "Executed" # my $dbh3 = connect_database({quickreturn => 1}); $dbh3->{AutoCommit} = 0; $t='Database handle attribute "Executed" begins false'; is ($dbh3->{Executed}, '', $t); $t='Database handle attribute "Executed" stays false after prepare()'; $sth = $dbh3->prepare('SELECT 12345'); is ($dbh3->{Executed}, '', $t); $t='Statement handle attribute "Executed" begins false'; is ($sth->{Executed}, '', $t); $t='Statement handle attribute "Executed" is true after execute()'; $sth->execute(); is ($sth->{Executed}, 1, $t); $t='Database handle attribute "Executed" is true after execute()'; is ($dbh3->{Executed}, 1, $t); $t='Statement handle attribute "Executed" is true after finish()'; $sth->finish(); is ($sth->{Executed}, 1, $t); $t='Database handle attribute "Executed" is true after finish()'; is ($dbh3->{Executed}, 1, $t); $t='Database handle attribute "Executed" is false after commit()'; $dbh3->commit(); is ($dbh3->{Executed}, '', $t); $t='Statement handle attribute "Executed" is true after commit()'; is ($sth->{Executed}, 1, $t); $t='Database handle attribute "Executed" is true after do()'; $dbh3->do('SELECT 1234'); is ($dbh3->{Executed}, 1, $t); $t='Database handle attribute "Executed" is false after rollback()'; $dbh3->commit(); is ($dbh3->{Executed}, '', $t); $t='Statement handle attribute "Executed" is true after rollback()'; is ($sth->{Executed}, 1, $t); $dbh3->disconnect(); # # Test of the handle attribute "Kids" # $t='Database handle attribute "Kids" is set properly'; $attrib = $dbh->{Kids}; is ($attrib, 2, $t); $t='Database handle attribute "Kids" works'; my $sth2 = $dbh->prepare('SELECT 234'); $attrib = $dbh->{Kids}; is ($attrib, 3, $t); $t='Statement handle attribute "Kids" is zero'; $attrib = $sth2->{Kids}; is ($attrib, 0, $t); # # Test of the handle attribute "ActiveKids" # $t='Database handle attribute "ActiveKids" is set properly'; $attrib = $dbh->{ActiveKids}; is ($attrib, 0, $t); $t='Database handle attribute "ActiveKids" works'; $sth2 = $dbh->prepare('SELECT 234'); $sth2->execute(); $attrib = $dbh->{ActiveKids}; is ($attrib, 1, $t); $t='Statement handle attribute "ActiveKids" is zero'; $attrib = $sth2->{ActiveKids}; is ($attrib, 0, $t); # # Test of the handle attribute "CachedKids" # $t='Database handle attribute "CachedKids" is set properly'; $attrib = $dbh->{CachedKids}; is (keys %$attrib, 2, $t); # # Test of the handle attribute "Type" # $t='Database handle attribute "Type" is set properly'; $attrib = $dbh->{Type}; is ($attrib, 'db', $t); $t='Statement handle attribute "Type" is set properly'; $sth = $dbh->prepare('SELECT 1'); $attrib = $sth->{Type}; is ($attrib, 'st', $t); # # Test of the handle attribute "ChildHandles" # Need a separate connection to keep the output size down # my $dbh4 = connect_database({quickreturn => 1}); $t='Database handle attribute "ChildHandles" is an empty list on startup'; $attrib = $dbh4->{ChildHandles}; is_deeply ($attrib, [], $t); $t='Statement handle attribute "ChildHandles" is an empty list on creation'; { my $sth4 = $dbh4->prepare('SELECT 1'); $attrib = $sth4->{ChildHandles}; is_deeply ($attrib, [], $t); $t='Database handle attribute "ChildHandles" contains newly created statement handle'; $attrib = $dbh4->{ChildHandles}; is_deeply ($attrib, [$sth4], $t); $sth4->finish(); } ## sth4 now out of scope $t='Database handle attribute "ChildHandles" has undef for destroyed statement handle'; $attrib = $dbh4->{ChildHandles}; is_deeply ($attrib, [undef], $t); $dbh4->disconnect(); # # Test of the handle attribute "CompatMode" # $t='Database handle attribute "CompatMode" is set properly'; $attrib = $dbh->{CompatMode}; ok (!$attrib, $t); # # Test of the handle attribute PrintError # $t='Database handle attribute "PrintError" is set properly'; $attrib = $dbh->{PrintError}; is ($attrib, '', $t); # Make sure that warnings are sent back to the client # We assume that older servers are okay my $client_level = ''; $sth = $dbh->prepare('SHOW client_min_messages'); $sth->execute(); $client_level = $sth->fetchall_arrayref()->[0][0]; $SQL = 'Testing the DBD::Pg modules error handling -?-'; if ($client_level eq 'error') { SKIP: { skip (q{Cannot test "PrintError" attribute because client_min_messages is set to 'error'}, 2); } SKIP: { skip (q{Cannot test "RaiseError" attribute because client_min_messages is set to 'error'}, 2); } SKIP: { skip (q{Cannot test "HandleError" attribute because client_min_messages is set to 'error'}, 2); } SKIP: { skip (q{Cannot test "HandleSetErr" attribute because client_min_messages is set to 'error'}, 4); } } else { { $warning = ''; local $SIG{__WARN__} = sub { $warning = shift; }; $dbh->{RaiseError} = 0; $t='Warning thrown when database handle attribute "PrintError" is on'; $dbh->{PrintError} = 1; $sth = $dbh->prepare($SQL); $sth->execute(); isnt ($warning, undef, $t); $t='No warning thrown when database handle attribute "PrintError" is off'; undef $warning; $dbh->{PrintError} = 0; $sth = $dbh->prepare($SQL); $sth->execute(); is ($warning, undef, $t); } } # # Test of the handle attribute RaiseError # if ($client_level ne 'error') { $t='No error produced when database handle attribute "RaiseError" is off'; $dbh->{RaiseError} = 0; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; is ($@, q{}, $t); $t='Error produced when database handle attribute "RaiseError" is off'; $dbh->{RaiseError} = 1; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; isnt ($@, q{}, $t); } # # Test of the handle attribute HandleError # $t='Database handle attribute "HandleError" is set properly'; $attrib = $dbh->{HandleError}; ok (!$attrib, $t); if ($client_level ne 'error') { $t='Database handle attribute "HandleError" works'; undef $warning; $dbh->{HandleError} = sub { $warning = shift; }; $sth = $dbh->prepare($SQL); $sth->execute(); ok ($warning, $t); $t='Database handle attribute "HandleError" modifies error messages'; undef $warning; $dbh->{HandleError} = sub { $_[0] = "Slonik $_[0]"; 0; }; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; like ($@, qr/^Slonik/, $t); $dbh->{HandleError}= undef; $dbh->rollback(); } # # Test of the handle attribute HandleSetErr # $t='Database handle attribute "HandleSetErr" is set properly'; $attrib = $dbh->{HandleSetErr}; ok (!$attrib, $t); if ($client_level ne 'error') { $t='Database handle attribute "HandleSetErr" works as expected'; undef $warning; $dbh->{HandleSetErr} = sub { my ($h,$err,$errstr,$state,$method) = @_; $_[1] = 42; $_[2] = 'ERRSTR'; $_[3] = '33133'; return; }; eval {$sth = $dbh->last_insert_id('cat', 'schema', 'table', 'col', ['notahashref']); }; ## Changing the state does not work yet. like ($@, qr{ERRSTR}, $t); is ($dbh->errstr, 'ERRSTR', $t); is ($dbh->err, '42', $t); $dbh->{HandleSetErr} = 0; $dbh->rollback(); } # # Test of the handle attribute "ErrCount" # $t='Database handle attribute "ErrCount" starts out at 0'; $dbh4 = connect_database({quickreturn => 1}); is ($dbh4->{ErrCount}, 0, $t); $t='Database handle attribute "ErrCount" is incremented with set_err()'; eval {$sth = $dbh4->last_insert_id('cat', 'schema', 'table', 'col', ['notahashref']); }; is ($dbh4->{ErrCount}, 1, $t); $dbh4->disconnect(); # # Test of the handle attribute "ShowErrorStatement" # $t='Database handle attribute "ShowErrorStatemnt" starts out false'; is ($dbh->{ShowErrorStatement}, '', $t); $SQL = 'Testing the ShowErrorStatement attribute'; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; $t='Database handle attribute "ShowErrorStatement" has no effect if not set'; unlike ($@, qr{for Statement "Testing}, $t); $dbh->{ShowErrorStatement} = 1; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; $t='Database handle attribute "ShowErrorStatement" adds statement to errors'; like ($@, qr{for Statement "Testing}, $t); $SQL = q{SELECT 'Another ShowErrorStatement Test' FROM pg_class WHERE relname = ? AND reltuples = ?}; eval { $sth = $dbh->prepare($SQL); $sth->execute(123); }; $t='Database handle attribute "ShowErrorStatement" adds statement and placeholders to errors'; like ($@, qr{with ParamValues}, $t); $SQL = q{SELECT 'Another ShowErrorStatement Test' FROM pg_class WHERE relname = ? AND reltuples = ?}; eval { $sth = $dbh->prepare($SQL); $sth->execute(123,456); }; $t='Database handle attribute "ShowErrorStatement" adds statement and placeholders to errors'; like ($@, qr{with ParamValues: 1='123', 2='456'}, $t); $dbh->commit(); # # Test of the handle attribute TraceLevel # $t='Database handle attribute "TraceLevel" returns a number'; $attrib = $dbh->{TraceLevel}; like ($attrib, qr/^\d$/, $t); # # Test of the handle attribute FetchHashKeyName # # The default is mixed case ("NAME"); $t='Database handle attribute "FetchHashKeyName" is set properly'; $attrib = $dbh->{FetchHashKeyName}; is ($attrib, 'NAME', $t); $t='Database handle attribute "FetchHashKeyName" works with the default value of NAME'; $SQL = q{SELECT "CaseTest" FROM dbd_pg_test}; $sth = $dbh->prepare($SQL); $sth->execute(); my ($colname) = keys %{$sth->fetchrow_hashref()}; $sth->finish(); is ($colname, 'CaseTest', $t); $t='Database handle attribute "FetchHashKeyName" can be changed'; $dbh->{FetchHashKeyName} = 'NAME_lc'; $attrib = $dbh->{FetchHashKeyName}; is ($attrib, 'NAME_lc', $t); $t='Database handle attribute "FetchHashKeyName" works with a value of NAME_lc'; $sth = $dbh->prepare($SQL); $sth->execute(); ($colname) = keys %{$sth->fetchrow_hashref()}; is ($colname, 'casetest', $t); $sth->finish(); $t='Database handle attribute "FetchHashKeyName" works with a value of NAME_uc'; $dbh->{FetchHashKeyName} = 'NAME_uc'; $sth = $dbh->prepare($SQL); $sth->execute(); ($colname) = keys %{$sth->fetchrow_hashref()}; $sth->finish(); $dbh->{FetchHashKeyName} = 'NAME'; is ($colname, 'CASETEST', $t); # # Test of the handle attribute ChopBlanks # $t='Database handle attribute "ChopBlanks" is set properly'; $attrib = $dbh->{ChopBlanks}; ok (!$attrib, $t); $dbh->do('DELETE FROM dbd_pg_test'); $dbh->do(q{INSERT INTO dbd_pg_test (id, fixed, val) VALUES (3, ' Fig', ' Raspberry ')}); $t='Database handle attribute "ChopBlanks" = 0 returns correct value for fixed-length column'; $dbh->{ChopBlanks} = 0; my ($val) = $dbh->selectall_arrayref(q{SELECT fixed FROM dbd_pg_test WHERE id = 3})->[0][0]; is ($val, ' Fig ', $t); $t='Database handle attribute "ChopBlanks" = 0 returns correct value for variable-length column'; ($val) = $dbh->selectrow_array(q{SELECT val FROM dbd_pg_test WHERE id = 3}); is ($val, ' Raspberry ', $t); $t='Database handle attribute "ChopBlanks" = 1 returns correct value for fixed-length column'; $dbh->{ChopBlanks}=1; ($val) = $dbh->selectall_arrayref(q{SELECT fixed FROM dbd_pg_test WHERE id = 3})->[0][0]; is ($val, ' Fig', $t); $t='Database handle attribute "ChopBlanks" = 1 returns correct value for variable-length column'; ($val) = $dbh->selectrow_array(q{SELECT val FROM dbd_pg_test WHERE id = 3}); $dbh->do('DELETE from dbd_pg_test'); is ($val, ' Raspberry ', $t); # # Test of the handle attribute LongReadLen # $t='Handle attribute "LongReadLen" has been set properly'; $attrib = $dbh->{LongReadLen}; ok ($attrib, $t); # # Test of the handle attribute LongTruncOk # $t='Handle attribute "LongTruncOk" has been set properly'; $attrib = $dbh->{LongTruncOk}; ok (!$attrib, $t); # # Test of the handle attribute TaintIn # $t='Handle attribute "TaintIn" has been set properly'; $attrib = $dbh->{TaintIn}; is ($attrib, '', $t); # # Test of the handle attribute TaintOut # $t='Handle attribute "TaintOut" has been set properly'; $attrib = $dbh->{TaintOut}; is ($attrib, '', $t); # # Test of the handle attribute Taint # $t='Handle attribute "Taint" has been set properly'; $attrib = $dbh->{Taint}; is ($attrib, '', $t); $t='The value of handle attribute "Taint" can be changed'; $dbh->{Taint}=1; $attrib = $dbh->{Taint}; is ($attrib, 1, $t); $t='Changing handle attribute "Taint" changes "TaintIn"'; $attrib = $dbh->{TaintIn}; is ($attrib, 1, $t); $t='Changing handle attribute "Taint" changes "TaintOut"'; $attrib = $dbh->{TaintOut}; is ($attrib, 1, $t); # # Not tested: handle attribute Profile # # # Test of the database handle attribute "ReadOnly" # SKIP: { if ($DBI::VERSION < 1.55) { skip ('DBI must be at least version 1.55 to test DB attribute "ReadOnly"', 8); } $t='Database handle attribute "ReadOnly" starts out undefined'; $dbh->commit(); ## This fails on some boxes, so we pull back all information to display why my ($helpconnect2, $connerror2); ($helpconnect2, $connerror2, $dbh4) = connect_database(); if (! defined $dbh4) { die "Database connection failed: helpconnect is $helpconnect2, error is $connerror2\n"; } $dbh4->trace(0); is ($dbh4->{ReadOnly}, undef, $t); $t='Database handle attribute "ReadOnly" allows SELECT queries to work when on'; $dbh4->{ReadOnly} = 1; $result = $dbh4->selectall_arrayref('SELECT 12345')->[0][0]; is ($result, 12345, $t); $t='Database handle attribute "ReadOnly" prevents INSERT queries from working when on'; $SQL = 'INSERT INTO dbd_pg_test (id) VALUES (50)'; eval { $dbh4->do($SQL); }; is($dbh4->state, '25006', $t); $dbh4->rollback(); $sth = $dbh4->prepare($SQL); eval { $sth->execute(); }; is($dbh4->state, '25006', $t); $dbh4->rollback(); $t='Database handle attribute "ReadOnly" allows INSERT queries when switched off'; $dbh4->{ReadOnly} = 0; eval { $dbh4->do($SQL); }; is ($@, q{}, $t); $dbh4->rollback(); $t='Database handle attribute "ReadOnly" allows INSERT queries when switched off'; $dbh4->{ReadOnly} = 0; eval { $dbh4->do($SQL); }; is ($@, q{}, $t); $dbh4->rollback(); $dbh4->{ReadOnly} = 1; $dbh4->{AutoCommit} = 1; $t='Database handle attribute "ReadOnly" has no effect if AutoCommit is on'; eval { $dbh4->do($SQL); }; is ($@, q{}, $t); my $delete = 'DELETE FROM dbd_pg_test WHERE id = 50'; $dbh4->do($delete); $sth = $dbh4->prepare($SQL); eval { $sth->execute(); }; is ($@, q{}, $t); $dbh4->disconnect(); } # # Test of the database handle attribute InactiveDestroy # This one must be the last test performed! # $t='Database handle attribute "InactiveDestroy" is set properly'; $attrib = $dbh->{InactiveDestroy}; ok (!$attrib, $t); # Disconnect in preparation for the fork tests ok ($dbh->disconnect(), 'Disconnect from database'); $t='Database handle attribute "Active" is false after disconnect'; $attrib = $dbh->{Active}; is ($attrib, '', $t); SKIP: { skip ('Cannot test database handle "InactiveDestroy" on a non-forking system', 8) if $^O =~ /Win/; require Test::Simple; skip ('Test::Simple version 0.47 or better required for testing of attribute "InactiveDestroy"', 8) if $Test::Simple::VERSION < 0.47; # Test of forking. Hang on to your hats my $answer = 42; $SQL = "SELECT $answer FROM dbd_pg_test WHERE id > ? LIMIT 1"; for my $destroy (0,1) { $dbh = connect_database({nosetup => 1, AutoCommit => 1}); $sth = $dbh->prepare($SQL); $sth->execute(1); $sth->finish(); # Desired flow: parent test, child test, child kill, parent test if (fork) { $t=qq{Parent in fork test is working properly ("InactiveDestroy" = $destroy)}; $sth->execute(1); $val = $sth->fetchall_arrayref()->[0][0]; is ($val, $answer, $t); # Let the child exit first select(undef,undef,undef,0.3); } else { # Child $dbh->{InactiveDestroy} = $destroy; select(undef,undef,undef,0.1); # Age before beauty exit; ## Calls disconnect via DESTROY unless InactiveDestroy set } if ($destroy) { $t=qq{Ping works after the child has exited ("InactiveDestroy" = $destroy)}; ok ($dbh->ping(), $t); $t='Successful ping returns a SQLSTATE code of 00000 (empty string)'; my $state = $dbh->state(); is ($state, '', $t); $t='Statement handle works after forking'; $sth->execute(1); $val = $sth->fetchall_arrayref()->[0][0]; is ($val, $answer, $t); } else { $t=qq{Ping fails after the child has exited ("InactiveDestroy" = $destroy)}; is ( $dbh->ping(), 0, $t); $t='Failed ping returns a SQLSTATE code of 08000'; my $state = $dbh->state(); is ($state, '08000', $t); $t=qq{pg_ping gives an error code of -2 after the child has exited ("InactiveDestroy" = $destroy)}; is ( $dbh->pg_ping(), -2,$t); } } } cleanup_database($dbh,'test'); $dbh->disconnect(); DBD-Pg-2.19.3/t/00basic.t0000644000076400007640000000073411642756716013101 0ustar greggreg#!perl ## Simply test that we can load the DBI and DBD::Pg modules, ## and that the latter gives a good version use 5.006; use strict; use warnings; use Test::More tests => 3; select(($|=1,select(STDERR),$|=1)[1]); BEGIN { use_ok ('DBI') or BAIL_OUT 'Cannot continue without DBI'; use_ok ('DBD::Pg') or BAIL_OUT 'Cannot continue without DBD::Pg'; } use DBD::Pg; like ($DBD::Pg::VERSION, qr/^v?\d+\.\d+\.\d+(?:_\d+)?$/, qq{Found DBD::Pg::VERSION as "$DBD::Pg::VERSION"}); DBD-Pg-2.19.3/t/01constants.t0000644000076400007640000002461611642756716014042 0ustar greggreg#!perl use 5.006; use strict; ## We cannot 'use warnings' here as PG_TSQUERY and others trip it up ## no critic (RequireUseWarnings) use Test::More tests => 136; select(($|=1,select(STDERR),$|=1)[1]); use DBD::Pg qw(:pg_types :async); ## Should match the list in Pg.xs ## This is auto-generated by types.c, so do not edit manually please is (PG_ABSTIME , 702, 'PG_ABSTIME returns correct value'); is (PG_ABSTIMEARRAY , 1023, 'PG_ABSTIMEARRAY returns correct value'); is (PG_ACLITEM , 1033, 'PG_ACLITEM returns correct value'); is (PG_ACLITEMARRAY , 1034, 'PG_ACLITEMARRAY returns correct value'); is (PG_ANY , 2276, 'PG_ANY returns correct value'); is (PG_ANYARRAY , 2277, 'PG_ANYARRAY returns correct value'); is (PG_ANYELEMENT , 2283, 'PG_ANYELEMENT returns correct value'); is (PG_ANYENUM , 3500, 'PG_ANYENUM returns correct value'); is (PG_ANYNONARRAY , 2776, 'PG_ANYNONARRAY returns correct value'); is (PG_BIT , 1560, 'PG_BIT returns correct value'); is (PG_BITARRAY , 1561, 'PG_BITARRAY returns correct value'); is (PG_BOOL , 16, 'PG_BOOL returns correct value'); is (PG_BOOLARRAY , 1000, 'PG_BOOLARRAY returns correct value'); is (PG_BOX , 603, 'PG_BOX returns correct value'); is (PG_BOXARRAY , 1020, 'PG_BOXARRAY returns correct value'); is (PG_BPCHAR , 1042, 'PG_BPCHAR returns correct value'); is (PG_BPCHARARRAY , 1014, 'PG_BPCHARARRAY returns correct value'); is (PG_BYTEA , 17, 'PG_BYTEA returns correct value'); is (PG_BYTEAARRAY , 1001, 'PG_BYTEAARRAY returns correct value'); is (PG_CHAR , 18, 'PG_CHAR returns correct value'); is (PG_CHARARRAY , 1002, 'PG_CHARARRAY returns correct value'); is (PG_CID , 29, 'PG_CID returns correct value'); is (PG_CIDARRAY , 1012, 'PG_CIDARRAY returns correct value'); is (PG_CIDR , 650, 'PG_CIDR returns correct value'); is (PG_CIDRARRAY , 651, 'PG_CIDRARRAY returns correct value'); is (PG_CIRCLE , 718, 'PG_CIRCLE returns correct value'); is (PG_CIRCLEARRAY , 719, 'PG_CIRCLEARRAY returns correct value'); is (PG_CSTRING , 2275, 'PG_CSTRING returns correct value'); is (PG_CSTRINGARRAY , 1263, 'PG_CSTRINGARRAY returns correct value'); is (PG_DATE , 1082, 'PG_DATE returns correct value'); is (PG_DATEARRAY , 1182, 'PG_DATEARRAY returns correct value'); is (PG_FDW_HANDLER , 3115, 'PG_FDW_HANDLER returns correct value'); is (PG_FLOAT4 , 700, 'PG_FLOAT4 returns correct value'); is (PG_FLOAT4ARRAY , 1021, 'PG_FLOAT4ARRAY returns correct value'); is (PG_FLOAT8 , 701, 'PG_FLOAT8 returns correct value'); is (PG_FLOAT8ARRAY , 1022, 'PG_FLOAT8ARRAY returns correct value'); is (PG_GTSVECTOR , 3642, 'PG_GTSVECTOR returns correct value'); is (PG_GTSVECTORARRAY , 3644, 'PG_GTSVECTORARRAY returns correct value'); is (PG_INET , 869, 'PG_INET returns correct value'); is (PG_INETARRAY , 1041, 'PG_INETARRAY returns correct value'); is (PG_INT2 , 21, 'PG_INT2 returns correct value'); is (PG_INT2ARRAY , 1005, 'PG_INT2ARRAY returns correct value'); is (PG_INT2VECTOR , 22, 'PG_INT2VECTOR returns correct value'); is (PG_INT2VECTORARRAY , 1006, 'PG_INT2VECTORARRAY returns correct value'); is (PG_INT4 , 23, 'PG_INT4 returns correct value'); is (PG_INT4ARRAY , 1007, 'PG_INT4ARRAY returns correct value'); is (PG_INT8 , 20, 'PG_INT8 returns correct value'); is (PG_INT8ARRAY , 1016, 'PG_INT8ARRAY returns correct value'); is (PG_INTERNAL , 2281, 'PG_INTERNAL returns correct value'); is (PG_INTERVAL , 1186, 'PG_INTERVAL returns correct value'); is (PG_INTERVALARRAY , 1187, 'PG_INTERVALARRAY returns correct value'); is (PG_LANGUAGE_HANDLER , 2280, 'PG_LANGUAGE_HANDLER returns correct value'); is (PG_LINE , 628, 'PG_LINE returns correct value'); is (PG_LINEARRAY , 629, 'PG_LINEARRAY returns correct value'); is (PG_LSEG , 601, 'PG_LSEG returns correct value'); is (PG_LSEGARRAY , 1018, 'PG_LSEGARRAY returns correct value'); is (PG_MACADDR , 829, 'PG_MACADDR returns correct value'); is (PG_MACADDRARRAY , 1040, 'PG_MACADDRARRAY returns correct value'); is (PG_MONEY , 790, 'PG_MONEY returns correct value'); is (PG_MONEYARRAY , 791, 'PG_MONEYARRAY returns correct value'); is (PG_NAME , 19, 'PG_NAME returns correct value'); is (PG_NAMEARRAY , 1003, 'PG_NAMEARRAY returns correct value'); is (PG_NUMERIC , 1700, 'PG_NUMERIC returns correct value'); is (PG_NUMERICARRAY , 1231, 'PG_NUMERICARRAY returns correct value'); is (PG_OID , 26, 'PG_OID returns correct value'); is (PG_OIDARRAY , 1028, 'PG_OIDARRAY returns correct value'); is (PG_OIDVECTOR , 30, 'PG_OIDVECTOR returns correct value'); is (PG_OIDVECTORARRAY , 1013, 'PG_OIDVECTORARRAY returns correct value'); is (PG_OPAQUE , 2282, 'PG_OPAQUE returns correct value'); is (PG_PATH , 602, 'PG_PATH returns correct value'); is (PG_PATHARRAY , 1019, 'PG_PATHARRAY returns correct value'); is (PG_PG_ATTRIBUTE , 75, 'PG_PG_ATTRIBUTE returns correct value'); is (PG_PG_CLASS , 83, 'PG_PG_CLASS returns correct value'); is (PG_PG_NODE_TREE , 194, 'PG_PG_NODE_TREE returns correct value'); is (PG_PG_PROC , 81, 'PG_PG_PROC returns correct value'); is (PG_PG_TYPE , 71, 'PG_PG_TYPE returns correct value'); is (PG_POINT , 600, 'PG_POINT returns correct value'); is (PG_POINTARRAY , 1017, 'PG_POINTARRAY returns correct value'); is (PG_POLYGON , 604, 'PG_POLYGON returns correct value'); is (PG_POLYGONARRAY , 1027, 'PG_POLYGONARRAY returns correct value'); is (PG_RECORD , 2249, 'PG_RECORD returns correct value'); is (PG_RECORDARRAY , 2287, 'PG_RECORDARRAY returns correct value'); is (PG_REFCURSOR , 1790, 'PG_REFCURSOR returns correct value'); is (PG_REFCURSORARRAY , 2201, 'PG_REFCURSORARRAY returns correct value'); is (PG_REGCLASS , 2205, 'PG_REGCLASS returns correct value'); is (PG_REGCLASSARRAY , 2210, 'PG_REGCLASSARRAY returns correct value'); is (PG_REGCONFIG , 3734, 'PG_REGCONFIG returns correct value'); is (PG_REGCONFIGARRAY , 3735, 'PG_REGCONFIGARRAY returns correct value'); is (PG_REGDICTIONARY , 3769, 'PG_REGDICTIONARY returns correct value'); is (PG_REGDICTIONARYARRAY , 3770, 'PG_REGDICTIONARYARRAY returns correct value'); is (PG_REGOPER , 2203, 'PG_REGOPER returns correct value'); is (PG_REGOPERARRAY , 2208, 'PG_REGOPERARRAY returns correct value'); is (PG_REGOPERATOR , 2204, 'PG_REGOPERATOR returns correct value'); is (PG_REGOPERATORARRAY , 2209, 'PG_REGOPERATORARRAY returns correct value'); is (PG_REGPROC , 24, 'PG_REGPROC returns correct value'); is (PG_REGPROCARRAY , 1008, 'PG_REGPROCARRAY returns correct value'); is (PG_REGPROCEDURE , 2202, 'PG_REGPROCEDURE returns correct value'); is (PG_REGPROCEDUREARRAY , 2207, 'PG_REGPROCEDUREARRAY returns correct value'); is (PG_REGTYPE , 2206, 'PG_REGTYPE returns correct value'); is (PG_REGTYPEARRAY , 2211, 'PG_REGTYPEARRAY returns correct value'); is (PG_RELTIME , 703, 'PG_RELTIME returns correct value'); is (PG_RELTIMEARRAY , 1024, 'PG_RELTIMEARRAY returns correct value'); is (PG_SMGR , 210, 'PG_SMGR returns correct value'); is (PG_TEXT , 25, 'PG_TEXT returns correct value'); is (PG_TEXTARRAY , 1009, 'PG_TEXTARRAY returns correct value'); is (PG_TID , 27, 'PG_TID returns correct value'); is (PG_TIDARRAY , 1010, 'PG_TIDARRAY returns correct value'); is (PG_TIME , 1083, 'PG_TIME returns correct value'); is (PG_TIMEARRAY , 1183, 'PG_TIMEARRAY returns correct value'); is (PG_TIMESTAMP , 1114, 'PG_TIMESTAMP returns correct value'); is (PG_TIMESTAMPARRAY , 1115, 'PG_TIMESTAMPARRAY returns correct value'); is (PG_TIMESTAMPTZ , 1184, 'PG_TIMESTAMPTZ returns correct value'); is (PG_TIMESTAMPTZARRAY , 1185, 'PG_TIMESTAMPTZARRAY returns correct value'); is (PG_TIMETZ , 1266, 'PG_TIMETZ returns correct value'); is (PG_TIMETZARRAY , 1270, 'PG_TIMETZARRAY returns correct value'); is (PG_TINTERVAL , 704, 'PG_TINTERVAL returns correct value'); is (PG_TINTERVALARRAY , 1025, 'PG_TINTERVALARRAY returns correct value'); is (PG_TRIGGER , 2279, 'PG_TRIGGER returns correct value'); is (PG_TSQUERY , 3615, 'PG_TSQUERY returns correct value'); is (PG_TSQUERYARRAY , 3645, 'PG_TSQUERYARRAY returns correct value'); is (PG_TSVECTOR , 3614, 'PG_TSVECTOR returns correct value'); is (PG_TSVECTORARRAY , 3643, 'PG_TSVECTORARRAY returns correct value'); is (PG_TXID_SNAPSHOT , 2970, 'PG_TXID_SNAPSHOT returns correct value'); is (PG_TXID_SNAPSHOTARRAY , 2949, 'PG_TXID_SNAPSHOTARRAY returns correct value'); is (PG_UNKNOWN , 705, 'PG_UNKNOWN returns correct value'); is (PG_UUID , 2950, 'PG_UUID returns correct value'); is (PG_UUIDARRAY , 2951, 'PG_UUIDARRAY returns correct value'); is (PG_VARBIT , 1562, 'PG_VARBIT returns correct value'); is (PG_VARBITARRAY , 1563, 'PG_VARBITARRAY returns correct value'); is (PG_VARCHAR , 1043, 'PG_VARCHAR returns correct value'); is (PG_VARCHARARRAY , 1015, 'PG_VARCHARARRAY returns correct value'); is (PG_VOID , 2278, 'PG_VOID returns correct value'); is (PG_XID , 28, 'PG_XID returns correct value'); is (PG_XIDARRAY , 1011, 'PG_XIDARRAY returns correct value'); is (PG_XML , 142, 'PG_XML returns correct value'); is (PG_XMLARRAY , 143, 'PG_XMLARRAY returns correct value'); DBD-Pg-2.19.3/t/03dbmethod.t0000644000076400007640000016474011727012501013576 0ustar greggreg#!perl ## Test of the database handle methods ## The following methods are *not* (explicitly) tested here: ## "take_imp_data" "pg_server_trace" "pg_server_untrace" "pg_type_info" ## "data_sources" (see 04misc.t) ## "disconnect" (see 01connect.t) ## "pg_savepoint" "pg_release" "pg_rollback_to" (see 20savepoints.t) ## "pg_getline" "pg_endcopy" "pg_getcopydata" "pg_getcopydata_async" (see 07copy.t) ## "pg_putline" "pg_putcopydata" "pg_putcopydata_async (see 07copy.t) ## "pg_cancel" "pg_ready" "pg_result" (see 08async.t) use 5.006; use strict; use warnings; use Data::Dumper; use Test::More; use DBI ':sql_types'; use DBD::Pg ':pg_types'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 534; isnt ($dbh, undef, 'Connect to database for database handle method testing'); my ($pglibversion,$pgversion) = ($dbh->{pg_lib_version},$dbh->{pg_server_version}); my ($schema,$schema2) = ('dbd_pg_testschema', 'dbd_pg_testschema2'); my ($table1,$table2,$table3) = ('dbd_pg_test1','dbd_pg_test2','dbd_pg_test3'); my ($sequence2,$sequence3,$sequence4) = ('dbd_pg_testsequence2','dbd_pg_testsequence3','dbd_pg_testsequence4'); my ($SQL, $sth, $result, @result, $expected, $warning, $rows, $t, $info); # Quick simple "tests" $dbh->do(q{}); ## This used to break, so we keep it as a test... $SQL = q{SELECT '2529DF6AB8F79407E94445B4BC9B906714964AC8' FROM dbd_pg_test WHERE id=?}; $sth = $dbh->prepare($SQL); $sth->finish(); $sth = $dbh->prepare_cached($SQL); $sth->finish(); # Populate the testing table for later use $SQL = 'INSERT INTO dbd_pg_test(id,val) VALUES (?,?)'; $sth = $dbh->prepare($SQL); $sth->bind_param(1, 1, SQL_INTEGER); $sth->execute(10,'Roseapple'); $sth->execute(11,'Pineapple'); $sth->execute(12,'Kiwi'); # # Test of the "last_insert_id" database handle method # $t='DB handle method "last_insert_id" fails when no arguments are given'; $dbh->commit(); eval { $dbh->last_insert_id(undef,undef,undef,undef); }; like ($@, qr{last_insert_id.*least}, $t); $t='DB handle method "last_insert_id" fails when given a non-existent sequence'; eval { $dbh->last_insert_id(undef,undef,undef,undef,{sequence=>'dbd_pg_nonexistentsequence_test'}); }; is ($dbh->state, '42P01', $t); $t='DB handle method "last_insert_id" fails when given a non-existent table'; $dbh->rollback(); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef); }; like ($@, qr{not find}, $t); $t='DB handle method "last_insert_id" fails when given an arrayref as last argument'; $dbh->rollback(); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef,[]); }; like ($@, qr{last_insert_id.*hashref}, $t); $t='DB handle method "last_insert_id" works when given an empty sequence argument'; $dbh->rollback(); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef,{sequence=>''}); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" fails when given a table with no primary key'; $dbh->rollback(); $dbh->do('CREATE TEMP TABLE dbd_pg_test_temp(a int)'); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_test_temp',undef); }; like ($@, qr{last_insert_id}, $t); $t='DB handle method "do" returns correct count with CREATE AS SELECT'; $dbh->rollback(); $result = $dbh->do('CREATE TEMP TABLE foobar AS SELECT * FROM pg_class LIMIT 3'); $expected = $pgversion >= 90000 ? 3 : '0E0'; is ($result, $expected, $t); $t='DB handle method "do" works properly with passed-in array with undefined entries'; $dbh->rollback(); $dbh->do('CREATE TEMP TABLE foobar (id INT, p TEXT[])'); my @aa; $aa[2] = 'asasa'; eval { $dbh->do('INSERT INTO foobar (p) VALUES (?)', undef, \@aa); }; is ($@, q{}, $t); $SQL = 'SELECT * FROM foobar'; $result = $dbh->selectall_arrayref($SQL)->[0]; is_deeply ($result, [undef,[undef,undef,'asasa']], $t); $t='DB handle method "last_insert_id" works when given a valid sequence and an invalid table'; $dbh->rollback(); eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef,{sequence=>'dbd_pg_testsequence'}); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" returns a numeric value'; like ($result, qr{^\d+$}, $t); $t='DB handle method "last_insert_id" works when given a valid sequence and an invalid table'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef, 'dbd_pg_testsequence'); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" returns a numeric value'; like ($result, qr{^\d+$}, $t); $t='DB handle method "last_insert_id" works when given a valid table'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" works when given an empty attrib'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef,''); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" works when called twice (cached) given a valid table'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef); }; is ($@, q{}, $t); $dbh->do("CREATE SCHEMA $schema2"); $dbh->do("CREATE SEQUENCE $schema2.$sequence2"); $dbh->do("CREATE SEQUENCE $schema.$sequence4"); $dbh->{Warn} = 0; $dbh->do("CREATE TABLE $schema2.$table2(a INTEGER PRIMARY KEY NOT NULL DEFAULT nextval('$schema2.$sequence2'))"); $dbh->do("CREATE TABLE $schema.$table2(a INTEGER PRIMARY KEY NOT NULL DEFAULT nextval('$schema.$sequence4'))"); $dbh->{Warn} = 1; $dbh->do("INSERT INTO $schema2.$table2 DEFAULT VALUES"); $t='DB handle method "last_insert_id" works when called with a schema not in the search path'; eval { $result = $dbh->last_insert_id(undef,$schema2,$table2,undef); }; is ($@, q{}, $t); $t='search_path respected when using last_insert_id with no cache (first table)'; $dbh->commit(); $dbh->do("SELECT setval('$schema2.$sequence2',200)"); $dbh->do("SELECT setval('$schema.$sequence4',100)"); $dbh->do("SET search_path = $schema,$schema2"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef,{pg_cache=>0}); }; is ($@, q{}, $t); is ($result, 100, $t); $t='search_path respected when using last_insert_id with no cache (second table)'; $dbh->commit(); $dbh->do("SET search_path = $schema2,$schema"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef,{pg_cache=>0}); }; is ($@, q{}, $t); is ($result, 200, $t); $t='Setting cache on (explicit) returns last result, even if search_path changes'; $dbh->do("SET search_path = $schema,$schema2"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef,{pg_cache=>1}); }; is ($@, q{}, $t); is ($result, 200, $t); $t='Setting cache on (implicit) returns last result, even if search_path changes'; $dbh->do("SET search_path = $schema,$schema2"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef); }; is ($@, q{}, $t); is ($result, 200, $t); $dbh->commit(); SKIP: { $t='DB handle method "last_insert_id" fails when the sequence name is changed and cache is used'; if ($pgversion < 80300) { $dbh->do("DROP TABLE $schema2.$table2"); $dbh->do("DROP SEQUENCE $schema2.$sequence2"); skip ('Cannot test sequence rename on pre-8.3 servers', 2); } $dbh->do("ALTER SEQUENCE $schema2.$sequence2 RENAME TO $sequence3"); $dbh->commit(); eval { $dbh->last_insert_id(undef,$schema2,$table2,undef); }; like ($@, qr{last_insert_id}, $t); $dbh->rollback(); $t='DB handle method "last_insert_id" works when the sequence name is changed and cache is turned off'; $dbh->commit(); eval { $dbh->last_insert_id(undef,$schema2,$table2,undef, {pg_cache=>0}); }; is ($@, q{}, $t); $dbh->do("DROP TABLE $schema2.$table2"); $dbh->do("DROP SEQUENCE $schema2.$sequence3"); } $dbh->do("DROP SCHEMA $schema2"); $dbh->do("DROP TABLE $table2"); $dbh->do("DROP SEQUENCE $sequence4"); # # Test of the "selectrow_array" database handle method # $t='DB handle method "selectrow_array" works'; $SQL = 'SELECT id FROM dbd_pg_test ORDER BY id'; @result = $dbh->selectrow_array($SQL); $expected = [10]; is_deeply (\@result, $expected, $t); # # Test of the "selectrow_arrayref" database handle method # $t='DB handle method "selectrow_arrayref" works'; $result = $dbh->selectrow_arrayref($SQL); is_deeply ($result, $expected, $t); $t='DB handle method "selectrow_arrayref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectrow_arrayref($sth); is_deeply ($result, $expected, $t); # # Test of the "selectrow_hashref" database handle method # $t='DB handle method "selectrow_hashref" works'; $result = $dbh->selectrow_hashref($SQL); $expected = {id => 10}; is_deeply ($result, $expected, $t); $t='DB handle method "selectrow_hashref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectrow_hashref($sth); is_deeply ($result, $expected, $t); # # Test of the "selectall_arrayref" database handle method # $t='DB handle method "selectall_arrayref" works'; $result = $dbh->selectall_arrayref($SQL); $expected = [[10],[11],[12]]; is_deeply ($result, $expected, $t); $t='DB handle method "selectall_arrayref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectall_arrayref($sth); is_deeply ($result, $expected, $t); $t='DB handle method "selectall_arrayref" works with the MaxRows attribute'; $result = $dbh->selectall_arrayref($SQL, {MaxRows => 2}); $expected = [[10],[11]]; is_deeply ($result, $expected, $t); $t='DB handle method "selectall_arrayref" works with the Slice attribute'; $SQL = 'SELECT id, val FROM dbd_pg_test ORDER BY id'; $result = $dbh->selectall_arrayref($SQL, {Slice => [1]}); $expected = [['Roseapple'],['Pineapple'],['Kiwi']]; is_deeply ($result, $expected, $t); # # Test of the "selectall_hashref" database handle method # $t='DB handle method "selectall_hashref" works'; $result = $dbh->selectall_hashref($SQL,'id'); $expected = {10=>{id =>10,val=>'Roseapple'},11=>{id=>11,val=>'Pineapple'},12=>{id=>12,val=>'Kiwi'}}; is_deeply ($result, $expected, $t); $t='DB handle method "selectall_hashref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectall_hashref($sth,'id'); is_deeply ($result, $expected, $t); # # Test of the "selectcol_arrayref" database handle method # $t='DB handle method "selectcol_arrayref" works'; $result = $dbh->selectcol_arrayref($SQL); $expected = [10,11,12]; is_deeply ($result, $expected, $t); $t='DB handle method "selectcol_arrayref" works with a prepared statement handle'; $result = $dbh->selectcol_arrayref($sth); is_deeply ($result, $expected, $t); $t='DB handle method "selectcol_arrayref" works with the Columns attribute'; $result = $dbh->selectcol_arrayref($SQL, {Columns=>[2,1]}); $expected = ['Roseapple',10,'Pineapple',11,'Kiwi',12]; is_deeply ($result, $expected, $t); $t='DB handle method "selectcol_arrayref" works with the MaxRows attribute'; $result = $dbh->selectcol_arrayref($SQL, {Columns=>[2], MaxRows => 1}); $expected = ['Roseapple']; is_deeply ($result, $expected, $t); # # Test of the "commit" and "rollback" database handle methods # { local $SIG{__WARN__} = sub { $warning = shift; }; $dbh->{AutoCommit}=0; $t='DB handle method "commit" gives no warning when AutoCommit is off'; $warning=q{}; $dbh->commit(); ok (! length $warning, $t); $t='DB handle method "rollback" gives no warning when AutoCommit is off'; $warning=q{}; $dbh->rollback(); ok (! length $warning, $t); $t='DB handle method "commit" returns true'; ok ($dbh->commit, $t); $t='DB handle method "rollback" returns true'; ok ($dbh->rollback, $t); $t='DB handle method "commit" gives a warning when AutoCommit is on'; $dbh->{AutoCommit}=1; $warning=q{}; $dbh->commit(); ok (length $warning, $t); $t='DB handle method "rollback" gives a warning when AutoCommit is on'; $warning=q{}; $dbh->rollback(); ok (length $warning, $t); } # # Test of the "begin_work" database handle method # $t='DB handle method "begin_work" gives a warning when AutoCommit is on'; $dbh->{AutoCommit}=0; eval { $dbh->begin_work(); }; isnt ($@, q{}, $t); $t='DB handle method "begin_work" gives no warning when AutoCommit is off'; $dbh->{AutoCommit}=1; eval { $dbh->begin_work(); }; is ($@, q{}, $t); ok (!$dbh->{AutoCommit}, 'DB handle method "begin_work" sets AutoCommit to off'); $t='DB handle method "commit" after "begin_work" sets AutoCommit to on'; $dbh->commit(); ok ($dbh->{AutoCommit}, $t); $t='DB handle method "begin_work" gives no warning when AutoCommit is off'; $dbh->{AutoCommit}=1; eval { $dbh->begin_work(); }; is ($@, q{}, $t); $t='DB handle method "begin_work" sets AutoCommit to off'; ok (!$dbh->{AutoCommit}, $t); $t='DB handle method "rollback" after "begin_work" sets AutoCommit to on'; $dbh->rollback(); ok ($dbh->{AutoCommit}, $t); $dbh->{AutoCommit}=0; # # Test of the "get_info" database handle method # $t='DB handle method "get_info" with no arguments gives an error'; eval { $dbh->get_info(); }; isnt ($@, q{}, $t); my %get_info = ( SQL_MAX_DRIVER_CONNECTIONS => 0, SQL_DRIVER_NAME => 6, SQL_DBMS_NAME => 17, SQL_DBMS_VERSION => 18, SQL_IDENTIFIER_QUOTE_CHAR => 29, SQL_CATALOG_NAME_SEPARATOR => 41, SQL_USER_NAME => 47, ); for (keys %get_info) { $t=qq{DB handle method "get_info" works with a value of "$_"}; my $back = $dbh->get_info($_); ok (defined $back, $t); $t=qq{DB handle method "get_info" works with a value of "$get_info{$_}"}; my $forth = $dbh->get_info($get_info{$_}); ok (defined $forth, $t); $t=q{DB handle method "get_info" returned matching values}; is ($back, $forth, $t); } # Make sure odbcversion looks normal $t='DB handle method "get_info" returns a valid looking ODBCVERSION string}'; my $odbcversion = $dbh->get_info(18); like ($odbcversion, qr{^([1-9]\d|\d[1-9])\.\d\d\.\d\d00$}, $t); # Testing max connections is good as this info is dynamic $t='DB handle method "get_info" returns a number for SQL_MAX_DRIVER_CONNECTIONS'; my $maxcon = $dbh->get_info(0); like ($maxcon, qr{^\d+$}, $t); $t='DB handle method "get_info" returns correct string for SQL_DATA_SOURCE_READ_ONLY when "on"'; $dbh->do(q{SET transaction_read_only = 'on'}); is ($dbh->get_info(25), 'Y', $t); $t='DB handle method "get_info" returns correct string for SQL_DATA_SOURCE_READ_ONLY when "off"'; ## Recent versions of Postgres are very fussy: must rollback $dbh->rollback(); $dbh->do(q{SET transaction_read_only = 'off'}); is ($dbh->get_info(25), 'N', $t); # # Test of the "table_info" database handle method # $t='DB handle method "table_info" works when called with undef arguments'; $sth = $dbh->table_info('', '', 'dbd_pg_test', ''); my $number = $sth->rows(); ok ($number, $t); # Check required minimum fields $t='DB handle method "table_info" returns fields required by DBI'; $result = $sth->fetchall_arrayref({}); my @required = (qw(TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS)); my %missing; for my $r (@$result) { for (@required) { $missing{$_}++ if ! exists $r->{$_}; } } is_deeply (\%missing, {}, $t); ## Check some of the returned fields: $result = $result->[0]; is ($result->{TABLE_CAT}, undef, 'DB handle method "table_info" returns proper TABLE_CAT'); is ($result->{TABLE_NAME}, 'dbd_pg_test', 'DB handle method "table_info" returns proper TABLE_NAME'); is ($result->{TABLE_TYPE}, 'TABLE', 'DB handle method "table_info" returns proper TABLE_TYPE'); $t=q{DB handle method "table_info" returns correct number of rows when given a 'TABLE,VIEW' type argument}; $sth = $dbh->table_info(undef,undef,undef,'TABLE,VIEW'); $number = $sth->rows(); cmp_ok ($number, '>', 1, $t); $t='DB handle method "table_info" returns correct number of rows when given an invalid type argument'; $sth = $dbh->table_info(undef,undef,undef,'DUMMY'); $rows = $sth->rows(); is ($rows, $number, $t); $t=q{DB handle method "table_info" returns correct number of rows when given a 'VIEW' type argument}; $sth = $dbh->table_info(undef,undef,undef,'VIEW'); $rows = $sth->rows(); cmp_ok ($rows, '<', $number, $t); $t=q{DB handle method "table_info" returns correct number of rows when given a 'TABLE' type argument}; $sth = $dbh->table_info(undef,undef,undef,'TABLE'); $rows = $sth->rows(); cmp_ok ($rows, '<', $number, $t); # Test listing catalog names $t='DB handle method "table_info" works when called with a catalog of %'; $sth = $dbh->table_info('%', '', ''); ok ($sth, $t); # Test listing schema names $t='DB handle method "table_info" works when called with a schema of %'; $sth = $dbh->table_info('', '%', ''); ok ($sth, $t); # Test listing table types $t='DB handle method "table_info" works when called with a type of %'; $sth = $dbh->table_info('', '', '', '%'); ok ($sth, $t); # # Test of the "column_info" database handle method # # Check required minimum fields $t='DB handle method "column_info" returns fields required by DBI'; $sth = $dbh->column_info('','','dbd_pg_test','score'); $result = $sth->fetchall_arrayref({}); @required = (qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE REMARKS COLUMN_DEF SQL_DATA_TYPE SQL_DATETIME_SUB CHAR_OCTET_LENGTH ORDINAL_POSITION IS_NULLABLE)); undef %missing; for my $r (@$result) { for (@required) { $missing{$_}++ if ! exists $r->{$_}; } } is_deeply (\%missing, {}, $t); # Check that pg_constraint was populated $t=q{DB handle method "column info" 'pg_constraint' returns a value for constrained columns}; $result = $result->[0]; like ($result->{pg_constraint}, qr/score/, $t); # Check that it is not populated for non-constrained columns $t=q{DB handle method "column info" 'pg_constraint' returns undef for non-constrained columns}; $sth = $dbh->column_info('','','dbd_pg_test','id'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{pg_constraint}, undef, $t); # Check the rest of the custom "pg" columns $t=q{DB handle method "column_info" returns good value for 'pg_type'}; is ($result->{pg_type}, 'integer', $t); ## Check some of the returned fields: my $r = $result; is ($r->{TABLE_CAT}, undef, 'DB handle method "column_info" returns proper TABLE_CAT'); is ($r->{TABLE_NAME}, 'dbd_pg_test', 'DB handle method "column_info returns proper TABLE_NAME'); is ($r->{COLUMN_NAME}, 'id', 'DB handle method "column_info" returns proper COLUMN_NAME'); is ($r->{DATA_TYPE}, 4, 'DB handle method "column_info" returns proper DATA_TYPE'); is ($r->{COLUMN_SIZE}, 4, 'DB handle method "column_info" returns proper COLUMN_SIZE'); is ($r->{NULLABLE}, '0', 'DB handle method "column_info" returns proper NULLABLE'); is ($r->{REMARKS}, 'Bob is your uncle', 'DB handle method "column_info" returns proper REMARKS'); is ($r->{COLUMN_DEF}, undef, 'DB handle method "column_info" returns proper COLUMN_DEF'); is ($r->{IS_NULLABLE}, 'NO', 'DB handle method "column_info" returns proper IS_NULLABLE'); is ($r->{pg_type}, 'integer', 'DB handle method "column_info" returns proper pg_type'); is ($r->{ORDINAL_POSITION}, 1, 'DB handle method "column_info" returns proper ORDINAL_POSITION'); # Make sure we handle CamelCase Column Correctly $t=q{DB handle method "column_info" works with non-lowercased columns}; $sth = $dbh->column_info('','','dbd_pg_test','CaseTest'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{COLUMN_NAME}, q{"CaseTest"}, $t); SKIP: { if ($pgversion < 80300) { skip ('DB handle method column_info attribute "pg_enum_values" requires at least Postgres 8.3', 2); } { local $dbh->{Warn} = 0; $dbh->do( q{CREATE TYPE dbd_pg_enumerated AS ENUM ('foo', 'bar', 'baz', 'buz')} ); $dbh->do( q{CREATE TEMP TABLE dbd_pg_enum_test ( is_enum dbd_pg_enumerated NOT NULL )} ); } $t='DB handle method "column_info" returns proper pg_type'; $sth = $dbh->column_info('','','dbd_pg_enum_test','is_enum'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{pg_type}, 'dbd_pg_enumerated', $t); $t='DB handle method "column_info" returns proper pg_enum_values'; is_deeply ($result->{pg_enum_values}, [ qw( foo bar baz buz ) ], $t); $dbh->do('DROP TABLE dbd_pg_enum_test'); $dbh->do('DROP TYPE dbd_pg_enumerated'); } # # Test of the "primary_key_info" database handle method # # Check required minimum fields $t='DB handle method "primary_key_info" returns required fields'; $sth = $dbh->primary_key_info('','','dbd_pg_test'); $result = $sth->fetchall_arrayref({}); @required = (qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME DATA_TYPE)); undef %missing; for my $r (@$result) { for (@required) { $missing{$_}++ if ! exists $r->{$_}; } } is_deeply (\%missing, {}, $t); ## Check some of the returned fields: $r = $result->[0]; is ($r->{TABLE_CAT}, undef, 'DB handle method "primary_key_info" returns proper TABLE_CAT'); is ($r->{TABLE_NAME}, 'dbd_pg_test', 'DB handle method "primary_key_info" returns proper TABLE_NAME'); is ($r->{COLUMN_NAME}, 'id', 'DB handle method "primary_key_info" returns proper COLUMN_NAME'); is ($r->{PK_NAME}, 'dbd_pg_test_pkey', 'DB handle method "primary_key_info" returns proper PK_NAME'); is ($r->{DATA_TYPE}, 'int4', 'DB handle method "primary_key_info" returns proper DATA_TYPE'); is ($r->{KEY_SEQ}, 1, 'DB handle method "primary_key_info" returns proper KEY_SEQ'); # # Test of the "primary_key" database handle method # $t='DB handle method "primary_key" works'; @result = $dbh->primary_key('', '', 'dbd_pg_test'); $expected = ['id']; is_deeply (\@result, $expected, $t); $t='DB handle method "primary_key" returns empty list for invalid table'; @result = $dbh->primary_key('', '', 'dbd_pg_test_do_not_create_this_table'); $expected = []; is_deeply (\@result, $expected, $t); # # Test of the "statistics_info" database handle method # SKIP: { $dbh->{private_dbdpg}{version} >= 80000 or skip ('Server must be version 8.0 or higher to test database handle method "statistics_info"', 10); $t='DB handle method "statistics_info" returns undef: no table'; $sth = $dbh->statistics_info(undef,undef,undef,undef,undef); is ($sth, undef, $t); ## Invalid table $t='DB handle method "statistics_info" returns undef: bad table'; $sth = $dbh->statistics_info(undef,undef,'dbd_pg_test9',undef,undef); is ($sth, undef, $t); ## Create some tables with various indexes { local $SIG{__WARN__} = sub {}; $dbh->do("CREATE TABLE $table1 (a INT, b INT NOT NULL, c INT NOT NULL, ". 'CONSTRAINT dbd_pg_test1_pk PRIMARY KEY (a))'); $dbh->do("ALTER TABLE $table1 ADD CONSTRAINT dbd_pg_test1_uc1 UNIQUE (b)"); $dbh->do("CREATE UNIQUE INDEX dbd_pg_test1_index_c ON $table1(c)"); $dbh->do("CREATE TABLE $table2 (a INT, b INT, c INT, PRIMARY KEY(a,b), UNIQUE(b,c))"); $dbh->do("CREATE INDEX dbd_pg_test2_skipme ON $table2(c,(a+b))"); $dbh->do("CREATE TABLE $table3 (a INT, b INT, c INT, PRIMARY KEY(a)) WITH OIDS"); $dbh->do("CREATE UNIQUE INDEX dbd_pg_test3_index_b ON $table3(b)"); $dbh->do("CREATE INDEX dbd_pg_test3_index_c ON $table3 USING hash(c)"); $dbh->do("CREATE INDEX dbd_pg_test3_oid ON $table3(oid)"); $dbh->do("CREATE UNIQUE INDEX dbd_pg_test3_pred ON $table3(c) WHERE c > 0 AND c < 45"); $dbh->commit(); } my $correct_stats = { one => [ [ undef, $schema, $table1, undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef ], [ undef, $schema, $table1, '0', undef, 'dbd_pg_test1_index_c', 'btree', 1, 'c', 'A', '0', '1', undef ], [ undef, $schema, $table1, '0', undef, 'dbd_pg_test1_pk', 'btree', 1, 'a', 'A', '0', '1', undef ], [ undef, $schema, $table1, '0', undef, 'dbd_pg_test1_uc1', 'btree', 1, 'b', 'A', '0', '1', undef ], ], two => [ [ undef, $schema, $table2, undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef ], [ undef, $schema, $table2, '0', undef, 'dbd_pg_test2_b_key', 'btree', 1, 'b', 'A', '0', '1', undef ], [ undef, $schema, $table2, '0', undef, 'dbd_pg_test2_b_key', 'btree', 2, 'c', 'A', '0', '1', undef ], [ undef, $schema, $table2, '0', undef, 'dbd_pg_test2_pkey', 'btree', 1, 'a', 'A', '0', '1', undef ], [ undef, $schema, $table2, '0', undef, 'dbd_pg_test2_pkey', 'btree', 2, 'b', 'A', '0', '1', undef ], ], three => [ [ undef, $schema, $table3, undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef ], [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_index_b', 'btree', 1, 'b', 'A', '0', '1', undef ], [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_pkey', 'btree', 1, 'a', 'A', '0', '1', undef ], [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_pred', 'btree', 1, 'c', 'A', '0', '1', '((c > 0) AND (c < 45))' ], [ undef, $schema, $table3, '1', undef, 'dbd_pg_test3_oid', 'btree', 1, 'oid', 'A', '0', '1', undef ], [ undef, $schema, $table3, '1', undef, 'dbd_pg_test3_index_c', 'hashed', 1, 'c', 'A', '0', '4', undef ], ], three_uo => [ [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_index_b', 'btree', 1, 'b', 'A', '0', '1', undef ], [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_pkey', 'btree', 1, 'a', 'A', '0', '1', undef ], [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_pred', 'btree', 1, 'c', 'A', '0', '1', '((c > 0) AND (c < 45))' ], ], }; ## Make some per-version tweaks ## 8.5 changed the way foreign key names are generated if ($pgversion >= 80500) { $correct_stats->{two}[1][5] = $correct_stats->{two}[2][5] = 'dbd_pg_test2_b_c_key'; } my $stats; $t="Correct stats output for $table1"; $sth = $dbh->statistics_info(undef,$schema,$table1,undef,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{one}, $t); $t="Correct stats output for $table2"; $sth = $dbh->statistics_info(undef,$schema,$table2,undef,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{two}, $t); $t="Correct stats output for $table3"; $sth = $dbh->statistics_info(undef,$schema,$table3,undef,undef); $stats = $sth->fetchall_arrayref; ## Too many intra-version differences to try for an exact number here: $correct_stats->{three}[5][11] = $stats->[5][11] = 0; is_deeply ($stats, $correct_stats->{three}, $t); $t="Correct stats output for $table3 (unique only)"; $sth = $dbh->statistics_info(undef,$schema,$table3,1,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{three_uo}, $t); { $t="Correct stats output for $table1"; $sth = $dbh->statistics_info(undef,undef,$table1,undef,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{one}, $t); $t="Correct stats output for $table3"; $sth = $dbh->statistics_info(undef,undef,$table2,undef,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{two}, $t); $t="Correct stats output for $table3"; $sth = $dbh->statistics_info(undef,undef,$table3,undef,undef); $stats = $sth->fetchall_arrayref; $correct_stats->{three}[5][11] = $stats->[5][11] = 0; is_deeply ($stats, $correct_stats->{three}, $t); $t="Correct stats output for $table3 (unique only)"; $sth = $dbh->statistics_info(undef,undef,$table3,1,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{three_uo}, $t); } # Clean everything up $dbh->do("DROP TABLE $table3"); $dbh->do("DROP TABLE $table2"); $dbh->do("DROP TABLE $table1"); } ## end of statistics_info tests # # Test of the "foreign_key_info" database handle method # ## Neither pktable nor fktable specified $t='DB handle method "foreign_key_info" returns undef: no pk / no fk'; $sth = $dbh->foreign_key_info(undef,undef,undef,undef,undef,undef); is ($sth, undef, $t); # Drop any tables that may exist my $fktables = join ',' => map { "'dbd_pg_test$_'" } (1..3); $SQL = "SELECT relname FROM pg_catalog.pg_class WHERE relkind='r' AND relname IN ($fktables)"; { local $SIG{__WARN__} = sub {}; for (@{$dbh->selectall_arrayref($SQL)}) { $dbh->do("DROP TABLE $_->[0] CASCADE"); } } ## Invalid primary table $t='DB handle method "foreign_key_info" returns undef: bad pk / no fk'; $sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,undef); is ($sth, undef, $t); ## Invalid foreign table $t='DB handle method "foreign_key_info" returns undef: no pk / bad fk'; $sth = $dbh->foreign_key_info(undef,undef,undef,undef,undef,'dbd_pg_test9'); is ($sth, undef, $t); ## Both primary and foreign are invalid $t='DB handle method "foreign_key_info" returns undef: bad fk / bad fk'; $sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,'dbd_pg_test9'); is ($sth, undef, $t); ## Create a pk table { local $SIG{__WARN__} = sub {}; $dbh->do('CREATE TABLE dbd_pg_test1 (a INT, b INT NOT NULL, c INT NOT NULL, '. 'CONSTRAINT dbd_pg_test1_pk PRIMARY KEY (a))'); $dbh->do('ALTER TABLE dbd_pg_test1 ADD CONSTRAINT dbd_pg_test1_uc1 UNIQUE (b)'); $dbh->do('CREATE UNIQUE INDEX dbd_pg_test1_index_c ON dbd_pg_test1(c)'); $dbh->commit(); } ## Good primary with no foreign keys $t='DB handle method "foreign_key_info" returns undef: good pk (but unreferenced)'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); is ($sth, undef, $t); ## Create a simple foreign key table { local $SIG{__WARN__} = sub {}; $dbh->do('CREATE TABLE dbd_pg_test2 (f1 INT PRIMARY KEY, f2 INT NOT NULL, f3 INT NOT NULL)'); $dbh->do('ALTER TABLE dbd_pg_test2 ADD CONSTRAINT dbd_pg_test2_fk1 FOREIGN KEY(f2) REFERENCES dbd_pg_test1(a)'); $dbh->commit(); } ## Bad primary with good foreign $t='DB handle method "foreign_key_info" returns undef: bad pk / good fk'; $sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,$table2); is ($sth, undef, $t); ## Good primary, good foreign, bad schemas $t='DB handle method "foreign_key_info" returns undef: good pk / good fk / bad pk schema'; my $testschema = 'dbd_pg_test_badschema11'; $sth = $dbh->foreign_key_info(undef,$testschema,$table1,undef,undef,$table2); is ($sth, undef, $t); $t='DB handle method "foreign_key_info" returns undef: good pk / good fk / bad fk schema'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,$testschema,$table2); is ($sth, undef, $t); ## Good primary $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); $result = $sth->fetchall_arrayref({}); # Check required minimum fields $t='DB handle method "foreign_key_info" returns fields required by DBI'; $result = $sth->fetchall_arrayref({}); @required = (qw(UK_TABLE_CAT UK_TABLE_SCHEM UK_TABLE_NAME PK_COLUMN_NAME FK_TABLE_CAT FK_TABLE_SCHEM FK_TABLE_NAME FK_COLUMN_NAME ORDINAL_POSITION UPDATE_RULE DELETE_RULE FK_NAME UK_NAME DEFERABILITY UNIQUE_OR_PRIMARY UK_DATA_TYPE FK_DATA_TYPE)); undef %missing; for my $r (@$result) { for (@required) { $missing{$_}++ if ! exists $r->{$_}; } } is_deeply (\%missing, {}, $t); ## Good primary $t='DB handle method "foreign_key_info" works for good pk'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); $result = $sth->fetchall_arrayref(); my $fk1 = [ undef, ## Catalog $schema, ## Schema $table1, ## Table 'a', ## Column undef, ## FK Catalog $schema, ## FK Schema $table2, ## FK Table 'f2', ## FK Table 2, ## Ordinal position 3, ## Update rule 3, ## Delete rule 'dbd_pg_test2_fk1', ## FK name 'dbd_pg_test1_pk', ## UK name '7', ## deferability 'PRIMARY', ## unique or primary 'int4', ## uk data type 'int4' ## fk data type ]; $expected = [$fk1]; is_deeply ($result, $expected, $t); ## Same with explicit table $t='DB handle method "foreign_key_info" works for good pk / good fk'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $result = $sth->fetchall_arrayref(); is_deeply ($result, $expected, $t); ## Foreign table only $t='DB handle method "foreign_key_info" works for good fk'; $sth = $dbh->foreign_key_info(undef,undef,undef,undef,undef,$table2); $result = $sth->fetchall_arrayref(); is_deeply ($result, $expected, $t); ## Add a foreign key to an explicit unique constraint $t='DB handle method "foreign_key_info" works for good pk / explicit fk'; { local $SIG{__WARN__} = sub {}; $dbh->do('ALTER TABLE dbd_pg_test2 ADD CONSTRAINT dbd_pg_test2_fk2 FOREIGN KEY (f3) '. 'REFERENCES dbd_pg_test1(b) ON DELETE SET NULL ON UPDATE CASCADE'); } $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); $result = $sth->fetchall_arrayref(); my $fk2 = [ undef, $schema, $table1, 'b', undef, $schema, $table2, 'f3', '3', '0', ## cascade '2', ## set null 'dbd_pg_test2_fk2', 'dbd_pg_test1_uc1', '7', 'UNIQUE', 'int4', 'int4' ]; $expected = [$fk1,$fk2]; is_deeply ($result, $expected, $t); ## Add a foreign key to an implicit unique constraint (a unique index on a column) $t='DB handle method "foreign_key_info" works for good pk / implicit fk'; { local $SIG{__WARN__} = sub {}; $dbh->do('ALTER TABLE dbd_pg_test2 ADD CONSTRAINT dbd_pg_test2_aafk3 FOREIGN KEY (f3) '. 'REFERENCES dbd_pg_test1(c) ON DELETE RESTRICT ON UPDATE SET DEFAULT'); } $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); $result = $sth->fetchall_arrayref(); my $fk3 = [ undef, $schema, $table1, 'c', undef, $schema, $table2, 'f3', '3', '4', ## set default '1', ## restrict 'dbd_pg_test2_aafk3', undef, ## plain indexes have no named constraint '7', 'UNIQUE', 'int4', 'int4' ]; $expected = [$fk3,$fk1,$fk2]; is_deeply ($result, $expected, $t); ## Create another foreign key table to point to the first (primary) table $t='DB handle method "foreign_key_info" works for multiple fks'; { local $SIG{__WARN__} = sub {}; $dbh->do('CREATE TABLE dbd_pg_test3 (ff1 INT NOT NULL)'); $dbh->do('ALTER TABLE dbd_pg_test3 ADD CONSTRAINT dbd_pg_test3_fk1 FOREIGN KEY(ff1) REFERENCES dbd_pg_test1(a)'); $dbh->commit(); } $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); $result = $sth->fetchall_arrayref(); my $fk4 = [ undef, $schema, $table1, 'a', undef, $schema, $table3, 'ff1', '1', '3', '3', 'dbd_pg_test3_fk1', 'dbd_pg_test1_pk', '7', 'PRIMARY', 'int4', 'int4' ]; $expected = [$fk3,$fk1,$fk2,$fk4]; is_deeply ($result, $expected, $t); ## Test that explicit naming two tables brings back only those tables $t='DB handle method "foreign_key_info" works for good pk / good fk (only)'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table3); $result = $sth->fetchall_arrayref(); $expected = [$fk4]; is_deeply ($result, $expected, $t); ## Multi-column madness $t='DB handle method "foreign_key_info" works for multi-column keys'; { local $SIG{__WARN__} = sub {}; $dbh->do('ALTER TABLE dbd_pg_test1 ADD CONSTRAINT dbd_pg_test1_uc2 UNIQUE (b,c,a)'); $dbh->do('ALTER TABLE dbd_pg_test2 ADD CONSTRAINT dbd_pg_test2_fk4 ' . 'FOREIGN KEY (f1,f3,f2) REFERENCES dbd_pg_test1(c,a,b)'); } $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $result = $sth->fetchall_arrayref(); ## "dbd_pg_test2_fk4" FOREIGN KEY (f1, f3, f2) REFERENCES dbd_pg_test1(c, a, b) my $fk5 = [ undef, $schema, $table1, 'c', undef, $schema, $table2, 'f1', '1', '3', '3', 'dbd_pg_test2_fk4', 'dbd_pg_test1_uc2', '7', 'UNIQUE', 'int4', 'int4' ]; # For the rest of the multi-column, only change: # primary column name [3] # foreign column name [7] # ordinal position [8] my @fk6 = @$fk5; my $fk6 = \@fk6; $fk6->[3] = 'a'; $fk6->[7] = 'f3'; $fk6->[8] = 3; my @fk7 = @$fk5; my $fk7 = \@fk7; $fk7->[3] = 'b'; $fk7->[7] = 'f2'; $fk7->[8] = 2; $expected = [$fk3,$fk1,$fk2,$fk5,$fk6,$fk7]; is_deeply ($result, $expected, $t); $t='DB handle method "foreign_key_info" works with FetchHashKeyName NAME_lc'; $dbh->{FetchHashKeyName} = 'NAME_lc'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $sth->execute(); $result = $sth->fetchrow_hashref(); $sth->finish(); ok (exists $result->{'fk_table_name'}, $t); $t='DB handle method "foreign_key_info" works with FetchHashKeyName NAME_uc'; $dbh->{FetchHashKeyName} = 'NAME_uc'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $sth->execute(); $result = $sth->fetchrow_hashref(); ok (exists $result->{'FK_TABLE_NAME'}, $t); $t='DB handle method "foreign_key_info" works with FetchHashKeyName NAME'; $dbh->{FetchHashKeyName} = 'NAME'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $sth->execute(); $result = $sth->fetchrow_hashref(); ok (exists $result->{'FK_TABLE_NAME'}, $t); # Clean everything up { $dbh->do('DROP TABLE dbd_pg_test3'); $dbh->do('DROP TABLE dbd_pg_test2'); $dbh->do('DROP TABLE dbd_pg_test1'); } # # Test of the "tables" database handle method # $t='DB handle method "tables" works'; @result = $dbh->tables('', '', 'dbd_pg_test', ''); like ($result[0], qr/dbd_pg_test/, $t); $t='DB handle method "tables" works with a "pg_noprefix" attribute'; @result = $dbh->tables('', '', 'dbd_pg_test', '', {pg_noprefix => 1}); is ($result[0], 'dbd_pg_test', $t); # # Test of the "type_info_all" database handle method # $result = $dbh->type_info_all(); # Quick check that the structure looks correct $t='DB handle method "type_info_all" returns a valid structure'; my $badresult=q{}; if (ref $result eq 'ARRAY') { my $index = $result->[0]; if (ref $index ne 'HASH') { $badresult = 'First element in array not a hash ref'; } else { for (qw(TYPE_NAME DATA_TYPE CASE_SENSITIVE)) { $badresult = "Field $_ missing" if !exists $index->{$_}; } } } else { $badresult = 'Array reference not returned'; } diag "type_info_all problem: $badresult" if $badresult; ok (!$badresult, $t); # # Test of the "type_info" database handle method # # Check required minimum fields $t='DB handle method "type_info" returns fields required by DBI'; $result = $dbh->type_info(4); @required = (qw(TYPE_NAME DATA_TYPE COLUMN_SIZE LITERAL_PREFIX LITERAL_SUFFIX CREATE_PARAMS NULLABLE CASE_SENSITIVE SEARCHABLE UNSIGNED_ATTRIBUTE FIXED_PREC_SCALE AUTO_UNIQUE_VALUE LOCAL_TYPE_NAME MINIMUM_SCALE MAXIMUM_SCALE SQL_DATA_TYPE SQL_DATETIME_SUB NUM_PREC_RADIX INTERVAL_PRECISION)); undef %missing; for (@required) { $missing{$_}++ if ! exists $result->{$_}; } is_deeply (\%missing, {}, $t); # # Test of the "quote" database handle method # my %quotetests = ( q{0} => q{'0'}, q{Ain't misbehaving } => q{'Ain''t misbehaving '}, NULL => q{'NULL'}, "" => q{''}, ## no critic ); for (keys %quotetests) { $t=qq{DB handle method "quote" works with a value of "$_"}; $result = $dbh->quote($_); is ($result, $quotetests{$_}, $t); } ## Test timestamp - should quote as a string $t='DB handle method "quote" work on timestamp'; my $tstype = 93; my $testtime = '2006-01-28 11:12:13'; is ($dbh->quote( $testtime, $tstype ), qq{'$testtime'}, $t); $t='DB handle method "quote" works with an undefined value'; my $foo; { no warnings;## Perl does not like undef args is ($dbh->quote($foo), q{NULL}, $t); } $t='DB handle method "quote" works with a supplied data type argument'; is ($dbh->quote(1, 4), 1, $t); ## Test bytea quoting my $scs = $dbh->{pg_standard_conforming_strings}; for my $byteval (1 .. 255) { my $byte = chr($byteval); $result = $dbh->quote($byte, { pg_type => PG_BYTEA }); if ($byteval < 32 or $byteval >= 127) { $expected = $scs ? sprintf q{E'\\\\%03o'}, $byteval : sprintf q{'\\\\%03o'}, $byteval; } else { $expected = $scs ? sprintf q{E'%s'}, $byte : sprintf q{'%s'}, $byte; } if ($byte eq '\\') { $expected =~ s{\\}{\\\\\\\\}; } elsif ($byte eq q{'}) { $expected = $scs ? q{E''''} : q{''''}; } $t = qq{Byte value $byteval quotes to $expected}; is ($result, $expected, $t); } ## Various backslash tests $t='DB handle method "quote" works properly with backslashes'; my $E = $pgversion >= 80100 ? q{E} : q{}; is ($dbh->quote('foo\\bar'), qq{${E}'foo\\\\bar'}, $t); $t='DB handle method "quote" works properly without backslashes'; is ($dbh->quote('foobar'), q{'foobar'}, $t); # # Test various quote types # ## Points $t='DB handle method "quote" works with type PG_POINT'; eval { $result = $dbh->quote(q{123,456}, { pg_type => PG_POINT }); }; is ($@, q{}, $t); $t='DB handle method "quote" returns correct value for type PG_POINT'; is ($result, q{'123,456'}, $t); $t='DB handle method "quote" fails with invalid PG_POINT string'; eval { $result = $dbh->quote(q{[123,456]}, { pg_type => PG_POINT }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_POINT string'; eval { $result = $dbh->quote(q{A123,456}, { pg_type => PG_POINT }); }; like ($@, qr{Invalid input for geometric type}, $t); ## Lines and line segments $t='DB handle method "quote" works with valid PG_LINE string'; eval { $result = $dbh->quote(q{123,456}, { pg_type => PG_LINE }); }; is ($@, q{}, $t); $t='DB handle method "quote" fails with invalid PG_LINE string'; eval { $result = $dbh->quote(q{[123,456]}, { pg_type => PG_LINE }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_LINE string'; eval { $result = $dbh->quote(q{<123,456}, { pg_type => PG_LINE }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_LSEG string'; eval { $result = $dbh->quote(q{[123,456]}, { pg_type => PG_LSEG }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_LSEG string'; eval { $result = $dbh->quote(q{[123,456}, { pg_type => PG_LSEG }); }; like ($@, qr{Invalid input for geometric type}, $t); ## Boxes $t='DB handle method "quote" works with valid PG_BOX string'; eval { $result = $dbh->quote(q{1,2,3,4}, { pg_type => PG_BOX }); }; is ($@, q{}, $t); $t='DB handle method "quote" fails with invalid PG_BOX string'; eval { $result = $dbh->quote(q{[1,2,3,4]}, { pg_type => PG_BOX }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_BOX string'; eval { $result = $dbh->quote(q{1,2,3,4,cheese}, { pg_type => PG_BOX }); }; like ($@, qr{Invalid input for geometric type}, $t); ## Paths - can have optional square brackets $t='DB handle method "quote" works with valid PG_PATH string'; eval { $result = $dbh->quote(q{[(1,2),(3,4)]}, { pg_type => PG_PATH }); }; is ($@, q{}, $t); $t='DB handle method "quote" returns correct value for type PG_PATH'; is ($result, q{'[(1,2),(3,4)]'}, $t); $t='DB handle method "quote" fails with invalid PG_PATH string'; eval { $result = $dbh->quote(q{<(1,2),(3,4)>}, { pg_type => PG_PATH }); }; like ($@, qr{Invalid input for path type}, $t); $t='DB handle method "quote" fails with invalid PG_PATH string'; eval { $result = $dbh->quote(q{<1,2,3,4>}, { pg_type => PG_PATH }); }; like ($@, qr{Invalid input for path type}, $t); ## Polygons $t='DB handle method "quote" works with valid PG_POLYGON string'; eval { $result = $dbh->quote(q{1,2,3,4}, { pg_type => PG_POLYGON }); }; is ($@, q{}, $t); $t='DB handle method "quote" fails with invalid PG_POLYGON string'; eval { $result = $dbh->quote(q{[1,2,3,4]}, { pg_type => PG_POLYGON }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_POLYGON string'; eval { $result = $dbh->quote(q{1,2,3,4,cheese}, { pg_type => PG_POLYGON }); }; like ($@, qr{Invalid input for geometric type}, $t); ## Circles - can have optional angle brackets $t='DB handle method "quote" works with valid PG_CIRCLE string'; eval { $result = $dbh->quote(q{<(1,2,3)>}, { pg_type => PG_CIRCLE }); }; is ($@, q{}, $t); $t='DB handle method "quote" returns correct value for type PG_CIRCLE'; is ($result, q{'<(1,2,3)>'}, $t); $t='DB handle method "quote" fails with invalid PG_CIRCLE string'; eval { $result = $dbh->quote(q{[(1,2,3)]}, { pg_type => PG_CIRCLE }); }; like ($@, qr{Invalid input for circle type}, $t); $t='DB handle method "quote" fails with invalid PG_CIRCLE string'; eval { $result = $dbh->quote(q{1,2,3,4,H}, { pg_type => PG_CIRCLE }); }; like ($@, qr{Invalid input for circle type}, $t); # # Test of the "quote_identifier" database handle method # %quotetests = ( q{0} => q{"0"}, q{Ain't misbehaving } => q{"Ain't misbehaving "}, NULL => q{"NULL"}, "" => q{""}, ## no critic ); for (keys %quotetests) { $t=qq{DB handle method "quote_identifier" works with a value of "$_"}; $result = $dbh->quote_identifier($_); is ($result, $quotetests{$_}, $t); } $t='DB handle method "quote_identifier" works with an undefined value'; is ($dbh->quote_identifier(undef), q{}, $t); $t='DB handle method "quote_identifier" works with schemas'; is ($dbh->quote_identifier( undef, 'Her schema', 'My table' ), q{"Her schema"."My table"}, $t); # # Test of the "table_attributes" database handle method (deprecated) # # Because this function is deprecated and really just calling the column_info() # and primary_key() methods, we will do minimal testing. $t='DB handle method "table_attributes" returns the expected fields'; $result = $dbh->func('dbd_pg_test', 'table_attributes'); $result = $result->[0]; @required = (qw(NAME TYPE SIZE NULLABLE DEFAULT CONSTRAINT PRIMARY_KEY REMARKS)); undef %missing; for (@required) { $missing{$_}++ if ! exists $result->{$_}; } is_deeply (\%missing, {}, $t); # # Test of the "pg_lo_*" database handle methods # $t='DB handle method "pg_lo_creat" returns a valid descriptor for reading'; $dbh->{AutoCommit}=1; $dbh->{AutoCommit}=0; ## Catch error where not in begin my ($R,$W) = ($dbh->{pg_INV_READ}, $dbh->{pg_INV_WRITE}); my $RW = $R|$W; my $object; $t='DB handle method "pg_lo_creat" works with old-school dbh->func() method'; $object = $dbh->func($W, 'pg_lo_creat'); like ($object, qr/^\d+$/o, $t); isnt ($object, 0, $t); $t='DB handle method "pg_lo_creat" works with deprecated dbh->func(...lo_creat) method'; $object = $dbh->func($W, 'lo_creat'); like ($object, qr/^\d+$/o, $t); isnt ($object, 0, $t); $t='DB handle method "pg_lo_creat" returns a valid descriptor for writing'; $object = $dbh->pg_lo_creat($W); like ($object, qr/^\d+$/o, $t); isnt ($object, 0, $t); $t='DB handle method "pg_lo_open" returns a valid descriptor for writing'; my $handle = $dbh->pg_lo_open($object, $W); like ($handle, qr/^\d+$/o, $t); isnt ($object, -1, $t); $t='DB handle method "pg_lo_lseek" works when writing'; $result = $dbh->pg_lo_lseek($handle, 0, 0); is ($result, 0, $t); isnt ($object, -1, $t); $t='DB handle method "pg_lo_write" works'; my $buf = 'tangelo mulberry passionfruit raspberry plantain' x 500; $result = $dbh->pg_lo_write($handle, $buf, length($buf)); is ($result, length($buf), $t); cmp_ok ($object, '>', 0, $t); $t='DB handle method "pg_lo_close" works after write'; $result = $dbh->pg_lo_close($handle); ok ($result, $t); # Reopen for reading $t='DB handle method "pg_lo_open" returns a valid descriptor for reading'; $handle = $dbh->pg_lo_open($object, $R); like ($handle, qr/^\d+$/o, $t); cmp_ok ($handle, 'eq', 0, $t); $t='DB handle method "pg_lo_lseek" works when reading'; $result = $dbh->pg_lo_lseek($handle, 11, 0); is ($result, 11, $t); $t='DB handle method "pg_lo_tell" works'; $result = $dbh->pg_lo_tell($handle); is ($result, 11, $t); $t='DB handle method "pg_lo_read" read back the same data that was written'; $dbh->pg_lo_lseek($handle, 0, 0); my ($buf2,$data) = ('',''); while ($dbh->pg_lo_read($handle, $data, 513)) { $buf2 .= $data; } is (length($buf), length($buf2), $t); $t='DB handle method "pg_lo_close" works after read'; $result = $dbh->pg_lo_close($handle); ok ($result, $t); $t='DB handle method "pg_lo_unlink" works'; $result = $dbh->pg_lo_unlink($object); is ($result, 1, $t); $t='DB handle method "pg_lo_unlink" fails when called second time'; $result = $dbh->pg_lo_unlink($object); ok (!$result, $t); $dbh->rollback(); SKIP: { eval { require File::Temp; }; $@ and skip ('Must have File::Temp to test pg_lo_import* and pg_lo_export', 8); $t='DB handle method "pg_lo_import" works'; my ($fh,$filename) = File::Temp::tmpnam(); print {$fh} "abc\ndef"; close $fh or warn 'Failed to close temporary file'; $handle = $dbh->pg_lo_import($filename); my $objid = $handle; ok ($handle, $t); $t='DB handle method "pg_lo_import" inserts correct data'; $SQL = "SELECT data FROM pg_largeobject where loid = $handle"; $info = $dbh->selectall_arrayref($SQL)->[0][0]; is_deeply ($info, "abc\ndef", $t); $dbh->commit(); SKIP: { if ($pglibversion < 80400) { skip ('Cannot test pg_lo_import_with_oid unless compiled against 8.4 or better server', 5); } if ($pgversion < 80100) { skip ('Cannot test pg_lo_import_with_oid against old versions of Postgres', 5); } $t='DB handle method "pg_lo_import_with_oid" works with high number'; my $highnumber = 345167; $dbh->pg_lo_unlink($highnumber); $dbh->commit(); my $thandle = $dbh->pg_lo_import_with_oid($filename, $highnumber); is ($thandle, $highnumber, $t); ok ($thandle, $t); $t='DB handle method "pg_lo_import_with_oid" inserts correct data'; $SQL = "SELECT data FROM pg_largeobject where loid = $thandle"; $info = $dbh->selectall_arrayref($SQL)->[0][0]; is_deeply ($info, "abc\ndef", $t); $t='DB handle method "pg_lo_import_with_oid" fails when given already used number'; eval { $thandle = $dbh->pg_lo_import_with_oid($filename, $objid); }; is ($thandle, undef, $t); $dbh->rollback(); $t='DB handle method "pg_lo_import_with_oid" falls back to lo_import when number is 0'; eval { $thandle = $dbh->pg_lo_import_with_oid($filename, 0); }; ok ($thandle, $t); } unlink $filename; $t='DB handle method "pg_lo_open" works after "pg_lo_insert"'; $handle = $dbh->pg_lo_open($handle, $R); like ($handle, qr/^\d+$/o, $t); $t='DB handle method "pg_lo_read" returns correct data after "pg_lo_import"'; $data = ''; $result = $dbh->pg_lo_read($handle, $data, 100); is ($result, 7, $t); is ($data, "abc\ndef", $t); $t='DB handle method "pg_lo_export" works'; ($fh,$filename) = File::Temp::tmpnam(); $result = $dbh->pg_lo_export($objid, $filename); ok (-e $filename, $t); seek($fh,0,1); seek($fh,0,0); $result = read $fh, $data, 10; is ($result, 7, $t); is ($data, "abc\ndef", $t); close $fh or warn 'Could not close tempfile'; unlink $filename; } ## Same pg_lo_* tests, but with AutoCommit on $dbh->{AutoCommit}=1; $t='DB handle method "pg_lo_creat" fails when AutoCommit on'; eval { $dbh->pg_lo_creat($W); }; like ($@, qr{pg_lo_creat when AutoCommit is on}, $t); $t='DB handle method "pg_lo_open" fails with AutoCommit on'; eval { $dbh->pg_lo_open($object, $W); }; like ($@, qr{pg_lo_open when AutoCommit is on}, $t); $t='DB handle method "pg_lo_read" fails with AutoCommit on'; eval { $dbh->pg_lo_read($object, $data, 0); }; like ($@, qr{pg_lo_read when AutoCommit is on}, $t); $t='DB handle method "pg_lo_lseek" fails with AutoCommit on'; eval { $dbh->pg_lo_lseek($handle, 0, 0); }; like ($@, qr{pg_lo_lseek when AutoCommit is on}, $t); $t='DB handle method "pg_lo_write" fails with AutoCommit on'; $buf = 'tangelo mulberry passionfruit raspberry plantain' x 500; eval { $dbh->pg_lo_write($handle, $buf, length($buf)); }; like ($@, qr{pg_lo_write when AutoCommit is on}, $t); $t='DB handle method "pg_lo_close" fails with AutoCommit on'; eval { $dbh->pg_lo_close($handle); }; like ($@, qr{pg_lo_close when AutoCommit is on}, $t); $t='DB handle method "pg_lo_tell" fails with AutoCommit on'; eval { $dbh->pg_lo_tell($handle); }; like ($@, qr{pg_lo_tell when AutoCommit is on}, $t); $t='DB handle method "pg_lo_unlink" fails with AutoCommit on'; eval { $dbh->pg_lo_unlink($object); }; like ($@, qr{pg_lo_unlink when AutoCommit is on}, $t); SKIP: { eval { require File::Temp; }; $@ and skip ('Must have File::Temp to test pg_lo_import and pg_lo_export', 5); $t='DB handle method "pg_lo_import" works (AutoCommit on)'; my ($fh,$filename) = File::Temp::tmpnam(); print {$fh} "abc\ndef"; close $fh or warn 'Failed to close temporary file'; $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $t='DB handle method "pg_lo_import" inserts correct data (AutoCommit on, begin_work not called)'; $SQL = 'SELECT data FROM pg_largeobject where loid = ?'; $sth = $dbh->prepare($SQL); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, "abc\ndef", $t); $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, no command)'; $dbh->begin_work(); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, "abc\ndef", $t); $dbh->rollback(); $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, no command, rollback)'; $dbh->begin_work(); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $dbh->rollback(); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, undef, $t); $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, second command)'; $dbh->begin_work(); $dbh->do('SELECT 123'); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, "abc\ndef", $t); $dbh->rollback(); $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, second command, rollback)'; $dbh->begin_work(); $dbh->do('SELECT 123'); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $dbh->rollback(); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, undef, $t); $t='DB handle method "pg_lo_import" works (AutoCommit not on, no command)'; $dbh->{AutoCommit} = 0; $dbh->commit(); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, "abc\ndef", $t); $t='DB handle method "pg_lo_import" works (AutoCommit not on, second command)'; $dbh->rollback(); $dbh->do('SELECT 123'); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, "abc\ndef", $t); unlink $filename; $dbh->{AutoCommit} = 1; my $objid = $handle; $t='DB handle method "pg_lo_export" works (AutoCommit on)'; ($fh,$filename) = File::Temp::tmpnam(); $result = $dbh->pg_lo_export($objid, $filename); ok (-e $filename, $t); seek($fh,0,1); seek($fh,0,0); $result = read $fh, $data, 10; is ($result, 7, $t); is ($data, "abc\ndef", $t); close $fh or warn 'Could not close tempfile'; unlink $filename; } $dbh->{AutoCommit} = 0; # # Test of the "pg_notifies" database handle method # $t='DB handle method "pg_notifies" does not throw an error'; eval { $dbh->func('pg_notifies'); }; is ($@, q{}, $t); $t='DB handle method "pg_notifies" (func) returns the correct values'; my $notify_name = 'dbdpg_notify_test'; my $pid = $dbh->selectall_arrayref('SELECT pg_backend_pid()')->[0][0]; $dbh->do("LISTEN $notify_name"); $dbh->do("NOTIFY $notify_name"); $dbh->commit(); $info = $dbh->func('pg_notifies'); is_deeply ($info, [$notify_name, $pid, ''], $t); $t='DB handle method "pg_notifies" returns the correct values'; $dbh->do("NOTIFY $notify_name"); $dbh->commit(); $info = $dbh->pg_notifies; is_deeply ($info, [$notify_name, $pid, ''], $t); # # Test of the "getfd" database handle method # $t='DB handle method "getfd" returns a number'; $result = $dbh->func('getfd'); like ($result, qr/^\d+$/, $t); # # Test of the "state" database handle method # $t='DB handle method "state" returns an empty string on success'; $result = $dbh->state(); is ($result, q{}, $t); $t='DB handle method "state" returns a five-character code on error'; eval { $dbh->do('SELECT dbdpg_throws_an_error'); }; $result = $dbh->state(); like ($result, qr/^[A-Z0-9]{5}$/, $t); $dbh->rollback(); # # Test of the "private_attribute_info" database handle method # SKIP: { if ($DBI::VERSION < 1.54) { skip ('DBI must be at least version 1.54 to test private_attribute_info', 2); } $t='DB handle method "private_attribute_info" returns at least one record'; my $private = $dbh->private_attribute_info(); my ($valid,$invalid) = (0,0); for my $name (keys %$private) { $name =~ /^pg_\w+/ ? $valid++ : $invalid++; } ok ($valid >= 1, $t); $t='DB handle method "private_attribute_info" returns only internal names'; is ($invalid, 0, $t); } # # Test of the "clone" database handle method # $t='Database handle method "clone" does not throw an error'; my $dbh2; eval { $dbh2 = $dbh->clone(); }; is ($@, q{}, $t); $t='Database handle method "clone" returns a valid database handle'; eval { $dbh2->do('SELECT 123'); }; is ($@, q{}, $t); $dbh2->disconnect(); # # Test of the "ping" database handle method # $t='DB handle method "ping" returns 1 on an idle connection'; is ($dbh->ping(), 1, $t); $t='DB handle method "ping" returns 3 for a good connection inside a transaction'; $dbh->do('SELECT 123'); $result = 3; is ($result, $dbh->ping(), $t); $t='DB handle method "ping" returns 1 on an idle connection'; $dbh->commit(); is ($dbh->ping(), 1, $t); my $mtvar; ## This is an implicit test of getline: please leave this var undefined $t='DB handle method "ping" returns 2 when in COPY IN state'; $dbh->do('COPY dbd_pg_test(id,pname) TO STDOUT'); { local $SIG{__WARN__} = sub {}; $dbh->pg_getline($mtvar,100); } is ($dbh->ping(), 2, $t); 1 while $dbh->pg_getline($mtvar,1000); $t='DB handle method "ping" returns 3 for a good connection inside a transaction'; $dbh->do('SELECT 123'); is ($dbh->ping(), 3, $t); $t='DB handle method "ping" returns a 4 when inside a failed transaction'; eval { $dbh->do('DBD::Pg creating an invalid command for testing'); }; is ($dbh->ping(), 4, $t); $t='DB handle method "ping" fails (returns 0) on a disconnected handle'; $dbh->disconnect(); is ($dbh->ping(), 0, $t); $t='Able to reconnect to the database after disconnect'; $dbh = connect_database({nosetup => 1}); isnt ($dbh, undef, $t); # # Test of the "pg_ping" database handle method # $t='DB handle method "pg_ping" returns 1 on an idle connection'; is ($dbh->pg_ping(), 1, $t); $t='DB handle method "pg_ping" returns 3 for a good connection inside a transaction'; $dbh->do('SELECT 123'); is ($dbh->pg_ping(), 3, $t); $t='DB handle method "pg_ping" returns 1 on an idle connection'; $dbh->commit(); is ($dbh->pg_ping(), 1, $t); $t='DB handle method "pg_ping" returns 2 when in COPY IN state'; $dbh->do('COPY dbd_pg_test(id,pname) TO STDOUT'); $dbh->pg_getline($mtvar,100); is ($dbh->pg_ping(), 2, $t); $t='DB handle method "pg_ping" returns 2 immediately after COPY IN state'; 1 while $dbh->pg_getline($mtvar,1000); is ($dbh->pg_ping(), 2, $t); $t='DB handle method "pg_ping" returns 3 for a good connection inside a transaction'; $dbh->do('SELECT 123'); is ($dbh->pg_ping(), 3, $t); $t='DB handle method "pg_ping" returns a 4 when inside a failed transaction'; eval { $dbh->do('DBD::Pg creating an invalid command for testing'); }; is ($dbh->pg_ping(), 4, $t); $t='DB handle method "pg_ping" fails (returns 0) on a disconnected handle'; cleanup_database($dbh,'test'); $dbh->disconnect(); is ($dbh->pg_ping(), -1, $t); DBD-Pg-2.19.3/t/09arrays.t0000644000076400007640000003273411726435424013330 0ustar greggreg#!perl ## Test arrays use 5.006; use strict; use warnings; use Test::More; use Data::Dumper; use DBI ':sql_types'; use DBD::Pg ':pg_types'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 200; isnt ($dbh, undef, 'Connect to database for array testing'); my ($sth,$result,$t); my $pgversion = $dbh->{pg_server_version}; my $SQL = q{DELETE FROM dbd_pg_test WHERE pname = 'Array Testing'}; my $cleararray = $dbh->prepare($SQL); $SQL = q{INSERT INTO dbd_pg_test(id,pname,testarray) VALUES (99,'Array Testing',?)}; my $addarray = $dbh->prepare($SQL); $SQL = q{INSERT INTO dbd_pg_test(id,pname,testarray2) VALUES (99,'Array Testing',?)}; my $addarray_int = $dbh->prepare($SQL); $SQL = q{INSERT INTO dbd_pg_test(id,pname,testarray3) VALUES (99,'Array Testing',?)}; my $addarray_bool = $dbh->prepare($SQL); $SQL = q{SELECT testarray FROM dbd_pg_test WHERE pname= 'Array Testing'}; my $getarray = $dbh->prepare($SQL); $SQL = q{SELECT testarray2 FROM dbd_pg_test WHERE pname= 'Array Testing'}; my $getarray_int = $dbh->prepare($SQL); $SQL = q{SELECT testarray3 FROM dbd_pg_test WHERE pname= 'Array Testing'}; my $getarray_bool = $dbh->prepare($SQL); $t='Array quoting allows direct insertion into statements'; $SQL = q{INSERT INTO dbd_pg_test (id,testarray) VALUES }; my $quoteid = $dbh->quote(123); my $quotearr = $dbh->quote([q{Quote's Test}]); $SQL .= qq{($quoteid, $quotearr)}; eval { $dbh->do($SQL); }; is ($@, q{}, $t); $dbh->rollback(); ## Input (eval-able Perl) ## Expected (ERROR or raw PostgreSQL output) ## Name of test my $array_tests = q![''] {""} Empty array [['']] {{""}} Empty array with two levels [[['']]] {{{""}}} Empty array with three levels [[''],['']] {{""},{""}} Two empty arrays [[[''],[''],['']]] {{{""},{""},{""}}} Three empty arrays at second level [[],[[]]] ERROR: must be of equal size Unbalanced empty arrays {} ERROR: Cannot bind a reference Bare hashref [{}] ERROR: only scalars and other arrays Hashref at top level [1,2,{3,4},5] ERROR: only scalars and other arrays Hidden hashref [[1,2],[3]] ERROR: must be of equal size Unbalanced array [[1,2],[3,4,5]] ERROR: must be of equal size Unbalanced array [[1,2],[]] ERROR: must be of equal size Unbalanced array [[],[3]] ERROR: must be of equal size Unbalanced array [123] {123} Simple 1-D numeric array ['abc'] {abc} Simple 1-D text array ['a','b,c'] {a,"b,c"} Text array with commas and quotes ['a','b,}'] {a,"b,}"} Text array with commas, escaped closing brace ['a','b,]'] {a,"b,]"} Text array with commas, escaped closing bracket [1,2] {1,2} Simple 1-D numeric array [[1]] {{1}} Simple 2-D numeric array [[1,2]] {{1,2}} Simple 2-D numeric array [[[1]]] {{{1}}} Simple 3-D numeric array [[["alpha",2],[23,"pop"]]] {{{alpha,2},{23,pop}}} 3-D mixed array [[[1,2,3],[4,5,"6"],["seven","8","9"]]] {{{1,2,3},{4,5,6},{seven,8,9}}} 3-D mixed array [q{O'RLY?}] {O'RLY?} Simple single quote [q{O"RLY?}] {"O\"RLY?"} Simple double quote [[q{O"RLY?}],[q|'Ya' - "really"|],[123]] {{"O\"RLY?"},{"'Ya' - \"really\""},{123}} Many quotes ["Single\\\\Backslash"] {"Single\\\\Backslash"} Single backslash testing ["Double\\\\\\\\Backslash"] {"Double\\\\\\\\Backslash"} Double backslash testing [["Test\\\nRun","Quite \"so\""],["back\\\\\\\\slashes are a \"pa\\\\in\"",123] ] {{"Test\\\nRun","Quite \"so\""},{"back\\\\\\\\slashes are a \"pa\\\\in\"",123}} Escape party - backslash+newline, two + one [undef] {NULL} NEED 80200: Simple undef test [[undef]] {{NULL}} NEED 80200: Simple undef test [[1,2],[undef,3],["four",undef],[undef,undef]] {{1,2},{NULL,3},{four,NULL},{NULL,NULL}} NEED 80200: Multiple undef test !; ## Note: We silently allow things like this: [[[]],[]] sub safe_getarray { my $ret = eval { $getarray->execute(); $getarray->fetchall_arrayref()->[0][0]; }; return $@ || $ret; } for my $test (split /\n\n/ => $array_tests) { next unless $test =~ /\w/; my ($input,$expected,$msg) = split /\n/ => $test; my $perl_input = eval $input; if ($msg =~ s/NEED (\d+):\s*//) { my $ver = $1; if ($pgversion < $ver) { SKIP: { skip ('Cannot test NULL arrays unless version 8.2 or better', 4); } next; } } # INSERT via bind values $dbh->rollback; eval { $addarray->execute($perl_input); }; if ($expected =~ /error:\s+(.+)/i) { like ($@, qr{$1}, "[bind] Array insert error : $msg : $input"); } else { is ($@, q{}, "[bind] Array insert success : $msg : $input"); $t="[bind][!expand] Correct array inserted: $msg : $input"; $dbh->{pg_expand_array} = 0; is (safe_getarray, $expected, $t); $t="[bind][expand] Correct array inserted: $msg : $input"; $dbh->{pg_expand_array} = 1; is_deeply (safe_getarray, $perl_input, $t); } # INSERT via `quote' and dynamic SQL $dbh->rollback; eval { $quotearr = $dbh->quote($perl_input); $SQL = qq{INSERT INTO dbd_pg_test(id,pname,testarray) VALUES (99,'Array Testing',$quotearr)}; $dbh->do($SQL); }; if ($expected =~ /error:\s+(.+)/i) { my $errmsg = $1; $errmsg =~ s/bind/quote/; like ($@, qr{$errmsg}, "[quote] Array insert error : $msg : $input"); } else { is ($@, q{}, "[quote] Array insert success : $msg : $input"); # No need to recheck !expand case. $t="[quote][expand] Correct array inserted: $msg : $input"; is_deeply (safe_getarray, $perl_input, $t); } if ($msg =~ /STOP/) { warn "Exiting for DEBUGGING. Result is:\n"; warn Dumper $result; cleanup_database($dbh,'test'); $dbh->disconnect; exit; } } ## Test of no-item and empty string arrays $t=q{String array with no items returns empty array}; $cleararray->execute(); $addarray->execute('{}'); $getarray->execute(); $result = $getarray->fetchall_arrayref(); is_deeply ($result, [[[]]], $t); $t=q{String array with empty string returns empty string}; $cleararray->execute(); $addarray->execute('{""}'); $getarray->execute(); $result = $getarray->fetchall_arrayref(); is_deeply ($result, [[['']]], $t); ## Test non-string array variants $t=q{Integer array with no items returns empty array}; $cleararray->execute(); $addarray_int->execute('{}'); $getarray_int->execute(); $result = $getarray_int->fetchall_arrayref(); is_deeply ($result, [[[]]], $t); $t=q{Boolean array with no items returns empty array}; $cleararray->execute(); $addarray_bool->execute('{}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[]]], $t); $t=q{Boolean array gets created and returned correctly}; $cleararray->execute(); $addarray_bool->execute('{1}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[1]]], $t); $cleararray->execute(); $addarray_bool->execute('{0}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[0]]], $t); $cleararray->execute(); $addarray_bool->execute('{t}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[1]]], $t); $cleararray->execute(); $addarray_bool->execute('{f}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[0]]], $t); $cleararray->execute(); $addarray_bool->execute('{f,t,f,0,1,1}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[0,1,0,0,1,1]]], $t); ## Pure string to array conversion testing my $array_tests_out = q!1 [1] Simple test of single array element 1,2 [1,2] Simple test of multiple array elements 1,2,3 [1,2,3] Simple test of multiple array elements 'a','b' ['a','b'] Array with text items 0.1,2.4 [0.1,2.4] Array with numeric items 'My"lrd','b','c' ['My"lrd','b','c'] Array with escaped items [1] [[1]] Multi-level integer array [[1,2]] [[[1,2]]] Multi-level integer array [[1],[2]] [[[1],[2]]] Multi-level integer array [[1],[2],[3]] [[[1],[2],[3]]] Multi-level integer array [[[1]],[[2]],[[3]]] [[[[1]],[[2]],[[3]]]] Multi-level integer array 'abc',NULL ['abc',undef] NEED 80200: Array with a null ['abc','NULL',NULL,NULL,123::text] [['abc','NULL',undef,undef,'123']] NEED 80200: Array with many nulls and a quoted int ['abc',''] [['abc','']] Final item is empty 1,NULL [1,undef] NEED 80200: Last item is NULL NULL [undef] NEED 80200: Only item is NULL NULL,NULL [undef,undef] NEED 80200: Two NULL items only NULL,NULL,NULL [undef,undef,undef] NEED 80200: Three NULL items only [123,NULL,456] [[123,undef,456]] NEED 80200: Middle item is NULL NULL,'abc' [undef,'abc'] NEED 80200: First item is NULL 'a','NULL' ['a',"NULL"] Fake NULL is text [[[[[1,2,3]]]]] [[[[[[1,2,3]]]]]] Deep nesting [[[[[1],[2],[3]]]]] [[[[[[1],[2],[3]]]]]] Deep nesting [[[[[1]]],[[[2]]],[[[3]]]]] [[[[[[1]]],[[[2]]],[[[3]]]]]] Deep nesting [[[[[1]],[[2]],[[3]]]]] [[[[[[1]],[[2]],[[3]]]]]] Deep nesting 1::bool [1] Test of boolean type 1::bool,0::bool,'true'::boolean [1,0,1] Test of boolean types 1::oid [1] Test of oid type - should not quote 1::text ['1'] Text number should quote 1,2,3 [1,2,3] Unspecified int should not quote 1::int [1] Integer number should quote '(1,2),(4,5)'::box,'(5,3),(4,5)' ['(4,5),(1,2)','(5,5),(4,3)'] Type 'box' works !; $Data::Dumper::Indent = 0; for my $test (split /\n\n/ => $array_tests_out) { next unless $test =~ /\w/; my ($input,$expected,$msg) = split /\n/ => $test; my $qexpected = $expected; if ($expected =~ s/\s*quote:\s*(.+)//) { $qexpected = $1; } if ($msg =~ s/NEED (\d+):\s*//) { my $ver = $1; if ($pgversion < $ver) { SKIP: { skip ('Cannot test NULL arrays unless version 8.2 or better', 1); } next; } } if ($pgversion < 80200) { if ($input =~ /SKIP/ or $test =~ /Fake NULL|boolean/) { SKIP: { skip ('Cannot test some array items on pre-8.2 servers', 1); } next; } } $t="Array test $msg : $input"; $SQL = qq{SELECT ARRAY[$input]}; $result = ''; eval { $result = $dbh->selectall_arrayref($SQL)->[0][0]; }; if ($result =~ /error:\s+(.+)/i) { like ($@, qr{$1}, "Array failed : $msg : $input"); } else { $expected = eval $expected; ## is_deeply does not handle type differences is ( (Dumper $result), (Dumper $expected), $t); } } ## Check utf-8 in and out of the database SKIP: { eval { require Encode; }; skip ('Encode module is needed for unicode tests', 14) if $@; my $server_encoding = $dbh->selectall_arrayref('SHOW server_encoding')->[0][0]; skip ('Cannot reliably test unicode without a UTF8 database', 14) if $server_encoding ne 'UTF8'; $t='String should be UTF-8'; local $dbh->{pg_enable_utf8} = 1; my $utf8_str = chr(0x100).'dam'; # LATIN CAPITAL LETTER A WITH MACRON ok (Encode::is_utf8( $utf8_str ), $t); $t='quote() handles utf8'; my $quoted = $dbh->quote($utf8_str); is ($quoted, qq{'$utf8_str'}, $t); $t='Quoted string should be UTF-8'; ok (Encode::is_utf8( $quoted ), $t); $t='quote() handles utf8 inside array'; $quoted = $dbh->quote([$utf8_str, $utf8_str]); is ($quoted, qq!'{"$utf8_str","$utf8_str"}'!, $t); $t='Quoted array of strings should be UTF-8'; ok (Encode::is_utf8( $quoted ), $t); ## Workaround for client encodings such as SJIS my $old_encoding = $dbh->selectall_arrayref('SHOW client_encoding')->[0][0]; if ($old_encoding ne 'UTF8') { $dbh->do(q{SET NAMES 'UTF8'}); } $t='Inserting utf-8 into an array via quoted do() works'; $dbh->do('DELETE FROM dbd_pg_test'); $SQL = qq{INSERT INTO dbd_pg_test (id, testarray, val) VALUES (1, $quoted, 'one')}; eval { $dbh->do($SQL); }; is ($@, q{}, $t); $t='Retreiving an array containing utf-8 works'; $SQL = q{SELECT id, testarray, val FROM dbd_pg_test WHERE id = 1}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->fetchall_arrayref()->[0]; my $expected = [1,[$utf8_str,$utf8_str],'one']; is_deeply ($result, $expected, $t); $t='Selected string should be UTF-8'; ok (Encode::is_utf8( $result->[1][0] ), $t); $t='Selected string should be UTF-8'; ok (Encode::is_utf8( $result->[1][1] ), $t); $t='Inserting utf-8 into an array via prepare and arrayref works'; $dbh->do('DELETE FROM dbd_pg_test'); $SQL = q{INSERT INTO dbd_pg_test (id, testarray, val) VALUES (?, ?, 'one')}; $sth = $dbh->prepare($SQL); eval { $sth->execute(1,['Bob',$utf8_str]); }; is ($@, q{}, $t); local $dbh->{pg_enable_utf8} = 1; $t='Retreiving an array containing utf-8 works'; $SQL = q{SELECT id, testarray, val FROM dbd_pg_test WHERE id = 1}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->fetchall_arrayref()->[0]; $expected = [1,['Bob',$utf8_str],'one']; is_deeply ($result, $expected, $t); $t='Selected ASCII string should not be UTF-8'; ok (!Encode::is_utf8( $result->[1][0] ), $t); $t='Selected string should be UTF-8'; ok (Encode::is_utf8( $result->[1][1] ), $t); $t='Non utf-8 inside an array is not return as utf-8'; $dbh->do('DELETE FROM dbd_pg_test'); $SQL = q{INSERT INTO dbd_pg_test (id, testarray, val) VALUES (1, '{"noutfhere"}', 'one')}; $dbh->do($SQL); $SQL = q{SELECT testarray FROM dbd_pg_test WHERE id = 1}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->fetchall_arrayref()->[0][0]; ok (!Encode::is_utf8($result), $t); $sth->finish(); } ## Quick test of empty arrays my $expected = $pgversion >= 80300 ? [[[]]] : [[undef]]; $t=q{Empty int array is returned properly}; $result = $dbh->selectall_arrayref(q{SELECT array(SELECT 12345::int WHERE 1=0)::int[]}); is_deeply ($result, $expected, $t); $t=q{Empty text array is returned properly}; $result = $dbh->selectall_arrayref(q{SELECT array(SELECT 'empty'::text WHERE 1=0)::text[]}); is_deeply ($result, $expected, $t); cleanup_database($dbh,'test'); $dbh->disconnect; DBD-Pg-2.19.3/t/03smethod.t0000644000076400007640000005056311642756716013473 0ustar greggreg#!perl ## Test of the statement handle methods ## The following methods are *not* currently tested here: ## "execute" ## "finish" ## "dump_results" use 5.006; use strict; use warnings; use POSIX qw(:signal_h); use Test::More; use DBI ':sql_types'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 97; isnt ($dbh, undef, 'Connect to database for statement handle method testing'); my $pglibversion = $dbh->{pg_lib_version}; my ($SQL, $sth, $sth2, $result, @result, $expected, $rows, $t); # # Test of the prepare flags # $t=q{Calling prepare() with no arguments gives an error}; eval{ $sth = $dbh->prepare(); }; like ($@, qr{\+ 0}, $t); $t=q{Calling prepare() with an undefined value returns undef}; $sth = $dbh->prepare(undef); is ($sth, undef, $t); $t='Prepare/execute with no flags works'; $SQL = 'SELECT id FROM dbd_pg_test WHERE id = ?'; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_server_prepare off at database handle works'; $dbh->{pg_server_prepare} = 0; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); ## 7.4 does not have a full SSP implementation, so we simply skip these tests. if ($pglibversion < 80000) { SKIP: { skip ('Not testing pg_server_prepare on 7.4-compiled servers', 2); } } else { $t='Prepare/execute with pg_server_prepare on at database handle works'; $dbh->{pg_server_prepare} = 1; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); } ## We must send a hashref as the final arg $t='Prepare failes when sent a non-hashref'; eval { $sth = $dbh->prepare('SELECT 123', ['I am not a hashref!']); }; like ($@, qr{not a hash}, $t); # Make sure that undefs are converted to NULL. $t='Prepare/execute with undef converted to NULL'; $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id, pdate) VALUES (?,?)'); ok ($sth->execute(401, undef), $t); $t='Prepare/execute with pg_server_prepare off at statement handle works'; $sth = $dbh->prepare($SQL, {pg_server_prepare => 0}); $sth->execute(1); ok ($sth->execute, $t); if ($pglibversion >= 80000) { $t='Prepare/execute with pg_server_prepare on at statement handle works'; $sth = $dbh->prepare($SQL, {pg_server_prepare => 1}); $sth->execute(1); ok ($sth->execute, $t); } $t='Prepare/execute with pg_prepare_now on at database handle works'; $dbh->{pg_prepare_now} = 1; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_prepare_now off at database handle works'; $dbh->{pg_prepare_now} = 0; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_prepare_now off at statement handle works'; $sth = $dbh->prepare($SQL, {pg_prepare_now => 0}); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_prepare_now on at statement handle works'; $sth = $dbh->prepare($SQL, {pg_prepare_now => 1}); $sth->execute(1); ok ($sth->execute, $t); # Test using our own prepared statements $t='Prepare/execute works with pg_prepare_name'; my $pgversion = $dbh->{pg_server_version}; my $myname = 'dbdpg_test_1'; $dbh->do("PREPARE $myname(int) AS SELECT COUNT(*) FROM pg_class WHERE reltuples > \$1", {pg_direct=> 1}); $sth = $dbh->prepare('SELECT ?'); $sth->bind_param(1, 1, SQL_INTEGER); $sth->{pg_prepare_name} = $myname; ok ($sth->execute(1), $t); $dbh->do("DEALLOCATE $myname"); # # Test of the "bind_param" statement handle method # $t='Statement handle method "bind_param" works when binding an int column with an int'; $SQL = 'SELECT id FROM dbd_pg_test WHERE id = ?'; $sth = $dbh->prepare($SQL); ok ($sth->bind_param(1, 1), $t); $t='Statement handle method "bind_param" works when rebinding an int column with a string'; ok ($sth->bind_param(1, 'foo'), $t); # Check if the server is sending us warning messages # We assume that older servers are okay my $client_level = ''; $sth2 = $dbh->prepare('SHOW client_min_messages'); $sth2->execute(); $client_level = $sth2->fetchall_arrayref()->[0][0]; # # Test of the "bind_param_inout" statement handle method # $t='Invalid placeholder fails for bind_param_inout'; my $var = 123; $sth = $dbh->prepare('SELECT 1+?::int'); eval { $sth->bind_param_inout(0, \$var, 0); }; like ($@, qr{Cannot bind}, $t); eval { $sth->bind_param_inout(3, \$var, 0); }; like ($@, qr{Cannot bind}, $t); $t = q{Calling bind_param_inout with a non-scalar reference fails}; eval { $sth->bind_param_inout(1, 'noway', 0); }; like ($@, qr{needs a reference}, $t); eval { $sth->bind_param_inout(1, $t, 0); }; like ($@, qr{needs a reference}, $t); eval { $sth->bind_param_inout(1, [123], 0); }; like ($@, qr{needs a reference}, $t); $t = q{Calling bind_param_inout changes an integer value}; eval { $sth->bind_param_inout(1, \$var, 0); }; is ($@, q{}, $t); $var = 999; $sth->execute(); $sth->fetch; is ($var, 1000, $t); $t = q{Calling bind_param_inout changes a string value}; $sth = $dbh->prepare(q{SELECT 'X'||?::text}); $sth->bind_param_inout(1, \$var, 0); $var = 'abc'; $sth->execute(); $sth->fetch; is ($var, 'Xabc', $t); $t = q{Calling bind_param_inout changes a string to a float}; $sth = $dbh->prepare('SELECT ?::float'); $sth->bind_param_inout(1, \$var, 0); $var = '1e+6'; $sth->execute(); $sth->fetch; is ($var, '1000000', $t); $t = q{Calling bind_param_inout works for second placeholder}; $sth = $dbh->prepare('SELECT ?::float, 1+?::int'); $sth->bind_param_inout(2, \$var, 0); $var = 111; $sth->execute(222,333); $sth->fetch; is ($var, 112, $t); $t = q{Calling bind_param_inout changes two variables at once}; my $var2 = 234; $sth = $dbh->prepare('SELECT 1+?::float, 1+?::int'); $sth->bind_param_inout(1, \$var, 0); $sth->bind_param_inout(2, \$var2, 0); $var = 444; $var2 = 555; $sth->execute(); $sth->fetch; is ($var, 445, $t); is ($var2, 556, $t); # # Test of the "bind_param_array" statement handle method # $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id, val) VALUES (?,?)'); # Try with 1, 2, and 3 values. All should succeed $t='Statement handle method "bind_param_array" works binding three values to the first placeholder'; eval { $sth->bind_param_array(1, [ 30, 31, 32 ], SQL_INTEGER); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works binding one scalar value to the second placeholder'; eval { $sth->bind_param_array(2, 'Mulberry'); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works binding three values to the second placeholder'; eval { $sth->bind_param_array(2, [ 'Mango', 'Strawberry', 'Gooseberry' ]); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works when binding one value to the second placeholder'; eval { $sth->bind_param_array(2, [ 'Mangoz' ]); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works when binding two values to the second placeholder'; eval { $sth->bind_param_array(2, [ 'Plantain', 'Apple' ]); }; is ($@, q{}, $t); # # Test of the "execute_array" statement handle method # $t='Statement method handle "execute_array" works'; $dbh->{RaiseError}=1; my @tuple_status; $rows = $sth->execute_array( { ArrayTupleStatus => \@tuple_status }); is_deeply (\@tuple_status, [1,1,1], $t); $t='Statement method handle "execute_array" returns correct number of rows'; is ($rows, 3, $t); # Test the ArrayTupleFetch attribute $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id, val) VALUES (?,?)'); # Try with 1, 2, and 3 values. All should succeed $sth->bind_param_array(1, [ 20, 21, 22 ], SQL_INTEGER); $sth->bind_param_array(2, 'fruit'); my $counter=0; my @insertvals = ( [33 => 'Peach'], [34 => 'Huckleberry'], [35 => 'Guava'], [36 => 'Lemon'], ); sub getval { return $insertvals[$counter++]; } $t='Statement method handle "execute_array" works with ArrayTupleFetch'; undef @tuple_status; $rows = $sth->execute_array( { ArrayTupleStatus => \@tuple_status, ArrayTupleFetch => \&getval }); is_deeply (\@tuple_status, [1,1,1,1], $t); $t='Statement method handle "execute_array" returns correct number of rows with ArrayTupleFetch'; is ($rows, 4, $t); # # Test of the "execute_for_fetch" statement handle method # $sth = $dbh->prepare('SELECT id+200, val FROM dbd_pg_test'); my $goodrows = $sth->execute(); $sth2 = $dbh->prepare(q{INSERT INTO dbd_pg_test (id, val) VALUES (?,?)}); $sth2->bind_param(1,'',SQL_INTEGER); my $fetch_tuple_sub = sub { $sth->fetchrow_arrayref() }; undef @tuple_status; $rows = $sth2->execute_for_fetch($fetch_tuple_sub, \@tuple_status); $t='Statement handle method "execute_for_fetch" works'; is_deeply (\@tuple_status, [map{1}(1..$goodrows)], $t); $t='Statement handle method "execute_for_fetch" returns correct number of rows'; is ($rows, $goodrows, $t); # # Test of the "fetchrow_arrayref" statement handle method # $t='Statement handle method "fetchrow_arrayref" returns first row correctly'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id = 34'); $sth->execute(); $result = $sth->fetchrow_arrayref(); is_deeply ($result, [34, 'Huckleberry'], $t); $t='Statement handle method "fetchrow_arrayref" returns undef when done'; $result = $sth->fetchrow_arrayref(); is_deeply ($result, undef, $t); # Test of the "fetch" alias $t='Statement handle method alias "fetch" returns first row correctly'; $sth->execute(); $result = $sth->fetch(); $expected = [34, 'Huckleberry']; is_deeply ($result, $expected, $t); $t='Statement handle method alias "fetch" returns undef when done'; $result = $sth->fetch(); is_deeply ($result, undef, $t); # # Test of the "fetchrow_array" statement handle method # $t='Statement handle method "fetchrow_array" returns first row correctly'; $sth->execute(); @result = $sth->fetchrow_array(); is_deeply (\@result, $expected, $t); $t='Statement handle method "fetchrow_array" returns an empty list when done'; @result = $sth->fetchrow_array(); is_deeply (\@result, [], $t); # # Test of the "fetchrow_hashref" statement handle method # $t='Statement handle method "fetchrow_hashref" works with a slice argument'; $sth->execute(); $result = $sth->fetchrow_hashref(); $expected = {id => 34, val => 'Huckleberry'}; is_deeply ($result, $expected, $t); $t='Statement handle method "fetchrow_hashref" returns undef when done'; $result = $sth->fetchrow_hashref(); is_deeply ($result, undef, $t); # # Test of the "fetchall_arrayref" statement handle method # $t='Statement handle method "fetchall_arrayref" returns first row correctly'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (35,36) ORDER BY id ASC'); $sth->execute(); $result = $sth->fetchall_arrayref(); $expected = [[35,'Guava'],[36,'Lemon']]; is_deeply ($result, $expected, $t); # Test of the 'slice' argument $t='Statement handle method "fetchall_arrayref" works with an arrayref slice'; $sth->execute(); $result = $sth->fetchall_arrayref([1]); $expected = [['Guava'],['Lemon']]; is_deeply ($result, $expected, $t); $t='Statement handle method "fetchall_arrayref" works with a hashref slice'; $sth->execute(); $result = $sth->fetchall_arrayref({id => 1}); $expected = [{id => 35},{id => 36}]; is_deeply ($result, $expected, $t); # My personal favorite way of grabbing data $t='Statement handle method "fetchall_arrayref" works with an empty hashref slice'; $sth->execute(); $result = $sth->fetchall_arrayref({}); $expected = [{id => 35, val => 'Guava'},{id => 36, val => 'Lemon'}]; is_deeply ($result, $expected, $t); SKIP: { if ($DBI::VERSION >= 1.603) { skip ('fetchall_arrayref max rows broken in DBI 1.603', 2); } # Test of the 'maxrows' argument $t=q{Statement handle method "fetchall_arrayref" works with a 'maxrows' argument}; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id >= 33 ORDER BY id ASC LIMIT 10'); $sth->execute(); $result = $sth->fetchall_arrayref(undef,2); $expected = [[33,'Peach'],[34,'Huckleberry']]; is_deeply ($result, $expected, $t); $t=q{Statement handle method "fetchall_arrayref" works with an arrayref slice and a 'maxrows' argument}; $result = $sth->fetchall_arrayref([1],2); $expected = [['Guava'],['Lemon']]; $sth->finish(); is_deeply ($result, $expected, $t); } # # Test of the "fetchall_hashref" statement handle method # $t='Statement handle method "fetchall_hashref" gives an error when called with no arguments'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $sth->execute(); eval { $sth->fetchall_hashref(); }; isnt ($@, q{}, $t); $t='Statement handle method "fetchall_hashref" works with a named key field'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $sth->execute(); $result = $sth->fetchall_hashref('id'); $expected = {33=>{id => 33, val => 'Peach'},34=>{id => 34, val => 'Huckleberry'}}; is_deeply ($result, $expected, $t); $t='Statement handle method "fetchall_hashref" returns an empty hash when no rows returned'; $sth->execute(); $result = $sth->fetchall_hashref(1); is_deeply ($result, $expected, q{Statement handle method "fetchall_hashref" works with a numeric key field}); $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id < 1'); $sth->execute(); $result = $sth->fetchall_hashref(1); is_deeply ($result, {}, $t); # # Test of the "rows" statement handle method # $t='Statement handle method "rows" returns -1 before an execute'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $rows = $sth->rows(); is ($rows, -1, $t); $t='Statement handle method "rows" returns correct number of rows'; $sth->execute(); $rows = $sth->rows(); $sth->finish(); is ($rows, 2, $t); # # Test of the "bind_col" statement handle method # $t='Statement handle method "bind_col" returns the correct value'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $sth->execute(); my $bindme; $result = $sth->bind_col(2, \$bindme); is ($result, 1, $t); $t='Statement handle method "bind_col" correctly binds parameters'; $sth->fetch(); is ($bindme, 'Peach', $t); $dbh->do(q{UPDATE dbd_pg_test SET testarray = '{2,3,55}' WHERE id = 33}); $t='Statement handle method "bind_col" returns the correct value'; my $bindarray; $sth = $dbh->prepare('SELECT id, testarray FROM dbd_pg_test WHERE id = 33'); $sth->execute(); $result = $sth->bind_col(1, \$bindme); is ($result, 1, $t); $t='Statement handle method "bind_col" returns the correct value'; $result = $sth->bind_col(2, \$bindarray); is ($result, 1, $t); $t='Statement handle method "bind_col" correctly binds parameters'; $sth->fetch(); is ($bindme, '33', $t); $t='Statement handle method "bind_col" correctly binds arrayref'; is_deeply ($bindarray, [2,3,55], $t); # # Test of the "bind_columns" statement handle method # $t='Statement handle method "bind_columns" fails when called with wrong number of arguments'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34) ORDER BY id'); $sth->execute(); my $bindme2; eval { $sth->bind_columns(1); }; isnt ($@, q{}, $t); $t='Statement handle method "bind_columns" returns the correct value'; $result = $sth->bind_columns(\$bindme, \$bindme2); is ($result, 1, $t); $t='Statement handle method "bind_columns" correctly binds parameters'; $sth->fetch(); $expected = [33, 'Peach']; my $got = [$bindme, $bindme2]; $sth->finish(); is_deeply ($got, $expected, $t); # # Test of the statement handle method "state" # $t='Statement handle method "state" returns an empty string on success'; $result = $sth->state(); is ($result, q{}, $t); $t='Statement handle method "state" returns a five-character code on error'; eval { $sth = $dbh->prepare('SELECT dbdpg_throws_an_error'); $sth->execute(); }; $result = $sth->state(); like ($result, qr/^[A-Z0-9]{5}$/, $t); $t='Statement and database handle method "state" return same code'; my $result2 = $dbh->state(); is ($result, $result2, $t); $t='Statement handle method "state" returns expected code'; is ($result, '42703', $t); # # Test of the statement handle method "private_attribute_info" # SKIP: { if ($DBI::VERSION < 1.54) { skip ('DBI must be at least version 1.54 to test private_attribute_info', 2); } $t='Statement handle method "private_attribute_info" returns at least one record'; $sth = $dbh->prepare('SELECT 123'); my $private = $sth->private_attribute_info(); my ($valid,$invalid) = (0,0); for my $name (keys %$private) { $name =~ /^pg_\w+/ ? $valid++ : $invalid++; } cmp_ok ($valid, '>=', 1, $t); $t='Statement handle method "private_attribute_info" returns only internal names'; $sth->finish(); is ($invalid, 0, $t); } # # Test of the statement handle method "pg_numbound" # $dbh->rollback(); $t=q{Statement handle attribute pg_numbound returns 0 if no placeholders}; $sth = $dbh->prepare('SELECT 123'); is ($sth->{pg_numbound}, 0, $t); $sth->execute(); is ($sth->{pg_numbound}, 0, $t); $t=q{Statement handle attribute pg_numbound returns 0 if no placeholders bound yet}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); is ($sth->{pg_numbound}, 0, $t); $t=q{Statement handle attribute pg_numbound returns 1 if one placeholder bound}; $sth->bind_param(1, 123); is ($sth->{pg_numbound}, 1, $t); $t=q{Statement handle attribute pg_numbound returns 2 if two placeholders bound}; $sth->bind_param(2, 345); is ($sth->{pg_numbound}, 2, $t); $t=q{Statement handle attribute pg_numbound returns 1 if one placeholders bound as NULL}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); $sth->bind_param(1, undef); is ($sth->{pg_numbound}, 1, $t); # # Test of the statement handle method "pg_bound" # $t=q{Statement handle attribute pg_bound returns an empty hash if no placeholders}; $sth = $dbh->prepare('SELECT 123'); is_deeply ($sth->{pg_bound}, {}, $t); $sth->execute(); is_deeply ($sth->{pg_bound}, {}, $t); $t=q{Statement handle attribute pg_bound returns correct value if no placeholders bound yet}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); is_deeply ($sth->{pg_bound}, {1=>0, 2=>0}, $t); $t=q{Statement handle attribute pg_bound returns correct value if one placeholder bound}; $sth->bind_param(2, 123); is_deeply ($sth->{pg_bound}, {1=>0, 2=>1}, $t); $t=q{Statement handle attribute pg_bound returns correct value if two placeholders bound}; $sth->bind_param(1, 123); is_deeply ($sth->{pg_bound}, {1=>1, 2=>1}, $t); # # Test of the statement handle method "pg_numbound" # $t=q{Statement handle attribute pg_numbound returns 1 if one placeholders bound as NULL}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); $sth->bind_param(1, undef); is_deeply ($sth->{pg_bound}, {1=>1, 2=>0}, $t); # # Test of the statement handle method "pg_current_row" # $t=q{Statement handle attribute pg_current_row returns zero until first row fetched}; $sth = $dbh->prepare('SELECT 1 FROM pg_class LIMIT 5'); is ($sth->{pg_current_row}, 0, $t); $t=q{Statement handle attribute pg_current_row returns zero until first row fetched}; $sth->execute(); is ($sth->{pg_current_row}, 0, $t); $t=q{Statement handle attribute pg_current_row returns 1 after a fetch}; $sth->fetch(); is ($sth->{pg_current_row}, 1, $t); $t=q{Statement handle attribute pg_current_row returns correct value while fetching}; my $x = 2; while (defined $sth->fetch()) { is ($sth->{pg_current_row}, $x++, $t); } $t=q{Statement handle attribute pg_current_row returns 0 when done fetching}; is ($sth->{pg_current_row}, 0, $t); $t=q{Statement handle attribute pg_current_row returns 0 after fetchall_arrayref}; $sth->execute(); $sth->fetchall_arrayref(); is ($sth->{pg_current_row}, 0, $t); # # Test of the statement handle method "cancel" # SKIP: { ## 7.4 does not have cancel if ($pglibversion < 80000) { skip ('Not testing cancel 7.4-compiled servers', 1); } $dbh->do('INSERT INTO dbd_pg_test (id) VALUES (?)',undef,1); $dbh->commit; $dbh->do('SELECT * FROM dbd_pg_test WHERE id = ? FOR UPDATE',undef,1); my $dbh2 = $dbh->clone; $dbh2->do('SET search_path TO ' . $dbh->selectrow_array('SHOW search_path')); my $oldaction; eval { # This statement will block indefinitely because of the 'FOR UPDATE' clause, # so we set up an alarm to cancel it after 2 seconds. my $sthl = $dbh2->prepare('SELECT * FROM dbd_pg_test WHERE id = ? FOR UPDATE'); $sthl->{RaiseError} = 1; my $action = POSIX::SigAction->new( sub {$sthl->cancel},POSIX::SigSet->new(SIGALRM)); $oldaction = POSIX::SigAction->new; POSIX::sigaction(SIGALRM,$action,$oldaction); alarm(2); # seconds before alarm $sthl->execute(1); alarm(0); # cancel alarm (if execute didn't block) }; # restore original signal handler POSIX::sigaction(SIGALRM,$oldaction); like ($@, qr/execute failed/, 'cancel'); $dbh2->disconnect(); } cleanup_database($dbh,'test'); $dbh->rollback(); $dbh->disconnect(); DBD-Pg-2.19.3/README.dev0000644000076400007640000007321112014741053012643 0ustar greggreg This file is for those interested in developing DBD::Pg. It is hoped that it will be a good introduction as well as a continual reference. Suggestions are always welcome. Note: most of this document assumes you are using a Unix-like system. Sections: * Overview * File List * Compiling * Editing * Heavy Testing * Debugging * Test Files * Version Numbers * New Files * New Methods * Making a New Release * Tips and Tricks * Resources ============== == Overview == ============== How It All Works DBD::Pg is a combination of Perl, C, and XS, using files from the dbdpg project, the DBI module, and libpq - the C library interface to the PostgreSQL server. There is a sometimes complex interweaving of files needed for each method. Running "perl Makefile.PL" uses the ExtUtils::MakeMaker module to create a true Makefile. Then the "make" command compiles everything, after creating the Pg.c file from Pg.xs and DBI's Perl.xsi. The files Pg.pm and blib/arch/auto/DBD/Pg/Pg.so form the core of the module once installed. (The above is oversimplified). The canonical git repo is at git://bucardo.org/dbdpg.git =============== == File List == =============== Here is what each file in the distribution does: * Text files: Changes - lists changes made to each version. Please be consistent and use tabs, not spaces, to indent. Try to list who found the bug, and who fixed it (if not the same person). Put the CPAN bug # in parenthesis, and put the person who made the actual changes in brackets. This file contains a version number. README.dev - you are reading it. README - the main file that explains the module, where to get it, and guides people in installing it. A large portion of it is simply a list of common gotchas and guides for various platforms. This file has a version number in it (or two, if this is a beta/release candidate) README.win32 - the directions on how to install DBD::Pg on a Win32 box. README.testdatabase - created by the tests to cache connection information. TODO - Rough list of upcoming tasks. SIGNATURE - Checksum verification via PGP, generated by Module::Signature. LICENSES/gpl-2.0.txt - GPL license LICENSES/artistic.txt - Artistic (Perl) license testme.tmp.pl - Quick helper file for testing individual bugs * Build files: Makefile.PL - The main file that starts everything off. Used by ExtUtils::MakeMaker to create the "Makefile". This file contains a version number. Makefile - Generated automatically by Makefile.PL. Not part of the distribution. META.yml - YAML description file. Updated by hand and contains a version number in three places. lib/Bundle/DBD/Pg.pm - Simple file used to enable perl -MCPAN -e 'install Bundle::DBD::Pg' Contains a version number. * Distribution files: MANIFEST - lists which files should be included in the release tarball. Used by the "make dist*" set of commands. MANIFEST.SKIP - files that are known to be safe to exclude from the release tarball. Used by the "make dist", "make distcheck" and "make skipcheck" commands. win32.mak - a helper file for the win32 build. * Program files: dbdimp.c - The main C file, which does most of the heavy lifting for the DBD::Pg module (the rest is done by Pg.pm). Almost all of the complexity and power of the module is here. dbdimp.h - Header file for dbdimp.c. dbivport.h - DBI portability macros. This should be the latest version from the DBI git repository. Pg.pm - The main Perl file, which contains DBD::Pg packages and code for the methods. Often times code here calls code from Pg.xs and dbdimp.c. This file contains a version number in two places (once in the code, once in the POD). The main documentation for the module lives here, as POD information. Pg.xs - The Perl "glue" file for DBD::Pg. This file basically tells Perl how to handle various methods. It makes many calls to dbdimp.c Pg.c - Not part of the distribution, but created from Pg.xs as part of the build process. Never edit this directly. Pg.h - Header file for Pg.xs (and thus Pg.c) quote.c - Various methods to help quote and dequote variables. Some of this is now done on the backend, but it is still needed to support older versions of PostgreSQL. quote.h - Header file for quote.c types.c - Lists all known data types for PostgreSQL. Run as a perl script to check for new types and rewrites the following: types.h types.c Pg.xs Pg.pm t/01constants.t 99_pod.t types.h - Header file for types.c * Test files: t/dbdpg_test_setup.pl - Common connection, schema creation, and schema destruction subs. Goes through a lot of trouble to try and get a database to test with. t/00_release.t - Quick check that all version numbers match. t/00basic.t - Very basic test to see if DBI and DBD::Pg load properly. Requires Test::Warn for the version warning test. t/00_signature.t - Uses Module::Signature to verify SIGNATURE file. All tests are skipped if the environment variable TEST_SIGNATURE is not set. t/01connect.t - Basic connection tests, outputs pretty, detailed connection information. t/01constants.t - Quick test of pg_types. t/02attribs.t - Tests all attributes. t/03dbmethod.t - Tests all database handle methods. t/03smethod.t - Tests all statement handle methods. t/04misc.t - Tests tracing, data_sources, $DBDPG_DEFAULT, and txn status changes. t/06bytea.t - Tests bytea manipulation. t/07copy.t - Tests COPY-related methods. t/08async.t - Tests asynchronous methods. t/09arrays.t - Tests array manipulation. t/12placeholders.t - Tests placeholders. t/20savepoints.t - Test savepoints. Requires a server version 8.0 or up. t/99cleanup.t - Removes anything we have created for the tests (e.g. tables) t/99_perlcritic.t - Uses Perl::Critic to check Pg.pm and all of the test files. Requires that TEST_CRITIC is set. It is recommended that you get all the Perl::Critic policies via Bundle::Perl::Critic::IncludingOptionalDependencies. .perlcriticrc - Used by the above: we assume tests are run from the main dir. t/99_pod.t - Verifies the POD of Pg.pm. Requires Test::POD version 0.95, and Test::Pod::Coverage 1.04. t/99_yaml.t - Uses Test::YAML::Meta to verify the META.yml file. t/99_spellcheck.t - Checks the spelling of everything it can. dbdpg_test_database - May be created by the test suite as a place to store a new database cluster. * Helper files The module App::Info is inside the t/lib directory (we put it there to prevent CPAN from indexing it). It is used by Makefile.PL to determine the version of PostgreSQL we are compiling against (by calling pg_config). It consists of: t/lib/App/Info.pm t/lib/App/Info/Handler.pm t/lib/App/Info/Handler/Prompt.pm t/lib/App/Info/RDBMS.pm t/lib/App/Info/RDBMS/PostgreSQL.pm t/lib/App/Info/Request.pm t/lib/App/Info/Util.pm =============== == Compiling == =============== Compiling is generally done with gcc. However, we also need to support a wide variety of compilers. Things which may only cause a minor warning when using gcc may stop other compilers cold. One way to catch this early is to add some warning flags to gcc. This can be done by extending the $comp_opts string inside of the Makefile.PL file. There are many warnings that can be enabled (see the man page for gcc for the list). Some of these warnings trigger for things outside of our control, such as the code for DBI or Perl itself. You can define the environment variable DBDPG_GCCDEBUG to turn many of these options on automatically. Within each section, the order is the same as found in man gcc. ## These are warnings that should only generate errors that we can fix: $comp_opts .= " -Wchar-subscripts -Wcomment"; $comp_opts .= " -Wformat=2"; ## does -Wformat,-Wformat-y2k,-Wformat-nonliteral,-Wformat-security $comp_opts .= " -Wnonnull"; $comp_opts .= " -Wuninitialized -Winit-self"; ## latter requires the former $comp_opts .= " -Wimplicit"; ## does -Wimplicit-int and -Wimplicit-function-declaration $comp_opts .= " -Wmain -Wmissing-braces -Wparentheses -Wsequence-point -Wreturn-type -Wswitch -Wswitch-enum -Wtrigraphs"; $comp_opts .= " -Wunused"; ## contains -Wunused- function,label,parameter,variable,value $comp_opts .= " -Wunknown-pragmas -Wstrict-aliasing"; $comp_opts .= " -Wall"; ## all of above, but we enumerate anyway $comp_opts .= " -Wextra -Wdeclaration-after-statement -Wendif-labels -Wpointer-arith"; $comp_opts .= " -Wbad-function-cast -Wcast-qual -Wcast-align -Wconversion -Wsign-compare -Waggregate-return"; $comp_opts .= " -Wmissing-prototypes -Wmissing-declarations -Wmissing-format-attribute -Wpacked -Winline -Winvalid-pch"; $comp_opts .= " -Wdisabled-optimization"; $comp_opts .= " -Wnested-externs"; $comp_opts .= " -Wstrict-prototypes"; ## Still hits a couple places in types.h $comp_opts .= " -Wswitch-default"; $comp_opts .= " -Wsystem-headers"; $comp_opts .= " -Wmissing-noreturn"; $comp_opts .= " -Wfloat-equal"; ## Does not like SvTRUE() calls $comp_opts .= " -Wpadded"; ## Use when adding/changing our structs ## These options tend to produce lots of hits outside of our code, but may still be useful: $comp_opts .= " -pedantic"; ## Useful, but very verbose $comp_opts .= " -Wundef"; ## Complains of XSubPPtmpAAAA in Pg.c being defined/undefined but then checked raw $comp_opts .= " -Wshadow"; ## lots of bogus hits - not very useful Filter: grep warning wfile | grep -v "/usr" $comp_opts .= " -Wwrite-strings"; $comp_opts .= " -Wredundant-decls"; ## Lots of warnings from Perl itself ## These options are probably not very useful: $comp_opts .= " -Wtraditional"; ## Lots and lots of junk $comp_opts .= " -Wold-style-definition"; ## We use lots of these $comp_opts .= " -Wunreachable-code"; ## Lots due to our multi-version ifdefs Please feel free to add to and clarify the above lists. ============= == Editing == ============= All the perl files should have a cperl pragma at the top of the file, for easy use in emacs. Please use tabs and not spaces everywhere, and keep the indenting to the cperl standard. Use the traditional C mode for *.c files. Pg.xs is a special case: if you know of a good mode for editing this file, please let us know and update this paragraph! Please follow the other syntax standards in place as much as possible. A few guidelines for XS files can be found in the XS perldocs. When in doubt, go with the guidelines from Damian Conway's Perl Best Practices book. =================== == Heavy Testing == =================== Testing should be done heavily and frequently, especially before a new release. The standard way to test is run "make test" which runs all the scripts in the "t" directory. If you find yourself making your own test, even if just for a minor or a temporary problem, please add it to the test suite. The more tests we have, the better. Generally, we want to run 'make test' on as wide a variety of configurations as possible. If you have different platforms of course, you should test all of those. Beyond that, you may find it helpful to set up some aliases to allow quick switching of Postgres and DBI versions. You should generally test each major version of PostgreSQL that DBD::Pg currently supports. Keep in mind that there are two things to test for each version: the server that we are compiling against (e.g. which libraries we are linking to) and the version we are connecting to. You should test all variations. One way is to keep multiple versions of PostgreSQL in standard directories, and use a standard port convention to keep things simple: the port is 5XXX where XXX is the version, so that PG 7.4.2 is listening on port 5742. Then set up two aliases for each version, like so: alias dbd747='export DBI_DSN="dbi:Pg:dbname=greg;port=5747"' alias dbd747m='export POSTGRES_LIB=/home/greg/pg747/lib POSTGRES_INCLUDE=/home/greg/pg747/include POSTGRES_DATA=/home/greg/pg747' This allows for quick testing of each combination: > dbd747m > dbd747 > perl Makefile.PL > make test (check output for any errors) > dbd739 > make test > dbd802 > make test > dbd739m > perl Makefile.PL > make test > dbd727 > make test > dbd802 > make test etc... It's also a good idea to test the current HEAD version of Postgres in your tests: this can detect changes nice and early. See the testallversions.tmp.pl file for one way to automate this. In addition to different versions of Postgres, it's a good idea to test a few versions of DBI: this has caught problems in the past. You'll basically need to install the different versions of DBI into different directories, then adjust PERL5LIB with aliases: alias dbi156='export PERL5LIB=/home/greg/perl/dbi156/lib/perl5/site_perl/5.10.0/i686-linux' alias dbi157='export PERL5LIB=/home/greg/perl/dbi157/lib/perl5/site_perl/5.10.0/i686-linux' Different encoding should also be tested: a good one for flushing out problems is BIG5, as it is not supported as a server encoding, only a client one. The simplest way to do this is to export the PGCLIENTENCODING variable to 'BIG5' before running the tests. * Using splint Another great program to use is splint, which is a "tool for statically checking C programs for security vulnerabilities and common programming mistakes." It can be found at http://www.splint.org/ It is typically run against a single C file, in our case, dbdimp.c and the generated Pg.c file. This is a very finicky tool. There is a "splint" target in the Makefile. There are three challenges to using splint: 1) Getting it to work in the first place. As the Makefile.PL section says, you need at least version 3.1.2. You also need to include all the relevant files, which Makefile.PL should do for you. Note that 'make splint' expects the TMP environment variable to be set to a writeable directory. 2) Limiting the amount of results. splint is extremely verbose, so one must usually limit what sort of things are returned. Again, the Makefile.PL has a partial list. 3) Figuring out the real problems. Again, splint's verbosity takes some getting used to, as does interpreting its output, and deciding what is really a problem and what is not. * Using valgrind We've not gotten valgrind to work against DBD::Pg, but would love to. Please email the list if you manage to do so! * Using Devel::Cover Another handy tool is the module Devel::Cover. While not totally useful as it only tests direct perl modules, it is good at giving Pg.pm the once-over. To use, install it, then run: cover -delete HARNESS_PERL_SWITCHES=-MDevel::Cover make test The tests will take much longer than usual. When done, run a simple cover then check out the coverage.html file inside the cover_db directory. * Using Devel::DProf This module is good for finding bottlenecks in the C portion of the code. Generally, you create a small test file that does heavy looping over some methods of interest, and then run it with: perl -d:DProf testfile.pl Then view the results with: dprofpp * Using Devel::NYTProf Another nice Perl-level profiler. To use: perl -d:NYTProf testfile.pl Then run: nytprofhtml and check out the generated HTML files. =============== == Debugging == =============== In addition to the Heavy Testing section, there are some simple aids to debugging. * Testing file It is helpful to have a standard file (e.g. ping.test.tmp) which contains some connection information and allows to easily stick in a piece of code for testing. It should run "make" to make sure everything is up to date. Here's the top of one such file: #!perl -w BEGIN { my $out = `make 2>&1`; if ($out =~ /^\w+\.[cx]s?:\d+:/ms or $out =~ /^Error/ms) { for (split /\n/ => $out) { print "MAKE ERROR: $_\n" if /^[\w\.]+:/; } exit; } use lib ".", "blib/lib", "blib/arch"; } END { print "End ping.test\n"; } BEGIN { print "Begin ping.test\n"; } use strict; use warnings; use Data::Dumper; $Data::Dumper::Deepcopy=1; use DBD::Pg; use DBI qw(:sql_types); $|=1; select((select(STDERR),$|=1)[0]); use vars qw($dbh $SQL $sql $sth $count $version $info $result $id $val); my $trace = shift || 0; my $dv = $DBI::VERSION; print "DBI version: $dv\n"; my $pv = $DBD::Pg::VERSION; print "DBD::Pg version: $pv\n"; my $DSN = $ENV{DBI_DSN}; $dbh = DBI->connect($DSN, $ENV{DBI_USER}, '', {AutoCommit=>0, RaiseError=>1, PrintError=>1}); my $VER = $dbh->{pg_server_version}; my $pgver = $dbh->{pg_lib_version}; print "Connected to $DSN\nServer version: $VER\nCompiled version: $pgver\n"; $dbh->trace($trace); __END__ Once you have completed a test, just put it below the __END__ line in case you ever need to use it again someday. Note that the first argument to this script is the trace level. Bumping the trace level to 10 can be very helpful. If it is not helpful, consider adding some debugging statements to dbdimp.c to make it so! * Coredumps If you get a coredump, you can use the "gdb" utility to see what happened. Here's a 10-second tutorial. If "core" is the name of the core file, just use "gdb perl core", then issue a "bt" command at the gdb prompt. This will run a backtrace and give you an idea of what is causing the problem. * For really low-level debugging from the Postgres side, you can use pg_server_trace() function. * The perl debugger can also be helpful (perl -d ping.test.tmp). * Don't forget about the PostgreSQL server logs either, when investigating matters. ================ == Test Files == ================ The test files are an important part of the module. Much work has gone into making the tests as complete, thorough, and clean as possible. Please try to follow these guidelines when developing: * Whenever you add a new feature, no matter how minor, add a test. Better yet, add many tests to make sure that it not only works correctly, but that it breaks when it is supposed to (e.g. when it is fed the wrong output). Try to conceive of every possible way your feature will be used and mis-used. Consider the effects of older versions of Perl, DBI, and/or Postgres. * If someone files a bug report that is not revealed by a test, please add a new test for it, no matter how simple the fix maybe, or how stupid the bug is. * Don't create a new test file unless necessary - use the existing ones whenever possible. Most things can fit in 03dbmethod.t (database handle methods) or 03smethod.t (statement handle methods). If all else fails, consider using the 04misc.t test. New files should generally be created for a bunch of related tests that do not easily fit into the current listings. * If you do create a new test, keep the name short, start it with a number, and use an existing test as a template. * Tests should be as "standalone" as possible. Most will call dbdpg_test_setup.pl to automatically setup the test table used. It's a good idea to delete any objects your test itself creates. Objects should be created as "temporary" whenever possible. Things should be always have a name starting with "dbd_pg_test". * Don't call DBI->connect inside of your tests, but use connect_database() from the dbdpg_test_setup.pl file instead. If you don't want it to blow away and recreate the current test table and other objects, use connect_database({nosetup => 1}). * Use the standard format for tests, and always provide an appropriate output text. Abbreviations are encouraged, but be consistent throughout the file. * Make sure to test on different versions of PostgreSQL, DBI, and Perl. Use the SKIP tag with an appropriate message if a test does not work on a particular version of something (see 20savepoints.t for an example). * To run a single test, use: prove --blib . -v t/testname.t ===================== == Version Numbers == ===================== Version numbers follow the Postgres convention: major, minor, and revision. (Note: older versions of DBD::Pg used a two-number system up until version 1.49, after which it switched to 2.0.0). The major number should very, very rarely change, and is saved for the truly major changes (e.g. those that may cause backwards compatibility problems). The minor revision is used to indicate a change in functionality, new features, etc. The revision number is used for small tweaks and bug fixes, and must be completely compatible with the version before it. Beta versions (aka release candidates) are the version with an underscore at the end of it. The tells CPAN not to consider this a "real" release. For example, if the upcoming release is 2.2.4, the first release candidate would be 2.2.3_1. A second would be 2.2.3_2 etc. Version numbers are currently set in six files: README (one place, two if a beta version) Pg.pm (two places) Changes Makefile.PL META.yml (three places) lib/Bundle/DBD/Pg.pm =============== == New Files == =============== If you are adding a new file to the distribution (and this should be a rare event), please check that you have done the following items: * Created a standard header for the file, with a (dollar sign)Id(dollar sign) * Added it to git via 'git add filename' and git commit filename' * Added it to the MANIFEST file * Added it to Makefile.PL if needed, to make sure all build dependencies are met * Updated/created necessary tests for it * Added it to the "File List" section above. ================= == New Methods == ================= New methods and attribute names should be short and descriptive. If they are "visible", please make sure they begin with a "pg_" prefix. If you feel they should not have this prefix, make your case on the dbi-dev list. ========================== == Making a New Release == ========================== This is a comprehensive checklist of all the steps required to release a new version, whether beta or regular. It is assumed you are very familiar with the other sections referenced herein (indicated with **) * Test on variety of versions (see ** Heavy Testing), including the optional tests. * Make sure everything is up to date in git (git status) * Update the versions (see ** Version Numbers) in README, Pg.pm (2 places!), Makefile.PL, lib/Bundle/DBD/Pg.pm, META.yml (3 places!), and Changes. Run the t/00_release.t file to double check you got everything. * If a final version, put the release date into the Changes file. * If a beta version, please put a large warning at the top of the README file. Here is a sample: =================================================== WARNING!! THIS IS A TEST VERSION (2.4.1_2) AND SHOULD BE USED FOR TESTING PURPOSES ONLY. PLEASE USE A STABLE VERSION (no underscore) BY VISITING: http://search.cpan.org/dist/DBD-Pg/ =================================================== * If not a beta version, remove the above warning from the README if it exists. * Completely update the Changes file The best way to do this (other than doing it as you go along) is to check the git logs, by running a diff against the last-released version. * Update the documentation Make sure that anything new has been documented properly, usually as POD inside of Pg.pm. A good way to do this is to use the tests in 99_pod.t - they will run automatically as part of the test suite if the right modules are installed. * Run "perl Makefile.PL" * Run "make dist". Double check that the tarball created has the correct version name. * Run "make distcheck". This will show you a list of all files that are in the current directory but not inside the MANIFEST file (or the MANIFEST.SKIP file). If there are any new files here that should be part of the distribution, add them to the MANIFEST file, commit your changes, and then re-run. Note that files ending in ".tmp" are currently skipped, so this is a good extension for any miscellaneous files you have that use often (e.g. libpq-fe.h.tmp) * Run "make skipcheck". This will show you a list of files that will NOT be packed into the release tarball. Make sure there is nothing important here. * Update the SIGNATURE file with Module::Signature (e.g. make signature) * Run "make disttest". This unpacks the tarball, then runs "make" and "make test" on it. You may also want to remove the directory it creates later by using "make realclean" * Make a new git tag: git tag -u 01234abc 1.2.3 -n "Version 1.2.3, released April 1, 2015" In the example above, 01234abc is your pgp shortid and 1.2.3 is the new version number. * Make checksums Generate md5 and sha1 checksums of the tarball. Include this in your emails. * Test it out Download the tarball to a completely different system, unpack and test it. * Announce to the "internal" lists dbd-pg@perl.org pgsql-interfaces@postgresql.org * Upload to CPAN and test. You'll need the pause account password. The interface is fairly straightforward. Once it is loaded, wait for it to appear on the main DBD::Pg page and then test that the file has the same checksums. * Commit the SIGNATURE file. Remember the git commit hash given, and add that to the Changes files. Then commit the Changes file. * Announce to the "public" lists dbd-pg@perl.org pgsql-interfaces@postgresql.org dbi-users@perl.org, dbi-dev@perl.org, dbi-announce@perl.org The format for DBI announcements: To: dbi-announce@perl.org Cc: dbi-users@perl.org Reply-to: dbi-users@perl.org Subject line: Name of module, version Short note of changes, link to CPAN directory. Checksums for the file. * Post to pgsql-announce@postgresql.org if this is a major or important version. * Post to the "PostgreSQL news" On the main page, there is a link named "Submit News" which points to: http://www.postgresql.org/about/submitnews The content should be roughly the same as the announcement. * PostgreSQL weekly news summary The maintainers of the weekly news are usually pretty good about catching the update and adding it in. If not, bug them. http://www.postgresql.org/community/weeklynews/ * Tell Greg to post on PlanetPostgresql. * If a non-beta, clean out any CPAN bugs, including going back and marking resolved bugs with this new version, once it appears in the choices (takes a day or two for the version to appear as a choice in the pulldown). * Check the CPAN testers report a few days after the PAUSE upload: http://www.cpantesters.org/distro/D/DBD-Pg.html * Update this file based on your experiences!! ===================== == Tips and Tricks == ===================== Also known as, the section to put things that don't fit anywhere else. Anything that may make life easier for other developers can go here. * Temporary tables We do not use temporary tables in most of our tests because they are not persistent across tests, they mess up the schema testing, and they are not compatible with the foreign key testing. But do try and use them whenever possible. * "turnstep" in the cvs/svn/git logs is Greg Sabino Mullane, greg@turnstep.com. * Use a "tmp" extension for files you keep around in the dbdpg directory, but don't want to show up when you do a "git status". They are also ignored by make dist. * Commit each file individually, unless the log message is *really* identical across all committed files (which is rare). Always give a good description of the exact changes made : assume that the log will be read independently of a diff. * Don't forget to test for memory leaks, particularly if you are working with the more complicated sections of dbdimp.c. For a quick check, enter a loop, then watch the memory size using the top tool. Here's a quick checker: $dbh->{pg_server_prepare} = 1; $dbh->{pg_direct} = 1; $dbh->do("CREATE TEMP TABLE leaktester(a int, b numeric(10,2), c text)"); $sth{'plain'} = $dbh->prepare("SELECT * from leaktester"); $sth{'place'} = $dbh->prepare("INSERT INTO leaktester(a,b,c) VALUES (?,?,?)"); my $loop = 1; while (1) { $sth{plain}->execute; $dbh->do("SELECT 123"); $dbh->quote(qq{Pi''zza!!"abc}); $sth->{pg_server_prepare}=1; $sth{place}->execute(1,2,"abc"); $sth->{pg_server_prepare}=0; $sth{place}->execute(1,2,"abc"); $sth->{pg_server_prepare}=1; $sth = $dbh->prepare("SELECT 123, ?"); $sth->bind_param(1,1,SQL_INTEGER); $sth->execute(1); $sth->finish(); $info = $dbh->selectall_arrayref("SELECT 123,456"); select(undef,undef,undef,0.1); exit if $loop++ > 10000; } =============== == Resources == =============== The primary resource is the mailing list, where the developers live. Other resources depend on the subject: * DBD::Pg The canonical URL: http://search.cpan.org/dist/DBD-Pg/ * CPAN::Reporter test results: http://cpantesters.perl.org/show/DBD-Pg.html * DBI The DBI developers list: http://lists.perl.org/showlist.cgi?name=dbi-dev The DBI users list: http://lists.perl.org/showlist.cgi?name=dbi-users The DBI announcement list: http://lists.perl.org/showlist.cgi?name=dbi-announce The latest DBI: http://search.cpan.org/dist/DBI/ The source code of other DBDs can be a useful tool as well. * Postgres A good source for general questions on libpq and similar things is the pgsql-hackers list. Having a copy of the Postgres source code is invaluable as well. Using a tool like glimpse or ctags is handy to find those obscure libpq functions quickly. You also may want to keep the libpq documentation handy. All of the Postgres mailing lists: http://www.postgresql.org/community/lists/ A great source for searching the pg documentation and mailing lists is: http://www.pgsql.ru/db/pgsearch/ which allows you to limit the search by version: very helpful as we support multiple versions of PostgreSQL. There are many ways to search the Postgres mailing lists: http://postgresql.markmail.org/ http://www.nabble.com/PostgreSQL-f759.html http://archives.postgresql.org/ http://groups.google.com/ (add group:pgsql.*) * Perl Besides a good general understanding of Perl, it helps to learn a little bit about XS: perldoc perlapi perldoc perlclib perldoc perlguts perldoc perlxstut perldoc perlxs This is the module that does all the introductory magic: perldoc ExtUtils::MakeMaker The all important testing suite: perldoc Test perldoc Test::Harness perldoc Test::Simple perldoc Test::More perldoc Test::Pod perldoc Test::Pod::Coverage perldoc Test::YAML::Meta Other important modules: perldoc Devel::Cover perldoc Module::Signature perldoc Perl::Critic perldoc DBI::Profile Also see perldoc DBI::DBD. It's fairly old and incomplete, but still useful. DBD-Pg-2.19.3/Pg.xs0000644000076400007640000004314311754277067012154 0ustar greggreg/* Copyright (c) 2000-2012 Greg Sabino Mullane and others: see the Changes file Portions Copyright (c) 1997-2000 Edmund Mergl Portions Copyright (c) 1994-1997 Tim Bunce You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. */ #include "Pg.h" #ifdef _MSC_VER #define strncasecmp(a,b,c) _strnicmp((a),(b),(c)) #endif MODULE = DBD::Pg PACKAGE = DBD::Pg I32 constant(name=Nullch) char *name PROTOTYPE: ALIAS: PG_ABSTIME = 702 PG_ABSTIMEARRAY = 1023 PG_ACLITEM = 1033 PG_ACLITEMARRAY = 1034 PG_ANY = 2276 PG_ANYARRAY = 2277 PG_ANYELEMENT = 2283 PG_ANYENUM = 3500 PG_ANYNONARRAY = 2776 PG_BIT = 1560 PG_BITARRAY = 1561 PG_BOOL = 16 PG_BOOLARRAY = 1000 PG_BOX = 603 PG_BOXARRAY = 1020 PG_BPCHAR = 1042 PG_BPCHARARRAY = 1014 PG_BYTEA = 17 PG_BYTEAARRAY = 1001 PG_CHAR = 18 PG_CHARARRAY = 1002 PG_CID = 29 PG_CIDARRAY = 1012 PG_CIDR = 650 PG_CIDRARRAY = 651 PG_CIRCLE = 718 PG_CIRCLEARRAY = 719 PG_CSTRING = 2275 PG_CSTRINGARRAY = 1263 PG_DATE = 1082 PG_DATEARRAY = 1182 PG_FDW_HANDLER = 3115 PG_FLOAT4 = 700 PG_FLOAT4ARRAY = 1021 PG_FLOAT8 = 701 PG_FLOAT8ARRAY = 1022 PG_GTSVECTOR = 3642 PG_GTSVECTORARRAY = 3644 PG_INET = 869 PG_INETARRAY = 1041 PG_INT2 = 21 PG_INT2ARRAY = 1005 PG_INT2VECTOR = 22 PG_INT2VECTORARRAY = 1006 PG_INT4 = 23 PG_INT4ARRAY = 1007 PG_INT8 = 20 PG_INT8ARRAY = 1016 PG_INTERNAL = 2281 PG_INTERVAL = 1186 PG_INTERVALARRAY = 1187 PG_LANGUAGE_HANDLER = 2280 PG_LINE = 628 PG_LINEARRAY = 629 PG_LSEG = 601 PG_LSEGARRAY = 1018 PG_MACADDR = 829 PG_MACADDRARRAY = 1040 PG_MONEY = 790 PG_MONEYARRAY = 791 PG_NAME = 19 PG_NAMEARRAY = 1003 PG_NUMERIC = 1700 PG_NUMERICARRAY = 1231 PG_OID = 26 PG_OIDARRAY = 1028 PG_OIDVECTOR = 30 PG_OIDVECTORARRAY = 1013 PG_OPAQUE = 2282 PG_PATH = 602 PG_PATHARRAY = 1019 PG_PG_ATTRIBUTE = 75 PG_PG_CLASS = 83 PG_PG_NODE_TREE = 194 PG_PG_PROC = 81 PG_PG_TYPE = 71 PG_POINT = 600 PG_POINTARRAY = 1017 PG_POLYGON = 604 PG_POLYGONARRAY = 1027 PG_RECORD = 2249 PG_RECORDARRAY = 2287 PG_REFCURSOR = 1790 PG_REFCURSORARRAY = 2201 PG_REGCLASS = 2205 PG_REGCLASSARRAY = 2210 PG_REGCONFIG = 3734 PG_REGCONFIGARRAY = 3735 PG_REGDICTIONARY = 3769 PG_REGDICTIONARYARRAY = 3770 PG_REGOPER = 2203 PG_REGOPERARRAY = 2208 PG_REGOPERATOR = 2204 PG_REGOPERATORARRAY = 2209 PG_REGPROC = 24 PG_REGPROCARRAY = 1008 PG_REGPROCEDURE = 2202 PG_REGPROCEDUREARRAY = 2207 PG_REGTYPE = 2206 PG_REGTYPEARRAY = 2211 PG_RELTIME = 703 PG_RELTIMEARRAY = 1024 PG_SMGR = 210 PG_TEXT = 25 PG_TEXTARRAY = 1009 PG_TID = 27 PG_TIDARRAY = 1010 PG_TIME = 1083 PG_TIMEARRAY = 1183 PG_TIMESTAMP = 1114 PG_TIMESTAMPARRAY = 1115 PG_TIMESTAMPTZ = 1184 PG_TIMESTAMPTZARRAY = 1185 PG_TIMETZ = 1266 PG_TIMETZARRAY = 1270 PG_TINTERVAL = 704 PG_TINTERVALARRAY = 1025 PG_TRIGGER = 2279 PG_TSQUERY = 3615 PG_TSQUERYARRAY = 3645 PG_TSVECTOR = 3614 PG_TSVECTORARRAY = 3643 PG_TXID_SNAPSHOT = 2970 PG_TXID_SNAPSHOTARRAY = 2949 PG_UNKNOWN = 705 PG_UUID = 2950 PG_UUIDARRAY = 2951 PG_VARBIT = 1562 PG_VARBITARRAY = 1563 PG_VARCHAR = 1043 PG_VARCHARARRAY = 1015 PG_VOID = 2278 PG_XID = 28 PG_XIDARRAY = 1011 PG_XML = 142 PG_XMLARRAY = 143 PG_ASYNC = 1 PG_OLDQUERY_CANCEL = 2 PG_OLDQUERY_WAIT = 4 CODE: if (0==ix) { if (!name) { name = GvNAME(CvGV(cv)); } croak("Unknown DBD::Pg constant '%s'", name); } else { RETVAL = ix; } OUTPUT: RETVAL INCLUDE: Pg.xsi # ------------------------------------------------------------ # db functions # ------------------------------------------------------------ MODULE=DBD::Pg PACKAGE = DBD::Pg::db SV* quote(dbh, to_quote_sv, type_sv=Nullsv) SV* dbh SV* to_quote_sv SV* type_sv CODE: { D_imp_dbh(dbh); SvGETMAGIC(to_quote_sv); /* Reject references other than overloaded objects (presumed stringifiable) and arrays (will make a PostgreSQL array). */ if (SvROK(to_quote_sv) && !SvAMAGIC(to_quote_sv)) { if (SvTYPE(SvRV(to_quote_sv)) != SVt_PVAV) croak("Cannot quote a reference"); to_quote_sv = pg_stringify_array(to_quote_sv, ",", imp_dbh->pg_server_version); } /* Null is always returned as "NULL", so we can ignore any type given */ if (!SvOK(to_quote_sv)) { RETVAL = newSVpvn("NULL", 4); } else { sql_type_info_t *type_info; char *quoted; const char *to_quote; STRLEN retlen=0; STRLEN len=0; /* If no valid type is given, we default to unknown */ if (!type_sv || !SvOK(type_sv)) { type_info = pg_type_data(PG_UNKNOWN); } else { if SvMAGICAL(type_sv) (void)mg_get(type_sv); if (SvNIOK(type_sv)) { type_info = sql_type_data(SvIV(type_sv)); } else { SV **svp; if ((svp = hv_fetch((HV*)SvRV(type_sv),"pg_type", 7, 0)) != NULL) { type_info = pg_type_data(SvIV(*svp)); } else if ((svp = hv_fetch((HV*)SvRV(type_sv),"type", 4, 0)) != NULL) { type_info = sql_type_data(SvIV(*svp)); } else { type_info = NULL; } } if (!type_info) { warn("Unknown type %" IVdf ", defaulting to UNKNOWN",SvIV(type_sv)); type_info = pg_type_data(PG_UNKNOWN); } } /* At this point, type_info points to a valid struct, one way or another */ if (SvMAGICAL(to_quote_sv)) (void)mg_get(to_quote_sv); to_quote = SvPV(to_quote_sv, len); /* Need good debugging here */ quoted = type_info->quote(to_quote, len, &retlen, imp_dbh->pg_server_version >= 80100 ? 1 : 0); RETVAL = newSVpvn(quoted, retlen); if (SvUTF8(to_quote_sv)) /* What about overloaded objects? */ SvUTF8_on(RETVAL); Safefree (quoted); } } OUTPUT: RETVAL # ------------------------------------------------------------ # database level interface PG specific # ------------------------------------------------------------ MODULE = DBD::Pg PACKAGE = DBD::Pg::db void state(dbh) SV *dbh CODE: D_imp_dbh(dbh); ST(0) = strEQ(imp_dbh->sqlstate,"00000") ? &PL_sv_no : newSVpv(imp_dbh->sqlstate, 5); void do(dbh, statement, attr=Nullsv, ...) SV * dbh char * statement SV * attr PROTOTYPE: $$;$@ CODE: { int retval; int asyncflag = 0; if (statement[0] == '\0') { /* Corner case */ XST_mUNDEF(0); return; } if (attr && SvROK(attr) && SvTYPE(SvRV(attr)) == SVt_PVHV) { SV **svp; if ((svp = hv_fetch((HV*)SvRV(attr),"pg_async", 8, 0)) != NULL) { asyncflag = (int)SvIV(*svp); } } if (items < 4) { /* No bind arguments */ /* Quick run via PQexec */ retval = pg_quickexec(dbh, statement, asyncflag); } else { /* We've got bind arguments, so we do the whole prepare/execute route */ imp_sth_t *imp_sth; SV * const sth = dbixst_bounce_method("prepare", 3); if (!SvROK(sth)) XSRETURN_UNDEF; imp_sth = (imp_sth_t*)(DBIh_COM(sth)); if (!dbdxst_bind_params(sth, imp_sth, items-2, ax+2)) XSRETURN_UNDEF; imp_sth->onetime = 1; /* Tells dbdimp.c not to bother preparing this */ imp_sth->async_flag = asyncflag; retval = dbd_st_execute(sth, imp_sth); } if (retval == 0) XST_mPV(0, "0E0"); else if (retval < -1) XST_mUNDEF(0); else XST_mIV(0, retval); } void _ping(dbh) SV * dbh CODE: ST(0) = sv_2mortal(newSViv(dbd_db_ping(dbh))); void getfd(dbh) SV * dbh CODE: int ret; D_imp_dbh(dbh); ret = pg_db_getfd(imp_dbh); ST(0) = sv_2mortal( newSViv( ret ) ); void pg_endcopy(dbh) SV * dbh CODE: ST(0) = (pg_db_endcopy(dbh)!=0) ? &PL_sv_no : &PL_sv_yes; void pg_notifies(dbh) SV * dbh CODE: D_imp_dbh(dbh); ST(0) = pg_db_pg_notifies(dbh, imp_dbh); void pg_savepoint(dbh,name) SV * dbh char * name CODE: D_imp_dbh(dbh); if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh)) warn("savepoint ineffective with AutoCommit enabled"); ST(0) = (pg_db_savepoint(dbh, imp_dbh, name)!=0) ? &PL_sv_yes : &PL_sv_no; void pg_rollback_to(dbh,name) SV * dbh char * name CODE: D_imp_dbh(dbh); if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh)) warn("rollback_to ineffective with AutoCommit enabled"); ST(0) = (pg_db_rollback_to(dbh, imp_dbh, name)!=0) ? &PL_sv_yes : &PL_sv_no; void pg_release(dbh,name) SV * dbh char * name CODE: D_imp_dbh(dbh); if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh)) warn("release ineffective with AutoCommit enabled"); ST(0) = (pg_db_release(dbh, imp_dbh, name)!=0) ? &PL_sv_yes : &PL_sv_no; void pg_lo_creat(dbh, mode) SV * dbh int mode CODE: const unsigned int ret = pg_db_lo_creat(dbh, mode); ST(0) = (ret > 0) ? sv_2mortal(newSVuv(ret)) : &PL_sv_undef; void pg_lo_open(dbh, lobjId, mode) SV * dbh unsigned int lobjId int mode CODE: const int ret = pg_db_lo_open(dbh, lobjId, mode); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_write(dbh, fd, buf, len) SV * dbh int fd char * buf size_t len CODE: const int ret = pg_db_lo_write(dbh, fd, buf, len); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_read(dbh, fd, buf, len) SV * dbh int fd char * buf size_t len PREINIT: SV * const bufsv = SvROK(ST(2)) ? SvRV(ST(2)) : ST(2); int ret; CODE: sv_setpvn(bufsv,"",0); /* Make sure we can grow it safely */ buf = SvGROW(bufsv, len + 1); ret = pg_db_lo_read(dbh, fd, buf, len); if (ret > 0) { SvCUR_set(bufsv, ret); *SvEND(bufsv) = '\0'; sv_setpvn(ST(2), buf, (unsigned)ret); SvSETMAGIC(ST(2)); } ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_lseek(dbh, fd, offset, whence) SV * dbh int fd int offset int whence CODE: const int ret = pg_db_lo_lseek(dbh, fd, offset, whence); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_tell(dbh, fd) SV * dbh int fd CODE: const int ret = pg_db_lo_tell(dbh, fd); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_close(dbh, fd) SV * dbh int fd CODE: ST(0) = (pg_db_lo_close(dbh, fd) >= 0) ? &PL_sv_yes : &PL_sv_no; void pg_lo_unlink(dbh, lobjId) SV * dbh unsigned int lobjId CODE: ST(0) = (pg_db_lo_unlink(dbh, lobjId) >= 1) ? &PL_sv_yes : &PL_sv_no; void pg_lo_import(dbh, filename) SV * dbh char * filename CODE: const unsigned int ret = pg_db_lo_import(dbh, filename); ST(0) = (ret > 0) ? sv_2mortal(newSVuv(ret)) : &PL_sv_undef; void pg_lo_import_with_oid(dbh, filename, lobjId) SV * dbh char * filename unsigned int lobjId CODE: const unsigned int ret = (lobjId==0) ? pg_db_lo_import(dbh, filename) : pg_db_lo_import_with_oid(dbh, filename, lobjId); ST(0) = (ret > 0) ? sv_2mortal(newSVuv(ret)) : &PL_sv_undef; void pg_lo_export(dbh, lobjId, filename) SV * dbh unsigned int lobjId char * filename CODE: ST(0) = (pg_db_lo_export(dbh, lobjId, filename) >= 1) ? &PL_sv_yes : &PL_sv_no; void lo_creat(dbh, mode) SV * dbh int mode CODE: const unsigned int ret = pg_db_lo_creat(dbh, mode); ST(0) = (ret > 0) ? sv_2mortal(newSVuv(ret)) : &PL_sv_undef; void lo_open(dbh, lobjId, mode) SV * dbh unsigned int lobjId int mode CODE: const int ret = pg_db_lo_open(dbh, lobjId, mode); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void lo_write(dbh, fd, buf, len) SV * dbh int fd char * buf size_t len CODE: const int ret = pg_db_lo_write(dbh, fd, buf, len); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void lo_read(dbh, fd, buf, len) SV * dbh int fd char * buf size_t len PREINIT: SV * const bufsv = SvROK(ST(2)) ? SvRV(ST(2)) : ST(2); int ret; CODE: sv_setpvn(bufsv,"",0); /* Make sure we can grow it safely */ buf = SvGROW(bufsv, len + 1); ret = pg_db_lo_read(dbh, fd, buf, len); if (ret > 0) { SvCUR_set(bufsv, ret); *SvEND(bufsv) = '\0'; sv_setpvn(ST(2), buf, (unsigned)ret); SvSETMAGIC(ST(2)); } ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void lo_lseek(dbh, fd, offset, whence) SV * dbh int fd int offset int whence CODE: const int ret = pg_db_lo_lseek(dbh, fd, offset, whence); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void lo_tell(dbh, fd) SV * dbh int fd CODE: const int ret = pg_db_lo_tell(dbh, fd); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void lo_close(dbh, fd) SV * dbh int fd CODE: ST(0) = (pg_db_lo_close(dbh, fd) >= 0) ? &PL_sv_yes : &PL_sv_no; void lo_unlink(dbh, lobjId) SV * dbh unsigned int lobjId CODE: ST(0) = (pg_db_lo_unlink(dbh, lobjId) >= 1) ? &PL_sv_yes : &PL_sv_no; void lo_import(dbh, filename) SV * dbh char * filename CODE: const unsigned int ret = pg_db_lo_import(dbh, filename); ST(0) = (ret > 0) ? sv_2mortal(newSVuv(ret)) : &PL_sv_undef; void lo_export(dbh, lobjId, filename) SV * dbh unsigned int lobjId char * filename CODE: ST(0) = (pg_db_lo_export(dbh, lobjId, filename) >= 1) ? &PL_sv_yes : &PL_sv_no; void pg_putline(dbh, buf) SV * dbh char * buf CODE: ST(0) = (pg_db_putline(dbh, buf)!=0) ? &PL_sv_no : &PL_sv_yes; void putline(dbh, buf) SV * dbh char * buf CODE: ST(0) = (pg_db_putline(dbh, buf)!=0) ? &PL_sv_no : &PL_sv_yes; void pg_getline(dbh, buf, len) PREINIT: SV *bufsv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); INPUT: SV * dbh unsigned int len char * buf CODE: int ret; bufsv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); sv_setpvn(bufsv,"",0); /* Make sure we can grow it safely */ buf = SvGROW(bufsv, 3); if (len > 3) buf = SvGROW(bufsv, len); ret = pg_db_getline(dbh, bufsv, (int)len); sv_setpv((SV*)ST(1), buf); SvSETMAGIC(ST(1)); ST(0) = (-1 != ret) ? &PL_sv_yes : &PL_sv_no; I32 pg_getcopydata(dbh, dataline) INPUT: SV * dbh CODE: RETVAL = pg_db_getcopydata(dbh, SvROK(ST(1)) ? SvRV(ST(1)) : ST(1), 0); OUTPUT: RETVAL I32 pg_getcopydata_async(dbh, dataline) INPUT: SV * dbh CODE: RETVAL = pg_db_getcopydata(dbh, SvROK(ST(1)) ? SvRV(ST(1)) : ST(1), 1); OUTPUT: RETVAL I32 pg_putcopydata(dbh, dataline) INPUT: SV * dbh SV * dataline CODE: RETVAL = pg_db_putcopydata(dbh, dataline); OUTPUT: RETVAL I32 pg_putcopyend(dbh) INPUT: SV * dbh CODE: RETVAL = pg_db_putcopyend(dbh); OUTPUT: RETVAL void getline(dbh, buf, len) PREINIT: SV *bufsv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); INPUT: SV * dbh unsigned int len char * buf CODE: int ret; sv_setpvn(bufsv,"",0); /* Make sure we can grow it safely */ buf = SvGROW(bufsv, 3); if (len > 3) buf = SvGROW(bufsv, len); ret = pg_db_getline(dbh, bufsv, (int)len); sv_setpv((SV*)ST(1), buf); SvSETMAGIC(ST(1)); ST(0) = (-1 != ret) ? &PL_sv_yes : &PL_sv_no; void endcopy(dbh) SV * dbh CODE: ST(0) = (-1 != pg_db_endcopy(dbh)) ? &PL_sv_yes : &PL_sv_no; void pg_server_trace(dbh,fh) SV * dbh FILE * fh CODE: pg_db_pg_server_trace(dbh,fh); void pg_server_untrace(dbh) SV * dbh CODE: pg_db_pg_server_untrace(dbh); void _pg_type_info (type_sv=Nullsv) SV* type_sv CODE: { int type_num = 0; if (type_sv && SvOK(type_sv)) { sql_type_info_t *type_info; if SvMAGICAL(type_sv) (void)mg_get(type_sv); type_info = pg_type_data(SvIV(type_sv)); type_num = type_info ? type_info->type.sql : SQL_VARCHAR; } ST(0) = sv_2mortal( newSViv( type_num ) ); } #if PGLIBVERSION >= 80000 void pg_result(dbh) SV * dbh CODE: int ret; D_imp_dbh(dbh); ret = pg_db_result(dbh, imp_dbh); if (ret == 0) XST_mPV(0, "0E0"); else if (ret < -1) XST_mUNDEF(0); else XST_mIV(0, ret); void pg_ready(dbh) SV *dbh CODE: D_imp_dbh(dbh); ST(0) = sv_2mortal(newSViv(pg_db_ready(dbh, imp_dbh))); void pg_cancel(dbh) SV *dbh CODE: D_imp_dbh(dbh); ST(0) = pg_db_cancel(dbh, imp_dbh) ? &PL_sv_yes : &PL_sv_no; #endif # -- end of DBD::Pg::db # ------------------------------------------------------------ # statement level interface PG specific # ------------------------------------------------------------ MODULE = DBD::Pg PACKAGE = DBD::Pg::st void state(sth) SV *sth; CODE: D_imp_sth(sth); D_imp_dbh_from_sth; ST(0) = strEQ(imp_dbh->sqlstate,"00000") ? &PL_sv_no : newSVpv(imp_dbh->sqlstate, 5); void pg_ready(sth) SV *sth CODE: D_imp_sth(sth); D_imp_dbh_from_sth; ST(0) = sv_2mortal(newSViv(pg_db_ready(sth, imp_dbh))); void pg_cancel(sth) SV *sth CODE: D_imp_sth(sth); ST(0) = pg_db_cancel_sth(sth, imp_sth) ? &PL_sv_yes : &PL_sv_no; void cancel(sth) SV *sth CODE: D_imp_sth(sth); ST(0) = dbd_st_cancel(sth, imp_sth) ? &PL_sv_yes : &PL_sv_no; #if PGLIBVERSION >= 80000 void pg_result(sth) SV * sth CODE: int ret; D_imp_sth(sth); D_imp_dbh_from_sth; ret = pg_db_result(sth, imp_dbh); if (ret == 0) XST_mPV(0, "0E0"); else if (ret < -1) XST_mUNDEF(0); else XST_mIV(0, ret); #endif # end of Pg.xs DBD-Pg-2.19.3/quote.h0000644000076400007640000000256111642756716012536 0ustar greggreg char * null_quote(const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_string(const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_bytea(char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_sql_binary(char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_bool(const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_integer(const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_int(const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_float(char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_name(const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_geom(const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_path(const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_circle(const char *string, STRLEN len, STRLEN *retlen, int estring); void dequote_char(const char *string, STRLEN *retlen, int estring); void dequote_string(const char *string, STRLEN *retlen, int estring); void dequote_bytea(char *string, STRLEN *retlen, int estring); void dequote_sql_binary(char *string, STRLEN *retlen, int estring); void dequote_bool(char *string, STRLEN *retlen, int estring); void null_dequote(const char *string, STRLEN *retlen, int estring); bool is_keyword(const char *string); DBD-Pg-2.19.3/lib/0000755000076400007640000000000012014741170011750 5ustar greggregDBD-Pg-2.19.3/lib/Bundle/0000755000076400007640000000000012014741170013161 5ustar greggregDBD-Pg-2.19.3/lib/Bundle/DBD/0000755000076400007640000000000012014741170013552 5ustar greggregDBD-Pg-2.19.3/lib/Bundle/DBD/Pg.pm0000644000076400007640000000104112014725537014463 0ustar greggreg package Bundle::DBD::Pg; use strict; use warnings; $VERSION = '2.19.3'; 1; __END__ =head1 NAME Bundle::DBD::Pg - A bundle to install all DBD::Pg related modules =head1 SYNOPSIS C =head1 CONTENTS DBI DBD::Pg =head1 DESCRIPTION This bundle includes all the modules needed for DBD::Pg (the Perl interface to the Postgres database system). Please feel free to ask for help or report any problems to dbd-pg@perl.org. =cut =head1 AUTHOR Greg Sabino Mullane EFE DBD-Pg-2.19.3/Pg.pm0000644000076400007640000050544212014725563012130 0ustar greggreg# -*-cperl-*- # # Copyright (c) 2002-2012 Greg Sabino Mullane and others: see the Changes file # Portions Copyright (c) 2002 Jeffrey W. Baker # Portions Copyright (c) 1997-2001 Edmund Mergl # Portions Copyright (c) 1994-1997 Tim Bunce # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use 5.006001; { package DBD::Pg; use version; our $VERSION = qv('2.19.3'); use DBI (); use DynaLoader (); use Exporter (); use vars qw(@ISA %EXPORT_TAGS $err $errstr $sqlstate $drh $dbh $DBDPG_DEFAULT @EXPORT); @ISA = qw(DynaLoader Exporter); %EXPORT_TAGS = ( async => [qw(PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT)], pg_types => [qw( PG_ABSTIME PG_ABSTIMEARRAY PG_ACLITEM PG_ACLITEMARRAY PG_ANY PG_ANYARRAY PG_ANYELEMENT PG_ANYENUM PG_ANYNONARRAY PG_BIT PG_BITARRAY PG_BOOL PG_BOOLARRAY PG_BOX PG_BOXARRAY PG_BPCHAR PG_BPCHARARRAY PG_BYTEA PG_BYTEAARRAY PG_CHAR PG_CHARARRAY PG_CID PG_CIDARRAY PG_CIDR PG_CIDRARRAY PG_CIRCLE PG_CIRCLEARRAY PG_CSTRING PG_CSTRINGARRAY PG_DATE PG_DATEARRAY PG_FDW_HANDLER PG_FLOAT4 PG_FLOAT4ARRAY PG_FLOAT8 PG_FLOAT8ARRAY PG_GTSVECTOR PG_GTSVECTORARRAY PG_INET PG_INETARRAY PG_INT2 PG_INT2ARRAY PG_INT2VECTOR PG_INT2VECTORARRAY PG_INT4 PG_INT4ARRAY PG_INT8 PG_INT8ARRAY PG_INTERNAL PG_INTERVAL PG_INTERVALARRAY PG_LANGUAGE_HANDLER PG_LINE PG_LINEARRAY PG_LSEG PG_LSEGARRAY PG_MACADDR PG_MACADDRARRAY PG_MONEY PG_MONEYARRAY PG_NAME PG_NAMEARRAY PG_NUMERIC PG_NUMERICARRAY PG_OID PG_OIDARRAY PG_OIDVECTOR PG_OIDVECTORARRAY PG_OPAQUE PG_PATH PG_PATHARRAY PG_PG_ATTRIBUTE PG_PG_CLASS PG_PG_NODE_TREE PG_PG_PROC PG_PG_TYPE PG_POINT PG_POINTARRAY PG_POLYGON PG_POLYGONARRAY PG_RECORD PG_RECORDARRAY PG_REFCURSOR PG_REFCURSORARRAY PG_REGCLASS PG_REGCLASSARRAY PG_REGCONFIG PG_REGCONFIGARRAY PG_REGDICTIONARY PG_REGDICTIONARYARRAY PG_REGOPER PG_REGOPERARRAY PG_REGOPERATOR PG_REGOPERATORARRAY PG_REGPROC PG_REGPROCARRAY PG_REGPROCEDURE PG_REGPROCEDUREARRAY PG_REGTYPE PG_REGTYPEARRAY PG_RELTIME PG_RELTIMEARRAY PG_SMGR PG_TEXT PG_TEXTARRAY PG_TID PG_TIDARRAY PG_TIME PG_TIMEARRAY PG_TIMESTAMP PG_TIMESTAMPARRAY PG_TIMESTAMPTZ PG_TIMESTAMPTZARRAY PG_TIMETZ PG_TIMETZARRAY PG_TINTERVAL PG_TINTERVALARRAY PG_TRIGGER PG_TSQUERY PG_TSQUERYARRAY PG_TSVECTOR PG_TSVECTORARRAY PG_TXID_SNAPSHOT PG_TXID_SNAPSHOTARRAY PG_UNKNOWN PG_UUID PG_UUIDARRAY PG_VARBIT PG_VARBITARRAY PG_VARCHAR PG_VARCHARARRAY PG_VOID PG_XID PG_XIDARRAY PG_XML PG_XMLARRAY )] ); { package DBD::Pg::DefaultValue; sub new { my $self = {}; return bless $self, shift; } } $DBDPG_DEFAULT = DBD::Pg::DefaultValue->new(); Exporter::export_ok_tags('pg_types', 'async'); @EXPORT = qw($DBDPG_DEFAULT PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT PG_BYTEA); require_version DBI 1.52; bootstrap DBD::Pg $VERSION; $err = 0; # holds error code for DBI::err $errstr = ''; # holds error string for DBI::errstr $sqlstate = ''; # holds five character SQLSTATE code $drh = undef; # holds driver handle once initialized ## These two methods are here to allow calling before connect() sub parse_trace_flag { my ($class, $flag) = @_; return (0x7FFFFF00 - 0x08000000) if $flag eq 'DBD'; ## all but the prefix return 0x01000000 if $flag eq 'pglibpq'; return 0x02000000 if $flag eq 'pgstart'; return 0x04000000 if $flag eq 'pgend'; return 0x08000000 if $flag eq 'pgprefix'; return 0x10000000 if $flag eq 'pglogin'; return 0x20000000 if $flag eq 'pgquote'; return DBI::parse_trace_flag($class, $flag); } sub parse_trace_flags { my ($class, $flags) = @_; return DBI::parse_trace_flags($class, $flags); } sub CLONE { $drh = undef; return; } ## Deprecated sub _pg_use_catalog { ## no critic (ProhibitUnusedPrivateSubroutines) return 'pg_catalog.'; } sub driver { return $drh if defined $drh; my($class, $attr) = @_; $class .= '::dr'; $drh = DBI::_new_drh($class, { 'Name' => 'Pg', 'Version' => $VERSION, 'Err' => \$DBD::Pg::err, 'Errstr' => \$DBD::Pg::errstr, 'State' => \$DBD::Pg::sqlstate, 'Attribution' => "DBD::Pg $VERSION by Greg Sabino Mullane and others", }); DBD::Pg::db->install_method('pg_cancel'); DBD::Pg::db->install_method('pg_endcopy'); DBD::Pg::db->install_method('pg_getline'); DBD::Pg::db->install_method('pg_getcopydata'); DBD::Pg::db->install_method('pg_getcopydata_async'); DBD::Pg::db->install_method('pg_notifies'); DBD::Pg::db->install_method('pg_putcopydata'); DBD::Pg::db->install_method('pg_putcopyend'); DBD::Pg::db->install_method('pg_ping'); DBD::Pg::db->install_method('pg_putline'); DBD::Pg::db->install_method('pg_ready'); DBD::Pg::db->install_method('pg_release'); DBD::Pg::db->install_method('pg_result'); ## NOT duplicated below! DBD::Pg::db->install_method('pg_rollback_to'); DBD::Pg::db->install_method('pg_savepoint'); DBD::Pg::db->install_method('pg_server_trace'); DBD::Pg::db->install_method('pg_server_untrace'); DBD::Pg::db->install_method('pg_type_info'); DBD::Pg::st->install_method('pg_cancel'); DBD::Pg::st->install_method('pg_result'); DBD::Pg::st->install_method('pg_ready'); DBD::Pg::db->install_method('pg_lo_creat'); DBD::Pg::db->install_method('pg_lo_open'); DBD::Pg::db->install_method('pg_lo_write'); DBD::Pg::db->install_method('pg_lo_read'); DBD::Pg::db->install_method('pg_lo_lseek'); DBD::Pg::db->install_method('pg_lo_tell'); DBD::Pg::db->install_method('pg_lo_close'); DBD::Pg::db->install_method('pg_lo_unlink'); DBD::Pg::db->install_method('pg_lo_import'); DBD::Pg::db->install_method('pg_lo_import_with_oid'); DBD::Pg::db->install_method('pg_lo_export'); return $drh; } ## end of driver 1; } ## end of package DBD::Pg { package DBD::Pg::dr; use strict; ## Returns an array of formatted database names from the pg_database table sub data_sources { my $drh = shift; my $attr = shift || ''; ## Future: connect to "postgres" when the minimum version we support is 8.0 my $connstring = 'dbname=template1'; if ($ENV{DBI_DSN}) { ($connstring = $ENV{DBI_DSN}) =~ s/dbi:Pg://i; } if (length $attr) { $connstring .= ";$attr"; } my $dbh = DBD::Pg::dr::connect($drh, $connstring) or return; $dbh->{AutoCommit}=1; my $SQL = 'SELECT pg_catalog.quote_ident(datname) FROM pg_catalog.pg_database ORDER BY 1'; my $sth = $dbh->prepare($SQL); $sth->execute() or die $DBI::errstr; $attr and $attr = ";$attr"; my @sources = map { "dbi:Pg:dbname=$_->[0]$attr" } @{$sth->fetchall_arrayref()}; $dbh->disconnect; return @sources; } sub connect { ## no critic (ProhibitBuiltinHomonyms) my ($drh, $dbname, $user, $pass, $attr) = @_; ## Allow "db" and "database" as synonyms for "dbname" $dbname =~ s/\b(?:db|database)\s*=/dbname=/; my $name = $dbname; if ($dbname =~ m{dbname\s*=\s*[\"\']([^\"\']+)}) { $name = "'$1'"; $dbname =~ s/\"/\'/g; } elsif ($dbname =~ m{dbname\s*=\s*([^;]+)}) { $name = $1; } $user = defined($user) ? $user : defined $ENV{DBI_USER} ? $ENV{DBI_USER} : ''; $pass = defined($pass) ? $pass : defined $ENV{DBI_PASS} ? $ENV{DBI_PASS} : ''; my ($dbh) = DBI::_new_dbh($drh, { 'Name' => $dbname, 'Username' => $user, 'CURRENT_USER' => $user, }); # Connect to the database.. DBD::Pg::db::_login($dbh, $dbname, $user, $pass, $attr) or return undef; my $version = $dbh->{pg_server_version}; $dbh->{private_dbdpg}{version} = $version; if ($attr) { if ($attr->{dbd_verbose}) { $dbh->trace('DBD'); } } return $dbh; } sub private_attribute_info { return { }; } } ## end of package DBD::Pg::dr { package DBD::Pg::db; use DBI qw(:sql_types); use strict; sub parse_trace_flag { my ($h, $flag) = @_; return DBD::Pg->parse_trace_flag($flag); } sub prepare { my($dbh, $statement, @attribs) = @_; return undef if ! defined $statement; # Create a 'blank' statement handle: my $sth = DBI::_new_sth($dbh, { 'Statement' => $statement, }); DBD::Pg::st::_prepare($sth, $statement, @attribs) || 0; return $sth; } sub last_insert_id { my ($dbh, $catalog, $schema, $table, $col, $attr) = @_; ## Our ultimate goal is to get a sequence my ($sth, $count, $SQL, $sequence); ## Cache all of our table lookups? Default is yes my $cache = 1; ## Catalog and col are not used $schema = '' if ! defined $schema; $table = '' if ! defined $table; my $cachename = "lii$table$schema"; if (defined $attr and length $attr) { ## If not a hash, assume it is a sequence name if (! ref $attr) { $attr = {sequence => $attr}; } elsif (ref $attr ne 'HASH') { $dbh->set_err(1, 'last_insert_id must be passed a hashref as the final argument'); return undef; } ## Named sequence overrides any table or schema settings if (exists $attr->{sequence} and length $attr->{sequence}) { $sequence = $attr->{sequence}; } if (exists $attr->{pg_cache}) { $cache = $attr->{pg_cache}; } } if (! defined $sequence and exists $dbh->{private_dbdpg}{$cachename} and $cache) { $sequence = $dbh->{private_dbdpg}{$cachename}; } elsif (! defined $sequence) { ## At this point, we must have a valid table name if (! length $table) { $dbh->set_err(1, 'last_insert_id needs at least a sequence or table name'); return undef; } my @args = ($table); ## Make sure the table in question exists and grab its oid my ($schemajoin,$schemawhere) = ('',''); if (length $schema) { $schemajoin = "\n JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)"; $schemawhere = "\n AND n.nspname = ?"; push @args, $schema; } $SQL = "SELECT c.oid FROM pg_catalog.pg_class c $schemajoin\n WHERE relname = ?$schemawhere"; if (! length $schema) { $SQL .= ' AND pg_catalog.pg_table_is_visible(c.oid)'; } $sth = $dbh->prepare_cached($SQL); $count = $sth->execute(@args); if (!defined $count or $count eq '0E0') { $sth->finish(); my $message = qq{Could not find the table "$table"}; length $schema and $message .= qq{ in the schema "$schema"}; $dbh->set_err(1, $message); return undef; } my $oid = $sth->fetchall_arrayref()->[0][0]; $oid =~ /(\d+)/ or die qq{OID was not numeric?!?\n}; $oid = $1; ## This table has a primary key. Is there a sequence associated with it via a unique, indexed column? $SQL = "SELECT a.attname, i.indisprimary, pg_catalog.pg_get_expr(adbin,adrelid)\n". "FROM pg_catalog.pg_index i, pg_catalog.pg_attribute a, pg_catalog.pg_attrdef d\n ". "WHERE i.indrelid = $oid AND d.adrelid=a.attrelid AND d.adnum=a.attnum\n". " AND a.attrelid = $oid AND i.indisunique IS TRUE\n". " AND a.atthasdef IS TRUE AND i.indkey[0]=a.attnum\n". q{ AND d.adsrc ~ '^nextval'}; $sth = $dbh->prepare($SQL); $count = $sth->execute(); if (!defined $count or $count eq '0E0') { $sth->finish(); $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"}); return undef; } my $info = $sth->fetchall_arrayref(); ## We have at least one with a default value. See if we can determine sequences my @def; for (@$info) { next unless $_->[2] =~ /^nextval\(+'([^']+)'::/o; push @$_, $1; push @def, $_; } if (!@def) { $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n}); } ## Tiebreaker goes to the primary keys if (@def > 1) { my @pri = grep { $_->[1] } @def; if (1 != @pri) { $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n}); } @def = @pri; } $sequence = $def[0]->[3]; ## Cache this information for subsequent calls $dbh->{private_dbdpg}{$cachename} = $sequence; } $sth = $dbh->prepare_cached('SELECT currval(?)'); $count = $sth->execute($sequence); return undef if ! defined $count; return $sth->fetchall_arrayref()->[0][0]; } ## end of last_insert_id sub ping { my $dbh = shift; local $SIG{__WARN__} = sub { } if $dbh->FETCH('PrintError'); my $ret = DBD::Pg::db::_ping($dbh); return $ret < 1 ? 0 : $ret; } sub pg_ping { my $dbh = shift; local $SIG{__WARN__} = sub { } if $dbh->FETCH('PrintError'); return DBD::Pg::db::_ping($dbh); } sub pg_type_info { my($dbh,$pg_type) = @_; local $SIG{__WARN__} = sub { } if $dbh->FETCH('PrintError'); my $ret = DBD::Pg::db::_pg_type_info($pg_type); return $ret; } # Column expected in statement handle returned. # table_cat, table_schem, table_name, column_name, data_type, type_name, # column_size, buffer_length, DECIMAL_DIGITS, NUM_PREC_RADIX, NULLABLE, # REMARKS, COLUMN_DEF, SQL_DATA_TYPE, SQL_DATETIME_SUB, CHAR_OCTET_LENGTH, # ORDINAL_POSITION, IS_NULLABLE # The result set is ordered by TABLE_SCHEM, TABLE_NAME and ORDINAL_POSITION. sub column_info { my $dbh = shift; my ($catalog, $schema, $table, $column) = @_; my @search; ## If the schema or table has an underscore or a %, use a LIKE comparison if (defined $schema and length $schema) { push @search, 'n.nspname ' . ($schema =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($schema); } if (defined $table and length $table) { push @search, 'c.relname ' . ($table =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($table); } if (defined $column and length $column) { push @search, 'a.attname ' . ($column =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($column); } my $whereclause = join "\n\t\t\t\tAND ", '', @search; my $schemajoin = 'JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)'; my $remarks = 'pg_catalog.col_description(a.attrelid, a.attnum)'; my $column_def = $dbh->{private_dbdpg}{version} >= 80000 ? 'pg_catalog.pg_get_expr(af.adbin, af.adrelid)' : 'af.adsrc'; my $col_info_sql = qq! SELECT NULL::text AS "TABLE_CAT" , quote_ident(n.nspname) AS "TABLE_SCHEM" , quote_ident(c.relname) AS "TABLE_NAME" , quote_ident(a.attname) AS "COLUMN_NAME" , a.atttypid AS "DATA_TYPE" , pg_catalog.format_type(a.atttypid, NULL) AS "TYPE_NAME" , a.attlen AS "COLUMN_SIZE" , NULL::text AS "BUFFER_LENGTH" , NULL::text AS "DECIMAL_DIGITS" , NULL::text AS "NUM_PREC_RADIX" , CASE a.attnotnull WHEN 't' THEN 0 ELSE 1 END AS "NULLABLE" , $remarks AS "REMARKS" , $column_def AS "COLUMN_DEF" , NULL::text AS "SQL_DATA_TYPE" , NULL::text AS "SQL_DATETIME_SUB" , NULL::text AS "CHAR_OCTET_LENGTH" , a.attnum AS "ORDINAL_POSITION" , CASE a.attnotnull WHEN 't' THEN 'NO' ELSE 'YES' END AS "IS_NULLABLE" , pg_catalog.format_type(a.atttypid, a.atttypmod) AS "pg_type" , '?' AS "pg_constraint" , n.nspname AS "pg_schema" , c.relname AS "pg_table" , a.attname AS "pg_column" , a.attrelid AS "pg_attrelid" , a.attnum AS "pg_attnum" , a.atttypmod AS "pg_atttypmod" , t.typtype AS "_pg_type_typtype" , t.oid AS "_pg_type_oid" FROM pg_catalog.pg_type t JOIN pg_catalog.pg_attribute a ON (t.oid = a.atttypid) JOIN pg_catalog.pg_class c ON (a.attrelid = c.oid) LEFT JOIN pg_catalog.pg_attrdef af ON (a.attnum = af.adnum AND a.attrelid = af.adrelid) $schemajoin WHERE a.attnum >= 0 AND c.relkind IN ('r','v') $whereclause ORDER BY "TABLE_SCHEM", "TABLE_NAME", "ORDINAL_POSITION" !; my $data = $dbh->selectall_arrayref($col_info_sql) or return undef; # To turn the data back into a statement handle, we need # to fetch the data as an array of arrays, and also have a # a matching array of all the column names my %col_map = (qw/ TABLE_CAT 0 TABLE_SCHEM 1 TABLE_NAME 2 COLUMN_NAME 3 DATA_TYPE 4 TYPE_NAME 5 COLUMN_SIZE 6 BUFFER_LENGTH 7 DECIMAL_DIGITS 8 NUM_PREC_RADIX 9 NULLABLE 10 REMARKS 11 COLUMN_DEF 12 SQL_DATA_TYPE 13 SQL_DATETIME_SUB 14 CHAR_OCTET_LENGTH 15 ORDINAL_POSITION 16 IS_NULLABLE 17 pg_type 18 pg_constraint 19 pg_schema 20 pg_table 21 pg_column 22 pg_enum_values 23 /); for my $row (@$data) { my $typoid = pop @$row; my $typtype = pop @$row; my $typmod = pop @$row; my $attnum = pop @$row; my $aid = pop @$row; $row->[$col_map{COLUMN_SIZE}] = _calc_col_size($typmod,$row->[$col_map{COLUMN_SIZE}]); # Replace the Pg type with the SQL_ type $row->[$col_map{DATA_TYPE}] = DBD::Pg::db::pg_type_info($dbh,$row->[$col_map{DATA_TYPE}]); # Add pg_constraint my $SQL = q{SELECT consrc FROM pg_catalog.pg_constraint WHERE contype = 'c' AND }. qq{conrelid = $aid AND conkey = '{$attnum}'}; my $info = $dbh->selectall_arrayref($SQL); if (@$info) { $row->[19] = $info->[0][0]; } else { $row->[19] = undef; } if ( $typtype eq 'e' ) { $SQL = "SELECT enumlabel FROM pg_catalog.pg_enum WHERE enumtypid = $typoid ORDER BY oid"; $row->[23] = $dbh->selectcol_arrayref($SQL); } else { $row->[23] = undef; } } # Since we've processed the data in Perl, we have to jump through a hoop # To turn it back into a statement handle # return _prepare_from_data ( 'column_info', $data, [ sort { $col_map{$a} <=> $col_map{$b} } keys %col_map], ); } sub _prepare_from_data { my ($statement, $data, $names, %attr) = @_; my $sponge = DBI->connect('dbi:Sponge:', '', '', { RaiseError => 1 }); my $sth = $sponge->prepare($statement, { rows=>$data, NAME=>$names, %attr }); return $sth; } sub statistics_info { my $dbh = shift; my ($catalog, $schema, $table, $unique_only, $quick, $attr) = @_; ## Catalog is ignored, but table is mandatory return undef unless defined $table and length $table; my $schema_where = ''; my @exe_args = ($table); my $input_schema = (defined $schema and length $schema) ? 1 : 0; if ($input_schema) { $schema_where = 'AND n.nspname = ? AND n.oid = d.relnamespace'; push(@exe_args, $schema); } else { $schema_where = 'AND n.oid = d.relnamespace'; } my $table_stats_sql = qq{ SELECT d.relpages, d.reltuples, n.nspname FROM pg_catalog.pg_class d, pg_catalog.pg_namespace n WHERE d.relname = ? $schema_where }; my $colnames_sql = qq{ SELECT a.attnum, a.attname FROM pg_catalog.pg_attribute a, pg_catalog.pg_class d, pg_catalog.pg_namespace n WHERE a.attrelid = d.oid AND d.relname = ? $schema_where }; my $stats_sql = qq{ SELECT c.relname, i.indkey, i.indisunique, i.indisclustered, a.amname, n.nspname, c.relpages, c.reltuples, i.indexprs, pg_get_expr(i.indpred,i.indrelid) as predicate FROM pg_catalog.pg_index i, pg_catalog.pg_class c, pg_catalog.pg_class d, pg_catalog.pg_am a, pg_catalog.pg_namespace n WHERE d.relname = ? $schema_where AND d.oid = i.indrelid AND i.indexrelid = c.oid AND c.relam = a.oid ORDER BY i.indisunique desc, a.amname, c.relname }; my @output_rows; # Table-level stats if (!$unique_only) { my $table_stats_sth = $dbh->prepare($table_stats_sql); $table_stats_sth->execute(@exe_args) or return undef; my $tst = $table_stats_sth->fetchrow_hashref or return undef; push(@output_rows, [ undef, # TABLE_CAT $tst->{nspname}, # TABLE_SCHEM $table, # TABLE_NAME undef, # NON_UNIQUE undef, # INDEX_QUALIFIER undef, # INDEX_NAME 'table', # TYPE undef, # ORDINAL_POSITION undef, # COLUMN_NAME undef, # ASC_OR_DESC $tst->{reltuples},# CARDINALITY $tst->{relpages}, # PAGES undef, # FILTER_CONDITION ]); } # Fetch the column names for later use my $colnames_sth = $dbh->prepare($colnames_sql); $colnames_sth->execute(@exe_args) or return undef; my $colnames = $colnames_sth->fetchall_hashref('attnum'); # Fetch the index definitions my $sth = $dbh->prepare($stats_sql); $sth->execute(@exe_args) or return undef; STAT_ROW: #use Data::Dumper; #warn Dumper $stats_sql; while (my $row = $sth->fetchrow_hashref) { #warn Dumper $row; next if $row->{indexprs}; # We can't return these accurately via this interface ... next if $unique_only and !$row->{indisunique}; my $indtype = $row->{indisclustered} ? 'clustered' : ( $row->{amname} eq 'btree' ) ? 'btree' : ($row->{amname} eq 'hash' ) ? 'hashed' : 'other'; my $nonunique = $row->{indisunique} ? 0 : 1; my @index_row = ( undef, # TABLE_CAT $row->{nspname}, # TABLE_SCHEM $table, # TABLE_NAME $nonunique, # NON_UNIQUE undef, # INDEX_QUALIFIER $row->{relname}, # INDEX_NAME $indtype, # TYPE undef, # ORDINAL_POSITION undef, # COLUMN_NAME 'A', # ASC_OR_DESC $row->{reltuples}, # CARDINALITY $row->{relpages}, # PAGES $row->{predicate}, # FILTER_CONDITION ); my $col_nums = $row->{indkey}; $col_nums =~ s/^\s+//; my @col_nums = split(/\s+/, $col_nums); my $ord_pos = 1; for my $col_num (@col_nums) { my @copy = @index_row; $copy[7] = $ord_pos++; # ORDINAL_POSITION $copy[8] = $colnames->{$col_num}->{attname}; # COLUMN_NAME push(@output_rows, \@copy); } } my @output_colnames = qw/ TABLE_CAT TABLE_SCHEM TABLE_NAME NON_UNIQUE INDEX_QUALIFIER INDEX_NAME TYPE ORDINAL_POSITION COLUMN_NAME ASC_OR_DESC CARDINALITY PAGES FILTER_CONDITION /; return _prepare_from_data('statistics_info', \@output_rows, \@output_colnames); } sub primary_key_info { my $dbh = shift; my ($catalog, $schema, $table, $attr) = @_; ## Catalog is ignored, but table is mandatory return undef unless defined $table and length $table; my $whereclause = 'AND c.relname = ' . $dbh->quote($table); if (defined $schema and length $schema) { $whereclause .= "\n\t\t\tAND n.nspname = " . $dbh->quote($schema); } my $TSJOIN = 'pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace)'; if ($dbh->{private_dbdpg}{version} < 80000) { $TSJOIN = '(SELECT 0 AS oid, 0 AS spcname, 0 AS spclocation LIMIT 0) AS t ON (t.oid=1)'; } my $pri_key_sql = qq{ SELECT c.oid , quote_ident(n.nspname) , quote_ident(c.relname) , quote_ident(c2.relname) , i.indkey, quote_ident(t.spcname), quote_ident(t.spclocation) , n.nspname, c.relname, c2.relname FROM pg_catalog.pg_class c JOIN pg_catalog.pg_index i ON (i.indrelid = c.oid) JOIN pg_catalog.pg_class c2 ON (c2.oid = i.indexrelid) LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace) LEFT JOIN $TSJOIN WHERE i.indisprimary IS TRUE $whereclause }; if ($dbh->{private_dbdpg}{version} >= 90200) { $pri_key_sql =~ s/t.spclocation/pg_tablespace_location(t.oid)/; } my $sth = $dbh->prepare($pri_key_sql) or return undef; $sth->execute(); my $info = $sth->fetchall_arrayref()->[0]; return undef if ! defined $info; # Get the attribute information my $indkey = join ',', split /\s+/, $info->[4]; my $sql = qq{ SELECT a.attnum, pg_catalog.quote_ident(a.attname) AS colname, pg_catalog.quote_ident(t.typname) AS typename FROM pg_catalog.pg_attribute a, pg_catalog.pg_type t WHERE a.attrelid = '$info->[0]' AND a.atttypid = t.oid AND attnum IN ($indkey); }; $sth = $dbh->prepare($sql) or return undef; $sth->execute(); my $attribs = $sth->fetchall_hashref('attnum'); my $pkinfo = []; ## Normal way: complete "row" per column in the primary key if (!exists $attr->{'pg_onerow'}) { my $x=0; my @key_seq = split/\s+/, $info->[4]; for (@key_seq) { # TABLE_CAT $pkinfo->[$x][0] = undef; # SCHEMA_NAME $pkinfo->[$x][1] = $info->[1]; # TABLE_NAME $pkinfo->[$x][2] = $info->[2]; # COLUMN_NAME $pkinfo->[$x][3] = $attribs->{$_}{colname}; # KEY_SEQ $pkinfo->[$x][4] = $_; # PK_NAME $pkinfo->[$x][5] = $info->[3]; # DATA_TYPE $pkinfo->[$x][6] = $attribs->{$_}{typename}; $pkinfo->[$x][7] = $info->[5]; $pkinfo->[$x][8] = $info->[6]; $pkinfo->[$x][9] = $info->[7]; $pkinfo->[$x][10] = $info->[8]; $pkinfo->[$x][11] = $info->[9]; $x++; } } else { ## Nicer way: return only one row # TABLE_CAT $info->[0] = undef; # TABLESPACES $info->[7] = $info->[5]; $info->[8] = $info->[6]; # Unquoted names $info->[9] = $info->[7]; $info->[10] = $info->[8]; $info->[11] = $info->[9]; # PK_NAME $info->[5] = $info->[3]; # COLUMN_NAME $info->[3] = 2==$attr->{'pg_onerow'} ? [ map { $attribs->{$_}{colname} } split /\s+/, $info->[4] ] : join ', ', map { $attribs->{$_}{colname} } split /\s+/, $info->[4]; # DATA_TYPE $info->[6] = 2==$attr->{'pg_onerow'} ? [ map { $attribs->{$_}{typename} } split /\s+/, $info->[4] ] : join ', ', map { $attribs->{$_}{typename} } split /\s+/, $info->[4]; # KEY_SEQ $info->[4] = 2==$attr->{'pg_onerow'} ? [ split /\s+/, $info->[4] ] : join ', ', split /\s+/, $info->[4]; $pkinfo = [$info]; } my @cols = (qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME DATA_TYPE)); push @cols, 'pg_tablespace_name', 'pg_tablespace_location'; push @cols, 'pg_schema', 'pg_table', 'pg_column'; return _prepare_from_data('primary_key_info', $pkinfo, \@cols); } sub primary_key { my $sth = primary_key_info(@_[0..3], {pg_onerow => 2}); return defined $sth ? @{$sth->fetchall_arrayref()->[0][3]} : (); } sub foreign_key_info { my $dbh = shift; ## PK: catalog, schema, table, FK: catalog, schema, table, attr my $oldname = $dbh->{FetchHashKeyName}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; ## Each of these may be undef or empty my $pschema = $_[1] || ''; my $ptable = $_[2] || ''; my $fschema = $_[4] || ''; my $ftable = $_[5] || ''; my $args = $_[6]; ## No way to currently specify it, but we are ready when there is my $odbc = 0; ## Must have at least one named table return undef if !$ptable and !$ftable; ## If only the primary table is given, we return only those columns ## that are used as foreign keys, even if that means that we return ## unique keys but not primary one. We also return all the foreign ## tables/columns that are referencing them, of course. ## The first step is to find the oid of each specific table in the args: ## Return undef if no matching relation found my %oid; for ([$ptable, $pschema, 'P'], [$ftable, $fschema, 'F']) { if (length $_->[0]) { my $SQL = "SELECT c.oid AS schema FROM pg_catalog.pg_class c, pg_catalog.pg_namespace n\n". 'WHERE c.relnamespace = n.oid AND c.relname = ' . $dbh->quote($_->[0]); if (length $_->[1]) { $SQL .= ' AND n.nspname = ' . $dbh->quote($_->[1]); } my $info = $dbh->selectall_arrayref($SQL); return undef if ! @$info; $oid{$_->[2]} = $info->[0][0]; } } ## We now need information about each constraint we care about. ## Foreign table: only 'f' / Primary table: only 'p' or 'u' my $WHERE = $odbc ? q{((contype = 'p'} : q{((contype IN ('p','u')}; if (length $ptable) { $WHERE .= " AND conrelid=$oid{'P'}::oid"; } else { $WHERE .= " AND conrelid IN (SELECT DISTINCT confrelid FROM pg_catalog.pg_constraint WHERE conrelid=$oid{'F'}::oid)"; if (length $pschema) { $WHERE .= ' AND n2.nspname = ' . $dbh->quote($pschema); } } $WHERE .= ")\n \t\t\t\tOR \n \t\t\t\t(contype = 'f'"; if (length $ftable) { $WHERE .= " AND conrelid=$oid{'F'}::oid"; if (length $ptable) { $WHERE .= " AND confrelid=$oid{'P'}::oid"; } } else { $WHERE .= " AND confrelid = $oid{'P'}::oid"; if (length $fschema) { $WHERE .= ' AND n2.nspname = ' . $dbh->quote($fschema); } } $WHERE .= '))'; ## Grab everything except specific column names: my $fk_sql = qq{ SELECT conrelid, confrelid, contype, conkey, confkey, pg_catalog.quote_ident(c.relname) AS t_name, pg_catalog.quote_ident(n2.nspname) AS t_schema, pg_catalog.quote_ident(n.nspname) AS c_schema, pg_catalog.quote_ident(conname) AS c_name, CASE WHEN confupdtype = 'c' THEN 0 WHEN confupdtype = 'r' THEN 1 WHEN confupdtype = 'n' THEN 2 WHEN confupdtype = 'a' THEN 3 WHEN confupdtype = 'd' THEN 4 ELSE -1 END AS update, CASE WHEN confdeltype = 'c' THEN 0 WHEN confdeltype = 'r' THEN 1 WHEN confdeltype = 'n' THEN 2 WHEN confdeltype = 'a' THEN 3 WHEN confdeltype = 'd' THEN 4 ELSE -1 END AS delete, CASE WHEN condeferrable = 'f' THEN 7 WHEN condeferred = 't' THEN 6 WHEN condeferred = 'f' THEN 5 ELSE -1 END AS defer FROM pg_catalog.pg_constraint k, pg_catalog.pg_class c, pg_catalog.pg_namespace n, pg_catalog.pg_namespace n2 WHERE $WHERE AND k.connamespace = n.oid AND k.conrelid = c.oid AND c.relnamespace = n2.oid ORDER BY conrelid ASC }; my $sth = $dbh->prepare($fk_sql); $sth->execute(); my $info = $sth->fetchall_arrayref({}); return undef if ! defined $info or ! @$info; ## Return undef if just ptable given but no fk found return undef if ! length $ftable and ! grep { $_->{'contype'} eq 'f'} @$info; ## Figure out which columns we need information about my %colnum; for my $row (@$info) { for (@{$row->{'conkey'}}) { $colnum{$row->{'conrelid'}}{$_}++; } if ($row->{'contype'} eq 'f') { for (@{$row->{'confkey'}}) { $colnum{$row->{'confrelid'}}{$_}++; } } } ## Get the information about the columns computed above my $SQL = qq{ SELECT a.attrelid, a.attnum, pg_catalog.quote_ident(a.attname) AS colname, pg_catalog.quote_ident(t.typname) AS typename FROM pg_catalog.pg_attribute a, pg_catalog.pg_type t WHERE a.atttypid = t.oid AND (\n}; $SQL .= join "\n\t\t\t\tOR\n" => map { my $cols = join ',' => keys %{$colnum{$_}}; "\t\t\t\t( a.attrelid = '$_' AND a.attnum IN ($cols) )" } sort keys %colnum; $sth = $dbh->prepare(qq{$SQL )}); $sth->execute(); my $attribs = $sth->fetchall_arrayref({}); ## Make a lookup hash my %attinfo; for (@$attribs) { $attinfo{"$_->{'attrelid'}"}{"$_->{'attnum'}"} = $_; } ## This is an array in case we have identical oid/column combos. Lowest oid wins my %ukey; for my $c (grep { $_->{'contype'} ne 'f' } @$info) { ## Munge multi-column keys into sequential order my $multi = join ' ' => sort @{$c->{'conkey'}}; push @{$ukey{$c->{'conrelid'}}{$multi}}, $c; } ## Finally, return as a SQL/CLI structure: my $fkinfo = []; my $x=0; for my $t (sort { $a->{'c_name'} cmp $b->{'c_name'} } grep { $_->{'contype'} eq 'f' } @$info) { ## We need to find which constraint row (if any) matches our confrelid-confkey combo ## by checking out ukey hash. We sort for proper matching of { 1 2 } vs. { 2 1 } ## No match means we have a pure index constraint my $u; my $multi = join ' ' => sort @{$t->{'confkey'}}; if (exists $ukey{$t->{'confrelid'}}{$multi}) { $u = $ukey{$t->{'confrelid'}}{$multi}->[0]; } else { ## Mark this as an index so we can fudge things later on $multi = 'index'; ## Grab the first one found, modify later on as needed $u = ((values %{$ukey{$t->{'confrelid'}}})[0]||[])->[0]; ## Bail in case there was no match next if ! ref $u; } ## ODBC is primary keys only next if $odbc and ($u->{'contype'} ne 'p' or $multi eq 'index'); my $conkey = $t->{'conkey'}; my $confkey = $t->{'confkey'}; for (my $y=0; $conkey->[$y]; $y++) { # UK_TABLE_CAT $fkinfo->[$x][0] = undef; # UK_TABLE_SCHEM $fkinfo->[$x][1] = $u->{'t_schema'}; # UK_TABLE_NAME $fkinfo->[$x][2] = $u->{'t_name'}; # UK_COLUMN_NAME $fkinfo->[$x][3] = $attinfo{$t->{'confrelid'}}{$confkey->[$y]}{'colname'}; # FK_TABLE_CAT $fkinfo->[$x][4] = undef; # FK_TABLE_SCHEM $fkinfo->[$x][5] = $t->{'t_schema'}; # FK_TABLE_NAME $fkinfo->[$x][6] = $t->{'t_name'}; # FK_COLUMN_NAME $fkinfo->[$x][7] = $attinfo{$t->{'conrelid'}}{$conkey->[$y]}{'colname'}; # ORDINAL_POSITION $fkinfo->[$x][8] = $conkey->[$y]; # UPDATE_RULE $fkinfo->[$x][9] = "$t->{'update'}"; # DELETE_RULE $fkinfo->[$x][10] = "$t->{'delete'}"; # FK_NAME $fkinfo->[$x][11] = $t->{'c_name'}; # UK_NAME (may be undef if an index with no named constraint) $fkinfo->[$x][12] = $multi eq 'index' ? undef : $u->{'c_name'}; # DEFERRABILITY $fkinfo->[$x][13] = "$t->{'defer'}"; # UNIQUE_OR_PRIMARY $fkinfo->[$x][14] = ($u->{'contype'} eq 'p' and $multi ne 'index') ? 'PRIMARY' : 'UNIQUE'; # UK_DATA_TYPE $fkinfo->[$x][15] = $attinfo{$t->{'confrelid'}}{$confkey->[$y]}{'typename'}; # FK_DATA_TYPE $fkinfo->[$x][16] = $attinfo{$t->{'conrelid'}}{$conkey->[$y]}{'typename'}; $x++; } ## End each column in this foreign key } ## End each foreign key my @CLI_cols = (qw( UK_TABLE_CAT UK_TABLE_SCHEM UK_TABLE_NAME UK_COLUMN_NAME FK_TABLE_CAT FK_TABLE_SCHEM FK_TABLE_NAME FK_COLUMN_NAME ORDINAL_POSITION UPDATE_RULE DELETE_RULE FK_NAME UK_NAME DEFERABILITY UNIQUE_OR_PRIMARY UK_DATA_TYPE FK_DATA_TYPE )); my @ODBC_cols = (qw( PKTABLE_CAT PKTABLE_SCHEM PKTABLE_NAME PKCOLUMN_NAME FKTABLE_CAT FKTABLE_SCHEM FKTABLE_NAME FKCOLUMN_NAME KEY_SEQ UPDATE_RULE DELETE_RULE FK_NAME PK_NAME DEFERABILITY UNIQUE_OR_PRIMARY PK_DATA_TYPE FKDATA_TYPE )); if ($oldname eq 'NAME_lc') { if ($odbc) { for my $col (@ODBC_cols) { $col = lc $col; } } else { for my $col (@CLI_cols) { $col = lc $col; } } } return _prepare_from_data('foreign_key_info', $fkinfo, $odbc ? \@ODBC_cols : \@CLI_cols); } sub table_info { my $dbh = shift; my ($catalog, $schema, $table, $type) = @_; my $tbl_sql = (); my $extracols = q{,NULL::text AS pg_schema, NULL::text AS pg_table}; if ( # Rule 19a (defined $catalog and $catalog eq '%') and (defined $schema and $schema eq '') and (defined $table and $table eq '') ) { $tbl_sql = qq{ SELECT NULL::text AS "TABLE_CAT" , NULL::text AS "TABLE_SCHEM" , NULL::text AS "TABLE_NAME" , NULL::text AS "TABLE_TYPE" , NULL::text AS "REMARKS" $extracols }; } elsif (# Rule 19b (defined $catalog and $catalog eq '') and (defined $schema and $schema eq '%') and (defined $table and $table eq '') ) { $extracols = q{,n.nspname AS pg_schema, NULL::text AS pg_table}; $tbl_sql = qq{SELECT NULL::text AS "TABLE_CAT" , quote_ident(n.nspname) AS "TABLE_SCHEM" , NULL::text AS "TABLE_NAME" , NULL::text AS "TABLE_TYPE" , CASE WHEN n.nspname ~ '^pg_' THEN 'system schema' ELSE 'owned by ' || pg_get_userbyid(n.nspowner) END AS "REMARKS" $extracols FROM pg_catalog.pg_namespace n ORDER BY "TABLE_SCHEM" }; } elsif (# Rule 19c (defined $catalog and $catalog eq '') and (defined $schema and $schema eq '') and (defined $table and $table eq '') and (defined $type and $type eq '%') ) { $tbl_sql = qq{ SELECT NULL::text AS "TABLE_CAT" , NULL::text AS "TABLE_SCHEM" , NULL::text AS "TABLE_NAME" , 'TABLE' AS "TABLE_TYPE" , 'relkind: r' AS "REMARKS" $extracols UNION SELECT NULL::text AS "TABLE_CAT" , NULL::text AS "TABLE_SCHEM" , NULL::text AS "TABLE_NAME" , 'VIEW' AS "TABLE_TYPE" , 'relkind: v' AS "REMARKS" $extracols }; } else { # Default SQL $extracols = q{,n.nspname AS pg_schema, c.relname AS pg_table}; my @search; my $showtablespace = ', quote_ident(t.spcname) AS "pg_tablespace_name", quote_ident(t.spclocation) AS "pg_tablespace_location"'; if ($dbh->{private_dbdpg}{version} >= 90200) { $showtablespace = ', quote_ident(t.spcname) AS "pg_tablespace_name", quote_ident(pg_tablespace_location(t.oid)) AS "pg_tablespace_location"'; } ## If the schema or table has an underscore or a %, use a LIKE comparison if (defined $schema and length $schema) { push @search, 'n.nspname ' . ($schema =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($schema); } if (defined $table and length $table) { push @search, 'c.relname ' . ($table =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($table); } ## All we can see is "table" or "view". Default is both my $typesearch = q{IN ('r','v')}; if (defined $type and length $type) { if ($type =~ /\btable\b/i and $type !~ /\bview\b/i) { $typesearch = q{= 'r'}; } elsif ($type =~ /\bview\b/i and $type !~ /\btable\b/i) { $typesearch = q{= 'v'}; } } push @search, "c.relkind $typesearch"; my $TSJOIN = 'pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace)'; if ($dbh->{private_dbdpg}{version} < 80000) { $TSJOIN = '(SELECT 0 AS oid, 0 AS spcname, 0 AS spclocation LIMIT 0) AS t ON (t.oid=1)'; } my $whereclause = join "\n\t\t\t\t\t AND " => @search; $tbl_sql = qq{ SELECT NULL::text AS "TABLE_CAT" , quote_ident(n.nspname) AS "TABLE_SCHEM" , quote_ident(c.relname) AS "TABLE_NAME" , CASE WHEN c.relkind = 'v' THEN CASE WHEN quote_ident(n.nspname) ~ '^pg_' THEN 'SYSTEM VIEW' ELSE 'VIEW' END ELSE CASE WHEN quote_ident(n.nspname) ~ '^pg_' THEN 'SYSTEM TABLE' ELSE 'TABLE' END END AS "TABLE_TYPE" , d.description AS "REMARKS" $showtablespace $extracols FROM pg_catalog.pg_class AS c LEFT JOIN pg_catalog.pg_description AS d ON (c.oid = d.objoid AND c.tableoid = d.classoid AND d.objsubid = 0) LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace) LEFT JOIN $TSJOIN WHERE $whereclause ORDER BY "TABLE_TYPE", "TABLE_CAT", "TABLE_SCHEM", "TABLE_NAME" }; } my $sth = $dbh->prepare( $tbl_sql ) or return undef; $sth->execute(); return $sth; } sub tables { my ($dbh, @args) = @_; my $attr = $args[4]; my $sth = $dbh->table_info(@args) or return; my $tables = $sth->fetchall_arrayref() or return; my @tables = map { (! (ref $attr eq 'HASH' and $attr->{pg_noprefix})) ? "$_->[1].$_->[2]" : $_->[2] } @$tables; return @tables; } sub table_attributes { my ($dbh, $table) = @_; my $sth = $dbh->column_info(undef,undef,$table,undef); my %convert = ( COLUMN_NAME => 'NAME', DATA_TYPE => 'TYPE', COLUMN_SIZE => 'SIZE', NULLABLE => 'NOTNULL', REMARKS => 'REMARKS', COLUMN_DEF => 'DEFAULT', pg_constraint => 'CONSTRAINT', ); my $attrs = $sth->fetchall_arrayref(\%convert); for my $row (@$attrs) { # switch the column names for my $name (keys %$row) { $row->{ $convert{$name} } = $row->{$name}; ## Keep some original columns delete $row->{$name} unless ($name eq 'REMARKS' or $name eq 'NULLABLE'); } # Moved check outside of loop as it was inverting the NOTNULL value for # attribute. # NOTNULL inverts the sense of NULLABLE $row->{NOTNULL} = ($row->{NOTNULL} ? 0 : 1); my @pri_keys = $dbh->primary_key( undef, undef, $table ); $row->{PRIMARY_KEY} = scalar(grep { /^$row->{NAME}$/i } @pri_keys) ? 1 : 0; } return $attrs; } sub _calc_col_size { my $mod = shift; my $size = shift; if ((defined $size) and ($size > 0)) { return $size; } elsif ($mod > 0xffff) { my $prec = ($mod & 0xffff) - 4; $mod >>= 16; my $dig = $mod; return "$prec,$dig"; } elsif ($mod >= 4) { return $mod - 4; } # else { # $rtn = $mod; # $rtn = undef; # } return; } sub type_info_all { my ($dbh) = @_; my $names = { TYPE_NAME => 0, DATA_TYPE => 1, COLUMN_SIZE => 2, LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE => 9, FIXED_PREC_SCALE => 10, AUTO_UNIQUE_VALUE => 11, LOCAL_TYPE_NAME => 12, MINIMUM_SCALE => 13, MAXIMUM_SCALE => 14, SQL_DATA_TYPE => 15, SQL_DATETIME_SUB => 16, NUM_PREC_RADIX => 17, INTERVAL_PRECISION => 18, }; ## This list is derived from dbi_sql.h in DBI, from types.c and types.h, and from the PG docs ## Aids to make the list more readable: my $GIG = 1073741824; my $PS = 'precision/scale'; my $LEN = 'length'; my $UN; my $ti = [ $names, # name sql_type size pfx/sfx crt n/c/s +-/P/I local min max sub rdx itvl ['unknown', SQL_UNKNOWN_TYPE, 0, $UN,$UN, $UN, 1,0,0, $UN,0,0, 'UNKNOWN', $UN,$UN, SQL_UNKNOWN_TYPE, $UN, $UN, $UN ], ['bytea', SQL_VARBINARY, $GIG, q{'},q{'}, $UN, 1,0,3, $UN,0,0, 'BYTEA', $UN,$UN, SQL_VARBINARY, $UN, $UN, $UN ], ['bpchar', SQL_CHAR, $GIG, q{'},q{'}, $LEN, 1,1,3, $UN,0,0, 'CHARACTER', $UN,$UN, SQL_CHAR, $UN, $UN, $UN ], ['numeric', SQL_DECIMAL, 1000, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,1000, SQL_DECIMAL, $UN, $UN, $UN ], ['numeric', SQL_NUMERIC, 1000, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,1000, SQL_NUMERIC, $UN, $UN, $UN ], ['int4', SQL_INTEGER, 10, $UN,$UN, $UN, 1,0,2, 0,0,0, 'INTEGER', 0,0, SQL_INTEGER, $UN, $UN, $UN ], ['int2', SQL_SMALLINT, 5, $UN,$UN, $UN, 1,0,2, 0,0,0, 'SMALLINT', 0,0, SQL_SMALLINT, $UN, $UN, $UN ], ['float4', SQL_FLOAT, 6, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,6, SQL_FLOAT, $UN, $UN, $UN ], ['float8', SQL_REAL, 15, $UN,$UN, $PS, 1,0,2, 0,0,0, 'REAL', 0,15, SQL_REAL, $UN, $UN, $UN ], ['int8', SQL_DOUBLE, 20, $UN,$UN, $UN, 1,0,2, 0,0,0, 'LONGINT', 0,0, SQL_DOUBLE, $UN, $UN, $UN ], ['date', SQL_DATE, 10, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'DATE', 0,0, SQL_DATE, $UN, $UN, $UN ], ['tinterval',SQL_TIME, 18, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TINTERVAL', 0,6, SQL_TIME, $UN, $UN, $UN ], ['timestamp',SQL_TIMESTAMP, 29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMP', 0,6, SQL_TIMESTAMP, $UN, $UN, $UN ], ['text', SQL_VARCHAR, $GIG, q{'},q{'}, $LEN, 1,1,3, $UN,0,0, 'TEXT', $UN,$UN, SQL_VARCHAR, $UN, $UN, $UN ], ['bool', SQL_BOOLEAN, 1, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'BOOLEAN', $UN,$UN, SQL_BOOLEAN, $UN, $UN, $UN ], ['array', SQL_ARRAY, 1, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'ARRAY', $UN,$UN, SQL_ARRAY, $UN, $UN, $UN ], ['date', SQL_TYPE_DATE, 10, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'DATE', 0,0, SQL_TYPE_DATE, $UN, $UN, $UN ], ['time', SQL_TYPE_TIME, 18, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIME', 0,6, SQL_TYPE_TIME, $UN, $UN, $UN ], ['timestamp',SQL_TYPE_TIMESTAMP,29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMP', 0,6, SQL_TYPE_TIMESTAMP, $UN, $UN, $UN ], ['timetz', SQL_TYPE_TIME_WITH_TIMEZONE, 29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMETZ', 0,6, SQL_TYPE_TIME_WITH_TIMEZONE, $UN, $UN, $UN ], ['timestamptz',SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, 29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMPTZ',0,6, SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, $UN, $UN, $UN ], # # intentionally omitted: char, all geometric types, internal types ]; return $ti; } # Characters that need to be escaped by quote(). my %esc = ( q{'} => '\\047', # '\\' . sprintf("%03o", ord("'")), # ISO SQL 2 '\\' => '\\134', # '\\' . sprintf("%03o", ord("\\")), ); # Set up lookup for SQL types we don't want to escape. my %no_escape = map { $_ => 1 } DBI::SQL_INTEGER, DBI::SQL_SMALLINT, DBI::SQL_DECIMAL, DBI::SQL_FLOAT, DBI::SQL_REAL, DBI::SQL_DOUBLE, DBI::SQL_NUMERIC; sub get_info { my ($dbh,$type) = @_; return undef unless defined $type and length $type; my %type = ( ## Driver information: 116 => ['SQL_ACTIVE_ENVIRONMENTS', 0 ], ## unlimited 10021 => ['SQL_ASYNC_MODE', 2 ], ## SQL_AM_STATEMENT 120 => ['SQL_BATCH_ROW_COUNT', 2 ], ## SQL_BRC_EXPLICIT 121 => ['SQL_BATCH_SUPPORT', 3 ], ## 12 SELECT_PROC + ROW_COUNT_PROC 2 => ['SQL_DATA_SOURCE_NAME', "dbi:Pg:$dbh->{Name}" ], 3 => ['SQL_DRIVER_HDBC', 0 ], ## not applicable 135 => ['SQL_DRIVER_HDESC', 0 ], ## not applicable 4 => ['SQL_DRIVER_HENV', 0 ], ## not applicable 76 => ['SQL_DRIVER_HLIB', 0 ], ## not applicable 5 => ['SQL_DRIVER_HSTMT', 0 ], ## not applicable ## Not clear what should go here. Some things suggest 'Pg', others 'Pg.pm'. We'll use DBD::Pg for now 6 => ['SQL_DRIVER_NAME', 'DBD::Pg' ], 77 => ['SQL_DRIVER_ODBC_VERSION', '03.00' ], 7 => ['SQL_DRIVER_VER', 'DBDVERSION' ], ## magic word 144 => ['SQL_DYNAMIC_CURSOR_ATTRIBUTES1', 0 ], ## we can FETCH, but not via methods 145 => ['SQL_DYNAMIC_CURSOR_ATTRIBUTES2', 0 ], ## same as above 84 => ['SQL_FILE_USAGE', 0 ], ## SQL_FILE_NOT_SUPPORTED (this is good) 146 => ['SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1', 519 ], ## not clear what this refers to in DBD context 147 => ['SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2', 5209 ], ## see above 81 => ['SQL_GETDATA_EXTENSIONS', 15 ], ## 1+2+4+8 149 => ['SQL_INFO_SCHEMA_VIEWS', 3932149 ], ## not: assert, charset, collat, trans 150 => ['SQL_KEYSET_CURSOR_ATTRIBUTES1', 0 ], ## applies to us? 151 => ['SQL_KEYSET_CURSOR_ATTRIBUTES2', 0 ], ## see above 10022 => ['SQL_MAX_ASYNC_CONCURRENT_STATEMENTS', 0 ], ## unlimited, probably 0 => ['SQL_MAX_DRIVER_CONNECTIONS', 'MAXCONNECTIONS' ], ## magic word 152 => ['SQL_ODBC_INTERFACE_CONFORMANCE', 1 ], ## SQL_OIC_LEVEL_1 10 => ['SQL_ODBC_VER', '03.00.0000' ], 153 => ['SQL_PARAM_ARRAY_ROW_COUNTS', 2 ], ## correct? 154 => ['SQL_PARAM_ARRAY_SELECTS', 3 ], ## PAS_NO_SELECT 11 => ['SQL_ROW_UPDATES', 'N' ], 14 => ['SQL_SEARCH_PATTERN_ESCAPE', '\\' ], 13 => ['SQL_SERVER_NAME', 'CURRENTDB' ], ## magic word 166 => ['SQL_STANDARD_CLI_CONFORMANCE', 2 ], ## ?? 167 => ['SQL_STATIC_CURSOR_ATTRIBUTES1', 519 ], ## ?? 168 => ['SQL_STATIC_CURSOR_ATTRIBUTES2', 5209 ], ## ?? ## DBMS Information 16 => ['SQL_DATABASE_NAME', 'CURRENTDB' ], ## magic word 17 => ['SQL_DBMS_NAME', 'PostgreSQL' ], 18 => ['SQL_DBMS_VERSION', 'ODBCVERSION' ], ## magic word ## Data source information 20 => ['SQL_ACCESSIBLE_PROCEDURES', 'Y' ], ## is this really true? 19 => ['SQL_ACCESSIBLE_TABLES', 'Y' ], ## is this really true? 82 => ['SQL_BOOKMARK_PERSISTENCE', 0 ], 42 => ['SQL_CATALOG_TERM', '' ], ## empty = catalogs are not supported 10004 => ['SQL_COLLATION_SEQ', 'ENCODING' ], ## magic word 22 => ['SQL_CONCAT_NULL_BEHAVIOR', 0 ], ## SQL_CB_NULL 23 => ['SQL_CURSOR_COMMIT_BEHAVIOR', 1 ], ## SQL_CB_CLOSE 24 => ['SQL_CURSOR_ROLLBACK_BEHAVIOR', 1 ], ## SQL_CB_CLOSE 10001 => ['SQL_CURSOR_SENSITIVITY', 1 ], ## SQL_INSENSITIVE 25 => ['SQL_DATA_SOURCE_READ_ONLY', 'READONLY' ], ## magic word 26 => ['SQL_DEFAULT_TXN_ISOLATION', 'DEFAULTTXN' ], ## magic word (2 or 8) 10002 => ['SQL_DESCRIBE_PARAMETER', 'Y' ], 36 => ['SQL_MULT_RESULT_SETS', 'Y' ], 37 => ['SQL_MULTIPLE_ACTIVE_TXN', 'Y' ], 111 => ['SQL_NEED_LONG_DATA_LEN', 'N' ], 85 => ['SQL_NULL_COLLATION', 0 ], ## SQL_NC_HIGH 40 => ['SQL_PROCEDURE_TERM', 'function' ], ## for now 39 => ['SQL_SCHEMA_TERM', 'schema' ], 44 => ['SQL_SCROLL_OPTIONS', 8 ], ## not really for DBD? 45 => ['SQL_TABLE_TERM', 'table' ], 46 => ['SQL_TXN_CAPABLE', 2 ], ## SQL_TC_ALL 72 => ['SQL_TXN_ISOLATION_OPTION', 10 ], ## 2+8 47 => ['SQL_USER_NAME', $dbh->{CURRENT_USER} ], ## Supported SQL 169 => ['SQL_AGGREGATE_FUNCTIONS', 127 ], ## all of 'em 117 => ['SQL_ALTER_DOMAIN', 31 ], ## all but deferred 86 => ['SQL_ALTER_TABLE', 32639 ], ## no collate 114 => ['SQL_CATALOG_LOCATION', 0 ], 10003 => ['SQL_CATALOG_NAME', 'N' ], 41 => ['SQL_CATALOG_NAME_SEPARATOR', '' ], 92 => ['SQL_CATALOG_USAGE', 0 ], 87 => ['SQL_COLUMN_ALIAS', 'Y' ], 74 => ['SQL_CORRELATION_NAME', 2 ], ## SQL_CN_ANY 127 => ['SQL_CREATE_ASSERTION', 0 ], 128 => ['SQL_CREATE_CHARACTER_SET', 0 ], 129 => ['SQL_CREATE_COLLATION', 0 ], 130 => ['SQL_CREATE_DOMAIN', 23 ], ## no collation, no defer 131 => ['SQL_CREATE_SCHEMA', 3 ], ## 1+2 schema + authorize 132 => ['SQL_CREATE_TABLE', 13845 ], ## no collation 133 => ['SQL_CREATE_TRANSLATION', 0 ], 134 => ['SQL_CREATE_VIEW', 9 ], ## local + create? 119 => ['SQL_DATETIME_LITERALS', 65535 ], ## all? 170 => ['SQL_DDL_INDEX', 3 ], ## create + drop 136 => ['SQL_DROP_ASSERTION', 0 ], 137 => ['SQL_DROP_CHARACTER_SET', 0 ], 138 => ['SQL_DROP_COLLATION', 0 ], 139 => ['SQL_DROP_DOMAIN', 7 ], 140 => ['SQL_DROP_SCHEMA', 7 ], 141 => ['SQL_DROP_TABLE', 7 ], 142 => ['SQL_DROP_TRANSLATION', 0 ], 143 => ['SQL_DROP_VIEW', 7 ], 27 => ['SQL_EXPRESSIONS_IN_ORDERBY', 'Y' ], 88 => ['SQL_GROUP_BY', 2 ], ## GROUP_BY_CONTAINS_SELECT 28 => ['SQL_IDENTIFIER_CASE', 2 ], ## SQL_IC_LOWER 29 => ['SQL_IDENTIFIER_QUOTE_CHAR', q{"} ], 148 => ['SQL_INDEX_KEYWORDS', 0 ], ## not needed for Pg 172 => ['SQL_INSERT_STATEMENT', 7 ], ## 1+2+4 = all 73 => ['SQL_INTEGRITY', 'Y' ], ## e.g. ON DELETE CASCADE? 89 => ['SQL_KEYWORDS', 'KEYWORDS' ], ## magic word 113 => ['SQL_LIKE_ESCAPE_CLAUSE', 'Y' ], 75 => ['SQL_NON_NULLABLE_COLUMNS', 1 ], ## NNC_NOT_NULL 115 => ['SQL_OJ_CAPABILITIES', 127 ], ## all 90 => ['SQL_ORDER_BY_COLUMNS_IN_SELECT', 'N' ], 38 => ['SQL_OUTER_JOINS', 'Y' ], 21 => ['SQL_PROCEDURES', 'Y' ], 93 => ['SQL_QUOTED_IDENTIFIER_CASE', 3 ], ## SQL_IC_SENSITIVE 91 => ['SQL_SCHEMA_USAGE', 31 ], ## all 94 => ['SQL_SPECIAL_CHARACTERS', '$' ], ## there are actually many more... 118 => ['SQL_SQL_CONFORMANCE', 4 ], ## SQL92_INTERMEDIATE ?? 95 => ['SQL_SUBQUERIES', 31 ], ## all 96 => ['SQL_UNION', 3 ], ## 1+2 = all ## SQL limits 112 => ['SQL_MAX_BINARY_LITERAL_LEN', 0 ], 34 => ['SQL_MAX_CATALOG_NAME_LEN', 0 ], 108 => ['SQL_MAX_CHAR_LITERAL_LEN', 0 ], 30 => ['SQL_MAX_COLUMN_NAME_LEN', 'NAMEDATALEN' ], ## magic word 97 => ['SQL_MAX_COLUMNS_IN_GROUP_BY', 0 ], 98 => ['SQL_MAX_COLUMNS_IN_INDEX', 0 ], 99 => ['SQL_MAX_COLUMNS_IN_ORDER_BY', 0 ], 100 => ['SQL_MAX_COLUMNS_IN_SELECT', 0 ], 101 => ['SQL_MAX_COLUMNS_IN_TABLE', 250 ], ## 250-1600 (depends on column types) 31 => ['SQL_MAX_CURSOR_NAME_LEN', 'NAMEDATALEN' ], ## magic word 10005 => ['SQL_MAX_IDENTIFIER_LEN', 'NAMEDATALEN' ], ## magic word 102 => ['SQL_MAX_INDEX_SIZE', 0 ], 102 => ['SQL_MAX_PROCEDURE_NAME_LEN', 'NAMEDATALEN' ], ## magic word 104 => ['SQL_MAX_ROW_SIZE', 0 ], ## actually 1.6 TB, but too big to represent here 103 => ['SQL_MAX_ROW_SIZE_INCLUDES_LONG', 'Y' ], 32 => ['SQL_MAX_SCHEMA_NAME_LEN', 'NAMEDATALEN' ], ## magic word 105 => ['SQL_MAX_STATEMENT_LEN', 0 ], 35 => ['SQL_MAX_TABLE_NAME_LEN', 'NAMEDATALEN' ], ## magic word 106 => ['SQL_MAX_TABLES_IN_SELECT', 0 ], 107 => ['SQL_MAX_USER_NAME_LEN', 'NAMEDATALEN' ], ## magic word ## Scalar function information 48 => ['SQL_CONVERT_FUNCTIONS', 2 ], ## CVT_CAST only? 49 => ['SQL_NUMERIC_FUNCTIONS', 16777215 ], ## ?? all but some naming clashes: rand(om), trunc(ate), log10=ln, etc. 50 => ['SQL_STRING_FUNCTIONS', 16280984 ], ## ?? 51 => ['SQL_SYSTEM_FUNCTIONS', 0 ], ## ?? 109 => ['SQL_TIMEDATE_ADD_INTERVALS', 0 ], ## ?? no explicit timestampadd? 110 => ['SQL_TIMEDATE_DIFF_INTERVALS', 0 ], ## ?? 52 => ['SQL_TIMEDATE_FUNCTIONS', 1966083 ], ## Conversion information - all but BIT, LONGVARBINARY, and LONGVARCHAR 53 => ['SQL_CONVERT_BIGINT', 1830399 ], 54 => ['SQL_CONVERT_BINARY', 1830399 ], 55 => ['SQL_CONVERT_BIT', 0 ], 56 => ['SQL_CONVERT_CHAR', 1830399 ], 57 => ['SQL_CONVERT_DATE', 1830399 ], 58 => ['SQL_CONVERT_DECIMAL', 1830399 ], 59 => ['SQL_CONVERT_DOUBLE', 1830399 ], 60 => ['SQL_CONVERT_FLOAT', 1830399 ], 61 => ['SQL_CONVERT_INTEGER', 1830399 ], 123 => ['SQL_CONVERT_INTERVAL_DAY_TIME', 1830399 ], 124 => ['SQL_CONVERT_INTERVAL_YEAR_MONTH', 1830399 ], 71 => ['SQL_CONVERT_LONGVARBINARY', 0 ], 62 => ['SQL_CONVERT_LONGVARCHAR', 0 ], 63 => ['SQL_CONVERT_NUMERIC', 1830399 ], 64 => ['SQL_CONVERT_REAL', 1830399 ], 65 => ['SQL_CONVERT_SMALLINT', 1830399 ], 66 => ['SQL_CONVERT_TIME', 1830399 ], 67 => ['SQL_CONVERT_TIMESTAMP', 1830399 ], 68 => ['SQL_CONVERT_TINYINT', 1830399 ], 69 => ['SQL_CONVERT_VARBINARY', 0 ], 70 => ['SQL_CONVERT_VARCHAR', 1830399 ], 122 => ['SQL_CONVERT_WCHAR', 0 ], 125 => ['SQL_CONVERT_WLONGVARCHAR', 0 ], 126 => ['SQL_CONVERT_WVARCHAR', 0 ], ); ## end of %type ## Put both numbers and names into a hash my %t; for (keys %type) { $t{$_} = $type{$_}->[1]; $t{$type{$_}->[0]} = $type{$_}->[1]; } return undef unless exists $t{$type}; my $ans = $t{$type}; if ($ans eq 'NAMEDATALEN') { return $dbh->selectall_arrayref('SHOW max_identifier_length')->[0][0]; } elsif ($ans eq 'ODBCVERSION') { my $version = $dbh->{private_dbdpg}{version}; return '00.00.0000' unless $version =~ /^(\d\d?)(\d\d)(\d\d)$/o; return sprintf '%02d.%02d.%.2d00', $1,$2,$3; } elsif ($ans eq 'DBDVERSION') { my $simpleversion = $DBD::Pg::VERSION; $simpleversion =~ s/_/./g; return sprintf '%02d.%02d.%1d%1d%1d%1d', split (/\./, "$simpleversion.0.0.0.0.0.0"); } elsif ($ans eq 'MAXCONNECTIONS') { return $dbh->selectall_arrayref('SHOW max_connections')->[0][0]; } elsif ($ans eq 'ENCODING') { return $dbh->selectall_arrayref('SHOW server_encoding')->[0][0]; } elsif ($ans eq 'KEYWORDS') { ## http://www.postgresql.org/docs/current/static/sql-keywords-appendix.html ## Basically, we want ones that are 'reserved' for PostgreSQL but not 'reserved' in SQL:2003 ## return join ',' => (qw(ANALYSE ANALYZE ASC DEFERRABLE DESC DO FREEZE ILIKE INITIALLY ISNULL LIMIT NOTNULL OFF OFFSET PLACING RETURNING VERBOSE)); } elsif ($ans eq 'CURRENTDB') { return $dbh->selectall_arrayref('SELECT pg_catalog.current_database()')->[0][0]; } elsif ($ans eq 'READONLY') { my $SQL = q{SELECT CASE WHEN setting = 'on' THEN 'Y' ELSE 'N' END FROM pg_settings WHERE name = 'transaction_read_only'}; my $info = $dbh->selectall_arrayref($SQL); return defined $info->[0] ? $info->[0][0] : 'N'; } elsif ($ans eq 'DEFAULTTXN') { my $SQL = q{SELECT CASE WHEN setting = 'read committed' THEN 2 ELSE 8 END FROM pg_settings WHERE name = 'default_transaction_isolation'}; my $info = $dbh->selectall_arrayref($SQL); return defined $info->[0] ? $info->[0][0] : 2; } return $ans; } # end of get_info sub private_attribute_info { return { pg_async_status => undef, pg_bool_tf => undef, pg_db => undef, pg_default_port => undef, pg_enable_utf8 => undef, pg_errorlevel => undef, pg_expand_array => undef, pg_host => undef, pg_INV_READ => undef, pg_INV_WRITE => undef, pg_lib_version => undef, pg_options => undef, pg_pass => undef, pg_pid => undef, pg_placeholder_dollaronly => undef, pg_port => undef, pg_prepare_now => undef, pg_protocol => undef, pg_server_prepare => undef, pg_server_version => undef, pg_socket => undef, pg_standard_conforming_strings => undef, pg_user => undef, }; } } { package DBD::Pg::st; sub parse_trace_flag { my ($h, $flag) = @_; return DBD::Pg->parse_trace_flag($flag); } sub bind_param_array { ## Binds an array of data to a specific placeholder in a statement ## The DBI version is broken, so we implement a near-copy here my $sth = shift; my ($p_id, $value_array, $attr) = @_; ## Bail if the second arg is not undef or an an arrayref return $sth->set_err(1, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array)) if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY'; ## Bail if the first arg is not a number return $sth->set_err(1, q{Can't use named placeholders for non-driver supported bind_param_array}) unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here ## Store the list of items in the hash (will be undef or an arayref) $sth->{ParamArrays}{$p_id} = $value_array; ## If any attribs were passed in, we need to call bind_param return $sth->bind_param($p_id, '', $attr) if $attr; ## This is the big change so -w does not complain return 1; } ## end bind_param_array sub private_attribute_info { return { pg_async => undef, pg_bound => undef, pg_current_row => undef, pg_direct => undef, pg_numbound => undef, pg_cmd_status => undef, pg_oid_status => undef, pg_placeholder_dollaronly => undef, pg_prepare_name => undef, pg_prepare_now => undef, pg_segments => undef, pg_server_prepare => undef, pg_size => undef, pg_type => undef, }; } } ## end st section 1; __END__ =head1 NAME DBD::Pg - PostgreSQL database driver for the DBI module =head1 SYNOPSIS use DBI; $dbh = DBI->connect("dbi:Pg:dbname=$dbname", '', '', {AutoCommit => 0}); # The AutoCommit attribute should always be explicitly set # For some advanced uses you may need PostgreSQL type values: use DBD::Pg qw(:pg_types); # For asynchronous calls, import the async constants: use DBD::Pg qw(:async); $dbh->do('INSERT INTO mytable(a) VALUES (1)'); $sth = $dbh->prepare('INSERT INTO mytable(a) VALUES (?)'); $sth->execute(); =head1 VERSION This documents version 2.19.3 of the DBD::Pg module =head1 DESCRIPTION DBD::Pg is a Perl module that works with the DBI module to provide access to PostgreSQL databases. =head1 MODULE DOCUMENTATION This documentation describes driver specific behavior and restrictions. It is not supposed to be used as the only reference for the user. In any case consult the B documentation first! =for html Latest DBI docmentation. =head1 THE DBI CLASS =head2 DBI Class Methods =head3 B This method creates a database handle by connecting to a database, and is the DBI equivalent of the "new" method. To connect to a Postgres database with a minimum of parameters, use the following syntax: $dbh = DBI->connect("dbi:Pg:dbname=$dbname", '', '', {AutoCommit => 0}); This connects to the database named in the C<$dbname> variable on the default port (usually 5432) without any user authentication. The following connect statement shows almost all possible parameters: $dbh = DBI->connect("dbi:Pg:dbname=$dbname;host=$host;port=$port;options=$options", $username, $password, {AutoCommit => 0, RaiseError => 1, PrintError => 0} ); If a parameter is not given, the connect() method will first look for specific environment variables, and then fall back to hard-coded defaults: parameter environment variable hard coded default ------------------------------------------------------ host PGHOST local domain socket hostaddr PGHOSTADDR local domain socket port PGPORT 5432 dbname* PGDATABASE current userid username PGUSER current userid password PGPASSWORD (none) options PGOPTIONS (none) service PGSERVICE (none) sslmode PGSSLMODE (none) * May also use the aliases C or C If the username and password values passed via C are undefined (as opposed to merely being empty strings), DBI will use the environment variables I and I if they exist. You can also connect by using a service connection file, which is named F. The location of this file can be controlled by setting the I environment variable. To use one of the named services within the file, set the name by using either the I parameter or the environment variable I. Note that when connecting this way, only the minimum parameters should be used. For example, to connect to a service named "zephyr", you could use: $dbh = DBI->connect("dbi:Pg:service=zephyr", '', ''); You could also set C<$ENV{PGSERVICE}> to "zephyr" and connect like this: $dbh = DBI->connect("dbi:Pg:", '', ''); The format of the F file is simply a bracketed service name, followed by one parameter per line in the format name=value. For example: [zephyr] dbname=winds user=wisp password=W$2Hc00YSgP port=6543 There are four valid arguments to the I parameter, which controls whether to use SSL to connect to the database: =over 4 =item * disable: SSL connections are never used =item * allow: try non-SSL, then SSL =item * prefer: try SSL, then non-SSL =item * require: connect only with SSL =back You can also connect using sockets in a specific directory. This may be needed if the server you are connecting to has a different default socket directory from the one used to compile DBD::Pg. Use the complete path to the socket directory as the name of the host, like this: $dbh = DBI->connect('dbi:Pg:dbname=foo;host=/var/tmp/socket', $username, $password, {AutoCommit => 0, RaiseError => 1}); The attribute hash can also contain a key named C, which simply calls C<< $dbh->trace('DBD') >> after the handle is created. This attribute is not recommended, as it is clearer to simply explicitly call C explicitly in your script. =head3 B $dbh = DBI->connect_cached("dbi:Pg:dbname=$dbname", $username, $password, \%options); Implemented by DBI, no driver-specific impact. =head3 B @data_sources = DBI->data_sources('Pg'); @data_sources = $dbh->data_sources(); Returns a list of available databases. Unless the environment variable C is set, a connection will be attempted to the database C. The normal connection environment variables also apply, such as C, C, C, C, and C. You can also pass in options to add to the connection string For example, to specify an alternate port and host: @data_sources = DBI->data_sources('Pg', 'port=5824;host=example.com'); or: @data_sources = $dbh->data_sources('port=5824;host=example.com'); =head2 Methods Common To All Handles For all of the methods below, B<$h> can be either a database handle (B<$dbh>) or a statement handle (B<$sth>). Note that I<$dbh> and I<$sth> can be replaced with any variable name you choose: these are just the names most often used. Another common variable used in this documentation is $I, which stands for "return value". =head3 B $rv = $h->err; Returns the error code from the last method called. For the connect method it returns C, which is a number used by I (the Postgres connection library). A value of 0 indicates no error (CONNECTION_OK), while any other number indicates a failed connection. The only other number commonly seen is 1 (CONNECTION_BAD). See the libpq documentation for the complete list of return codes. In all other non-connect methods C<< $h->err >> returns the C of the current handle. This is a number used by libpq and is one of: 0 Empty query string 1 A command that returns no data successfully completed. 2 A command that returns data sucessfully completed. 3 A COPY OUT command is still in progress. 4 A COPY IN command is still in progress. 5 A bad response was received from the backend. 6 A nonfatal error occurred (a notice or warning message) 7 A fatal error was returned: the last query failed. =head3 B $str = $h->errstr; Returns the last error that was reported by Postgres. This message is affected by the L setting. =head3 B $str = $h->state; Returns a five-character "SQLSTATE" code. Success is indicated by a C<00000> code, which gets mapped to an empty string by DBI. A code of C indicates a connection failure, usually because the connection to the Postgres server has been lost. While this method can be called as either C<< $sth->state >> or C<< $dbh->state >>, it is usually clearer to always use C<< $dbh->state >>. The list of codes used by PostgreSQL can be found at: L Note that these codes are part of the SQL standard and only a small number of them will be used by PostgreSQL. Common codes: 00000 Successful completion 25P01 No active SQL transaction 25P02 In failed SQL transaction S8006 Connection failure =head3 B $h->trace($trace_settings); $h->trace($trace_settings, $trace_filename); $trace_settings = $h->trace; Changes the trace settings on a database or statement handle. The optional second argument specifies a file to write the trace information to. If no filename is given, the information is written to F. Note that tracing can be set globally as well by setting C<< DBI->trace >>, or by using the environment variable I. The value is either a numeric level or a named flag. For the flags that DBD::Pg uses, see L. =head3 B $h->trace_msg($message_text); $h->trace_msg($message_text, $min_level); Writes a message to the current trace output (as set by the L method). If a second argument is given, the message is only written if the current tracing level is equal to or greater than the C<$min_level>. =head3 B and B $h->trace($h->parse_trace_flags('SQL|pglibpq')); $h->trace($h->parse_trace_flags('1|pgstart')); ## Simpler: $h->trace('SQL|pglibpq'); $h->trace('1|pgstart'); my $value = DBD::Pg->parse_trace_flag('pglibpq'); DBI->trace($value); The parse_trace_flags method is used to convert one or more named flags to a number which can passed to the L method. DBD::Pg currently supports the DBI-specific flag, C, as well as the ones listed below. Flags can be combined by using the parse_trace_flags method, which simply calls C on each item and combines them. Sometimes you may wish to turn the tracing on before you connect to the database. The second example above shows a way of doing this: the call to C<< DBD::Pg->parse_trace_flags >> provides a number than can be fed to C<< DBI->trace >> before you create a database handle. DBD::Pg supports the following trace flags: =over 4 =item SQL Outputs all SQL statements. Note that the output provided will not necessarily be in a form suitable to passing directly to Postgres, as server-side prepared statements are used extensively by DBD::Pg. For maximum portability of output (but with a potential performance hit), use with C<< $dbh->{pg_server_prepare} = 0 >>. =item DBD Turns on all non-DBI flags, in other words, only the ones that are specific to DBD::Pg (all those below which start with the letters 'pg'). =item pglibpq Outputs the name of each libpq function (without arguments) immediately before running it. This is a good way to trace the flow of your program at a low level. This information is also output if the trace level is set to 4 or greater. =item pgstart Outputs the name of each internal DBD::Pg function, and other information such as the function arguments or important global variables, as each function starts. This information is also output if the trace level is set to 4 or greater. =item pgend Outputs a simple message at the very end of each internal DBD::Pg function. This is also output if the trace level is set to 4 or greater. =item pgprefix Forces each line of trace output to begin with the string B>. This helps to differentiate it from the normal DBI trace output. =item pglogin Outputs a message showing the connection string right before a new database connection is attempted, a message when the connection was successful, and a message right after the database has been disconnected. Also output if trace level is 5 or greater. =back =for text See the DBI section on TRACING for more information. =for html See the DBI section on TRACING for more information.
=head3 B DBD::Pg uses the C method to support a variety of functions. Note that the name of the function comes I, after the arguments. =over =item table_attributes $attrs = $dbh->func($table, 'table_attributes'); Use of the tables_attributes function is no longer recommended. Instead, you can use the more portable C and C methods to access the same information. The table_attributes method returns, for the given table argument, a reference to an array of hashes, each of which contains the following keys: NAME attribute name TYPE attribute type SIZE attribute size (-1 for variable size) NULLABLE flag nullable DEFAULT default value CONSTRAINT constraint PRIMARY_KEY flag is_primary_key REMARKS attribute description =item pg_lo_creat $lobjId = $dbh->pg_lo_creat($mode); Creates a new large object and returns the object-id. C<$mode> is a bitmask describing read and write access to the new object. This setting is ignored since Postgres version 8.1. For backwards compatibility, however, you should set a valid mode anyway (see L for a list of valid modes). Upon failure it returns C. This function cannot be used if AutoCommit is enabled. The old way of calling large objects functions is deprecated: $dbh->func(.., 'lo_); =item lo_open $lobj_fd = $dbh->pg_lo_open($lobjId, $mode); Opens an existing large object and returns an object-descriptor for use in subsequent C calls. C<$mode> is a bitmask describing read and write access to the opened object. It may be one of: $dbh->{pg_INV_READ} $dbh->{pg_INV_WRITE} $dbh->{pg_INV_READ} | $dbh->{pg_INV_WRITE} C and C modes are identical; in both modes, the large object can be read from or written to. Reading from the object will provide the object as written in other committed transactions, along with any writes performed by the current transaction. Objects opened with C cannot be written to. Reading from this object will provide the stored data at the time of the transaction snapshot which was active when C was called. Returns C upon failure. Note that 0 is a perfectly correct (and common) object descriptor! This function cannot be used if AutoCommit is enabled. =item lo_write $nbytes = $dbh->pg_lo_write($lobj_fd, $buffer, $len); Writes C<$len> bytes of c<$buffer> into the large object C<$lobj_fd>. Returns the number of bytes written and C upon failure. This function cannot be used if AutoCommit is enabled. =item lo_read $nbytes = $dbh->pg_lo_read($lobj_fd, $buffer, $len); Reads C<$len> bytes into c<$buffer> from large object C<$lobj_fd>. Returns the number of bytes read and C upon failure. This function cannot be used if AutoCommit is enabled. =item lo_lseek $loc = $dbh->pg_lo_lseek($lobj_fd, $offset, $whence); Changes the current read or write location on the large object C<$obj_id>. Currently C<$whence> can only be 0 (which is L_SET). Returns the current location and C upon failure. This function cannot be used if AutoCommit is enabled. =item lo_tell $loc = $dbh->pg_lo_tell($lobj_fd); Returns the current read or write location on the large object C<$lobj_fd> and C upon failure. This function cannot be used if AutoCommit is enabled. =item lo_close $lobj_fd = $dbh->pg_lo_close($lobj_fd); Closes an existing large object. Returns true upon success and false upon failure. This function cannot be used if AutoCommit is enabled. =item lo_unlink $ret = $dbh->pg_lo_unlink($lobjId); Deletes an existing large object. Returns true upon success and false upon failure. This function cannot be used if AutoCommit is enabled. =item lo_import $lobjId = $dbh->pg_lo_import($filename); Imports a Unix file as a large object and returns the object id of the new object or C upon failure. =item lo_import_with_oid $lobjId = $dbh->pg_lo_import($filename, $OID); Same as lo_import, but attempts to use the supplied OID as the large object number. If this number is 0, it falls back to the behavior of lo_import (which assigns the next available OID). This is only available when DBD::Pg is compiled against a Postgres server version 8.4 or later. =item lo_export $ret = $dbh->pg_lo_export($lobjId, $filename); Exports a large object into a Unix file. Returns false upon failure, true otherwise. =item getfd $fd = $dbh->func('getfd'); Deprecated, use L<< $dbh->{pg_socket}|/pg_socket >> instead. =back =head3 B $hashref = $dbh->private_attribute_info(); $hashref = $sth->private_attribute_info(); Returns a hash of all private attributes used by DBD::Pg, for either a database or a statement handle. Currently, all the hash values are undef. =head1 ATTRIBUTES COMMON TO ALL HANDLES =head3 B (boolean) If set to true, then the L method will not be automatically called when the database handle goes out of scope. This is required if you are forking, and even then you must tread carefully and ensure that either the parent or the child (but not both!) handles all database calls from that point forwards, so that messages from the Postgres backend are only handled by one of the processes. If you don't set things up properly, you will see messages such as "I", and "I". The best solution is to either have the child process reconnect to the database with a fresh database handle, or to rewrite your application not to use use forking. See the section on L for a way to have your script continue to work while the database is processing a request. =head3 B (boolean, inherited) Forces errors to always raise an exception. Although it defaults to off, it is recommended that this be turned on, as the alternative is to check the return value of every method (prepare, execute, fetch, etc.) manually, which is easy to forget to do. =head3 B (boolean, inherited) Forces database errors to also generate warnings, which can then be filtered with methods such as locally redefining I<$SIG{__WARN__}> or using modules such as C. This attribute is on by default. =head3 B (boolean, inherited) Appends information about the current statement to error messages. If placeholder information is available, adds that as well. Defaults to false. =head3 B (boolean, inherited) Enables warnings. This is on by default, and should only be turned off in a local block for a short a time only when absolutely needed. =head3 B (boolean, read-only) Indicates if a handle has been executed. For database handles, this value is true after the L method has been called, or when one of the child statement handles has issued an L. Issuing a L or L always resets the attribute to false for database handles. For statement handles, any call to L or its variants will flip the value to true for the lifetime of the statement handle. =head3 B (integer, inherited) Sets the trace level, similar to the L method. See the sections on L and L for more details. =head3 B (boolean, read-only) Indicates if a handle is active or not. For database handles, this indicates if the database has been disconnected or not. For statement handles, it indicates if all the data has been fetched yet or not. Use of this attribute is not encouraged. =head3 B (integer, read-only) Returns the number of child processes created for each handle type. For a driver handle, indicates the number of database handles created. For a database handle, indicates the number of statement handles created. For statement handles, it always returns zero, because statement handles do not create kids. =head3 B (integer, read-only) Same as C, but only returns those that are active. =head3 B (hash ref) Returns a hashref of handles. If called on a database handle, returns all statement handles created by use of the C method. If called on a driver handle, returns all database handles created by the L method. =head3 B (array ref) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (code ref, inherited) Implemented by DBI, no driver-specific impact. =head3 B (unsigned integer) Implemented by DBI, no driver-specific impact. =head3 B (string, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Supported by DBD::Pg as proposed by DBI. This method is similar to the SQL function C. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (inherited) Implemented by DBI, no driver-specific impact. =head3 B (scalar) Returns C for a driver handle, C for a database handle, and C for a statement handle. Should be rarely needed. =head3 B Not used by DBD::Pg =head3 B Not used by DBD::Pg =head3 B Not used by DBD::Pg =head1 DBI DATABASE HANDLE OBJECTS =head2 Database Handle Methods =head3 B $ary_ref = $dbh->selectall_arrayref($sql); $ary_ref = $dbh->selectall_arrayref($sql, \%attr); $ary_ref = $dbh->selectall_arrayref($sql, \%attr, @bind_values); Returns a reference to an array containing the rows returned by preparing and executing the SQL string. See the DBI documentation for full details. =head3 B $hash_ref = $dbh->selectall_hashref($sql, $key_field); Returns a reference to a hash containing the rows returned by preparing and executing the SQL string. See the DBI documentation for full details. =head3 B $ary_ref = $dbh->selectcol_arrayref($sql, \%attr, @bind_values); Returns a reference to an array containing the first column from each rows returned by preparing and executing the SQL string. It is possible to specify exactly which columns to return. See the DBI documentation for full details. =head3 B $sth = $dbh->prepare($statement, \%attr); WARNING: DBD::Pg now (as of version 1.40) uses true prepared statements by sending them to the backend to be prepared by the Postgres server. Statements that were legal before may no longer work. See below for details. The prepare method prepares a statement for later execution. PostgreSQL supports prepared statements, which enables DBD::Pg to only send the query once, and simply send the arguments for every subsequent call to L. DBD::Pg can use these server-side prepared statements, or it can just send the entire query to the server each time. The best way is automatically chosen for each query. This will be sufficient for most users: keep reading for a more detailed explanation and some optional flags. Queries that do not begin with the word "SELECT", "INSERT", "UPDATE", or "DELETE" are never sent as server-side prepared statements. Deciding whether or not to use prepared statements depends on many factors, but you can force them to be used or not used by using the L attribute when calling L. Setting this to "0" means to never use prepared statements. Setting L to "1" means that prepared statements should be used whenever possible. This is the default when connected to Postgres servers version 8.0 or higher. Servers that are version 7.4 get a special default value of "2", because server-side statements were only partially supported in that version. In this case, it only uses server-side prepares if all parameters are specifically bound. The L attribute can also be set at connection time like so: $dbh = DBI->connect($DBNAME, $DBUSER, $DBPASS, { AutoCommit => 0, RaiseError => 1, pg_server_prepare => 0, }); or you may set it after your database handle is created: $dbh->{pg_server_prepare} = 1; To enable it for just one particular statement: $sth = $dbh->prepare("SELECT id FROM mytable WHERE val = ?", { pg_server_prepare => 1 }); You can even toggle between the two as you go: $sth->{pg_server_prepare} = 1; $sth->execute(22); $sth->{pg_server_prepare} = 0; $sth->execute(44); $sth->{pg_server_prepare} = 1; $sth->execute(66); In the above example, the first execute will use the previously prepared statement. The second execute will not, but will build the query into a single string and send it to the server. The third one will act like the first and only send the arguments. Even if you toggle back and forth, a statement is only prepared once. Using prepared statements is in theory quite a bit faster: not only does the PostgreSQL backend only have to prepare the query only once, but DBD::Pg no longer has to worry about quoting each value before sending it to the server. However, there are some drawbacks. The server cannot always choose the ideal parse plan because it will not know the arguments before hand. But for most situations in which you will be executing similar data many times, the default plan will probably work out well. Programs such as PgBouncer which cache connections at a low level should not use prepared statements via DBD::Pg, or must take extra care in the application to account for the fact that prepared statements are not shared across database connections. Further discussion on this subject is beyond the scope of this documentation: please consult the pgsql-performance mailing list, L Only certain commands will be sent to a server-side prepare: currently these include C statements. The "prepare/bind/execute" process has changed significantly for PostgreSQL servers 7.4 and later: please see the C and C entries for much more information. Setting one of the bind_values to "undef" is the equivalent of setting the value to NULL in the database. Setting the bind_value to $DBDPG_DEFAULT is equivalent to sending the literal string 'DEFAULT' to the backend. Note that using this option will force server-side prepares off until such time as PostgreSQL supports using DEFAULT in prepared statements. DBD::Pg also supports passing in arrays to execute: simply pass in an arrayref, and DBD::Pg will flatten it into a string suitable for input on the backend. If you are using Postgres version 8.2 or greater, you can also use any of the fetch methods to retrieve the values of a C clause after you execute an C, C, or C. For example: $dbh->do(q{CREATE TABLE abc (id SERIAL, country TEXT)}); $SQL = q{INSERT INTO abc (country) VALUES (?) RETURNING id}; $sth = $dbh->prepare($SQL); $sth->execute('France'); $countryid = $sth->fetch()->[0]; $sth->execute('New Zealand'); $countryid = $sth->fetch()->[0]; =head3 B $tuples = $sth->execute_array() or die $sth->errstr; $tuples = $sth->execute_array(\%attr) or die $sth->errstr; $tuples = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr; ($tuples, $rows) = $sth->execute_array(\%attr) or die $sth->errstr; ($tuples, $rows) = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr; Execute a prepared statement once for each item in a passed-in hashref, or items that were previously bound via the L method. See the DBI documentation for more details. =head3 B $tuples = $sth->execute_for_fetch($fetch_tuple_sub); $tuples = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status); ($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub); ($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status); Used internally by the L method, and rarely used directly. See the DBI documentation for more details. =head3 B $ary_ref = $sth->fetchrow_arrayref; Fetches the next row of data from the statement handle, and returns a reference to an array holding the column values. Any columns that are NULL are returned as undef within the array. If there are no more rows or if an error occurs, the this method return undef. You should check C<< $sth->err >> afterwards (or use the L attribute) to discover if the undef returned was due to an error. Note that the same array reference is returned for each fetch, so don't store the reference and then use it after a later fetch. Also, the elements of the array are also reused for each row, so take care if you want to take a reference to an element. See also L. =head3 B @ary = $sth->fetchrow_array; Similar to the L method, but returns a list of column information rather than a reference to a list. Do not use this in a scalar context. =head3 B $hash_ref = $sth->fetchrow_hashref; $hash_ref = $sth->fetchrow_hashref($name); Fetches the next row of data and returns a hashref containing the name of the columns as the keys and the data itself as the values. Any NULL value is returned as as undef value. If there are no more rows or if an error occurs, the this method return undef. You should check C<< $sth->err >> afterwards (or use the L attribute) to discover if the undef returned was due to an error. The optional C<$name> argument should be either C, C or C, and indicates what sort of transformation to make to the keys in the hash. =head3 B $tbl_ary_ref = $sth->fetchall_arrayref(); $tbl_ary_ref = $sth->fetchall_arrayref( $slice ); $tbl_ary_ref = $sth->fetchall_arrayref( $slice, $max_rows ); Returns a reference to an array of arrays that contains all the remaining rows to be fetched from the statement handle. If there are no more rows, an empty arrayref will be returned. If an error occurs, the data read in so far will be returned. Because of this, you should always check C<< $sth->err >> after calling this method, unless L has been enabled. If C<$slice> is an array reference, fetchall_arrayref uses the L method to fetch each row as an array ref. If the C<$slice> array is not empty then it is used as a slice to select individual columns by perl array index number (starting at 0, unlike column and parameter numbers which start at 1). With no parameters, or if $slice is undefined, fetchall_arrayref acts as if passed an empty array ref. If C<$slice> is a hash reference, fetchall_arrayref uses L to fetch each row as a hash reference. See the DBI documentation for a complete discussion. =head3 B $hash_ref = $sth->fetchall_hashref( $key_field ); Returns a hashref containing all rows to be fetched from the statement handle. See the DBI documentation for a full discussion. =head3 B $rv = $sth->finish; Indicates to DBI that you are finished with the statement handle and are not going to use it again. Only needed when you have not fetched all the possible rows. =head3 B $rv = $sth->rows; Returns the number of rows returned by the last query. In contrast to many other DBD modules, the number of rows is available immediately after calling C<< $sth->execute >>. Note that the L method itself returns the number of rows itself, which means that this method is rarely needed. =head3 B $rv = $sth->bind_col($column_number, \$var_to_bind); $rv = $sth->bind_col($column_number, \$var_to_bind, \%attr ); $rv = $sth->bind_col($column_number, \$var_to_bind, $bind_type ); Binds a Perl variable and/or some attributes to an output column of a SELECT statement. Column numbers count up from 1. You do not need to bind output columns in order to fetch data. See the DBI documentation for a discussion of the optional parameters C<\%attr> and C<$bind_type> =head3 B $rv = $sth->bind_columns(@list_of_refs_to_vars_to_bind); Calls the L method for each column in the SELECT statement, using the supplied list. =head3 B $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh); Fetches all the rows from the statement handle, calls C for each row, and prints the results to C<$fh> (which defaults to F). Rows are separated by C<$lsep> (which defaults to a newline). Columns are separated by C<$fsep> (which defaults to a comma). The C<$maxlen> controls how wide the output can be, and defaults to 35. This method is designed as a handy utility for prototyping and testing queries. Since it uses "neat_list" to format and edit the string for reading by humans, it is not recommended for data transfer applications. =head3 B $blob = $sth->blob_read($id, $offset, $len); Supported by DBD::Pg. This method is implemented by DBI but not currently documented by DBI, so this method might change. This method seems to be heavily influenced by the current implementation of blobs in Oracle. Nevertheless we try to be as compatible as possible. Whereas Oracle suffers from the limitation that blobs are related to tables and every table can have only one blob (datatype LONG), PostgreSQL handles its blobs independent of any table by using so-called object identifiers. This explains why the C method is blessed into the STATEMENT package and not part of the DATABASE package. Here the field parameter has been used to handle this object identifier. The offset and len parameters may be set to zero, in which case the whole blob is fetched at once. See also the PostgreSQL-specific functions concerning blobs, which are available via the C interface. For further information and examples about blobs, please read the chapter about Large Objects in the PostgreSQL Programmer's Guide at L. =head2 Statement Handle Attributes =head3 B (integer, read-only) Returns the number of columns returned by the current statement. A number will only be returned for SELECT statements, for SHOW statements (which always return C<1>), and for INSERT, UPDATE, and DELETE statements which contain a RETURNING clause. This method returns undef if called before C. =head3 B (integer, read-only) Returns the number of placeholders in the current statement. =head3 B (arrayref, read-only) Returns an arrayref of column names for the current statement. This method will only work for SELECT statements, for SHOW statements, and for INSERT, UPDATE, and DELETE statements which contain a RETURNING clause. This method returns undef if called before C. =head3 B (arrayref, read-only) The same as the C attribute, except that all column names are forced to lower case. =head3 B (arrayref, read-only) The same as the C attribute, except that all column names are forced to upper case. =head3 B (hashref, read-only) Similar to the C attribute, but returns a hashref of column names instead of an arrayref. The names of the columns are the keys of the hash, and the values represent the order in which the columns are returned, starting at 0. This method returns undef if called before C. =head3 B (hashref, read-only) The same as the C attribute, except that all column names are forced to lower case. =head3 B (hashref, read-only) The same as the C attribute, except that all column names are forced to lower case. =head3 B (arrayref, read-only) Returns an arrayref indicating the data type for each column in the statement. This method returns undef if called before C. =head3 B (arrayref, read-only) Returns an arrayref of integer values for each column returned by the statement. The number indicates the precision for C columns, the size in number of characters for C and C columns, and for all other types of columns it returns the number of I. This method returns undef if called before C. =head3 B (arrayref, read-only) Returns an arrayref of integer values for each column returned by the statement. The number indicates the scale of the that column. The only type that will return a value is C. This method returns undef if called before C. =head3 B (arrayref, read-only) Returns an arrayref of integer values for each column returned by the statement. The number indicates if the column is nullable or not. 0 = not nullable, 1 = nullable, 2 = unknown. This method returns undef if called before C. =head3 B (dbh, read-only) Returns the database handle this statement handle was created from. =head3 B (hash ref, read-only) Returns a reference to a hash containing the values currently bound to placeholders. If the "named parameters" type of placeholders are being used (such as ":foo"), then the keys of the hash will be the names of the placeholders (without the colon). If the "dollar sign numbers" type of placeholders are being used, the keys of the hash will be the numbers, without the dollar signs. If the "question mark" type is used, integer numbers will be returned, starting at one and increasing for every placeholder. If this method is called before L, the literal values passed in are returned. If called after L, then the quoted versions of the values are returned. =head3 B (hash ref, read-only) Returns a reference to a hash containing the type names currently bound to placeholders. The keys are the same as returned by the ParamValues method. The values are hashrefs containing a single key value pair, in which the key is either 'TYPE' if the type has a generic SQL equivalent, and 'pg_type' if the type can only be expressed by a Postgres type. The value is the internal number corresponding to the type originally passed in. (Placeholders that have not yet been bound will return undef as the value). This allows the output of ParamTypes to be passed back to the L method. =head3 B (string, read-only) Returns the statement string passed to the most recent "prepare" method called in this database handle, even if that method failed. This is especially useful where "RaiseError" is enabled and the exception handler checks $@ and sees that a C method call failed. =head3 B (integer, read-only) DBD::Pg specific attribute. Returns the number of the tuple (row) that was most recently fetched. Returns zero before and after fetching is performed. =head3 B (integer, read-only) DBD::Pg specific attribute. Returns the number of placeholders that are currently bound (via bind_param). =head3 B (hashref, read-only) DBD::Pg specific attribute. Returns a hash of all named placeholders. The key is the name of the placeholder, and the value is a 0 or a 1, indicating if the placeholder has been bound yet (e.g. via bind_param) =head3 B (arrayref, read-only) DBD::Pg specific attribute. It returns a reference to an array of integer values for each column. The integer shows the size of the column in bytes. Variable length columns are indicated by -1. =head3 B (arrayref, read-only) DBD::Pg specific attribute. It returns a reference to an array of strings for each column. The string shows the name of the data_type. =head3 B (arrayref, read-only) DBD::Pg specific attribute. Returns an arrayref of the query split on the placeholders. =head3 B (integer, read-only) DBD::Pg specific attribute. It returns the OID of the last INSERT command. =head3 B (integer, read-only) DBD::Pg specific attribute. It returns the type of the last command. Possible types are: "INSERT", "DELETE", "UPDATE", "SELECT". =head3 B (boolean) DBD::Pg specific attribute. Default is false. If true, the query is passed directly to the backend without parsing for placeholders. =head3 B (boolean) DBD::Pg specific attribute. Default is off. If true, the query will be immediately prepared, rather than waiting for the L call. =head3 B (string) DBD::Pg specific attribute. Specifies the name of the prepared statement to use for this statement handle. Not normally needed, see the section on the L method for more information. =head3 B (integer) DBD::Pg specific attribute. Indicates if DBD::Pg should attempt to use server-side prepared statements for this statement handle. The default value, 1, indicates that prepared statements should be used whenever possible. See the section on the L method for more information. =head3 B (boolean) DBD::Pg specific attribute. Defaults to off. When true, question marks inside of the query being prepared are not treated as placeholders. Useful for statements that contain unquoted question marks, such as geometric operators. =head3 B (integer) DBD::Pg specific attribute. Indicates the current behavior for asynchronous queries. See the section on L for more information. =head3 B Not used by DBD::Pg =head3 B Not used by DBD::Pg =head3 B Not used by DBD::Pg. See the note about L elsewhere in this document. =head1 FURTHER INFORMATION =head2 Transactions Transaction behavior is controlled via the L attribute. For a complete definition of C please refer to the DBI documentation. According to the DBI specification the default for C is a true value. In this mode, any change to the database becomes valid immediately. Any C, C or C statements will be rejected. DBD::Pg implements C by issuing a C statement immediately before executing a statement, and a C afterwards. Note that preparing a statement is not always enough to trigger the first C, as the actual C is usually postponed until the first call to L. =head2 Savepoints PostgreSQL version 8.0 introduced the concept of savepoints, which allows transactions to be rolled back to a certain point without affecting the rest of the transaction. DBD::Pg encourages using the following methods to control savepoints: =head3 C Creates a savepoint. This will fail unless you are inside of a transaction. The only argument is the name of the savepoint. Note that PostgreSQL DOES allow multiple savepoints with the same name to exist. $dbh->pg_savepoint("mysavepoint"); =head3 C Rolls the database back to a named savepoint, discarding any work performed after that point. If more than one savepoint with that name exists, rolls back to the most recently created one. $dbh->pg_rollback_to("mysavepoint"); =head3 C Releases (or removes) a named savepoint. If more than one savepoint with that name exists, it will only destroy the most recently created one. Note that all savepoints created after the one being released are also destroyed. $dbh->pg_release("mysavepoint"); =head2 Asynchronous Queries It is possible to send a query to the backend and have your script do other work while the query is running on the backend. Both queries sent by the L method, and by the L method can be sent asynchronously. (NOTE: This will only work if DBD::Pg has been compiled against Postgres libraries of version 8.0 or greater) The basic usage is as follows: use DBD::Pg ':async'; print "Async do() example:\n"; $dbh->do("SELECT long_running_query()", {pg_async => PG_ASYNC}); do_something_else(); { if ($dbh->pg_ready()) { $res = $dbh->pg_result(); print "Result of do(): $res\n"; } print "Query is still running...\n"; if (cancel_request_received) { $dbh->pg_cancel(); } sleep 1; redo; } print "Async prepare/execute example:\n"; $sth = $dbh->prepare("SELECT long_running_query(1)", {pg_async => PG_ASYNC}); $sth->execute(); ## Changed our mind, cancel and run again: $sth = $dbh->prepare("SELECT 678", {pg_async => PG_ASYNC + PG_OLDQUERY_CANCEL}); $sth->execute(); do_something_else(); if (!$sth->pg_ready) { do_another_thing(); } ## We wait until it is done, and get the result: $res = $dbh->pg_result(); =head3 Asynchronous Constants There are currently three asynchronous constants exported by DBD::Pg. You can import all of them by putting either of these at the top of your script: use DBD::Pg; use DBD::Pg ':async'; You may also use the numbers instead of the constants, but using the constants is recommended as it makes your script more readable. =over 4 =item PG_ASYNC This is a constant for the number 1. It is passed to either the L or the L method as a value to the pg_async key and indicates that the query should be sent asynchronously. =item PG_OLDQUERY_CANCEL This is a constant for the number 2. When passed to either the L or the L method, it causes any currently running asynchronous query to be cancelled and rolled back. It has no effect if no asynchronous query is currently running. =item PG_OLDQUERY_WAIT This is a constant for the number 4. When passed to either the L or the L method, it waits for any currently running asynchronous query to complete. It has no effect if there is no asynchronous query currently running. =back =head3 Asynchronous Methods =over 4 =item B This database-level method attempts to cancel any currently running asynchronous query. It returns true if the cancel succeeded, and false otherwise. Note that a query that has finished before this method is executed will also return false. B: a successful cancellation may leave the database in an unusable state, so you may need to ROLLBACK or ROLLBACK TO a savepoint. As of version 2.17.0 of DBD::Pg, rollbacks are not done automatically. $result = $dbh->pg_cancel(); =item B This method can be called as a database handle method or (for convenience) as a statement handle method. Both simply see if a previously issued asynchronous query has completed yet. It returns true if the statement has finished, in which case you should then call the L method. Calls to C should only be used when you have other things to do while the query is running. If you simply want to wait until the query is done, do not call pg_ready() over and over, but simply call the pg_result() method. my $time = 0; while (!$dbh->pg_ready) { print "Query is still running. Seconds: $time\n"; $time++; sleep 1; } $result = $dbh->pg_result; =item B This database handle method returns the results of a previously issued asynchronous query. If the query is still running, this method will wait until it has finished. The result returned is the number of rows: the same thing that would have been returned by the asynchronous L or L if it had been called without an asynchronous flag. $result = $dbh->pg_result; =back =head3 Asynchronous Examples Here are some working examples of asynchronous queries. Note that we'll use the B function to emulate a long-running query. use strict; use warnings; use Time::HiRes 'sleep'; use DBD::Pg ':async'; my $dbh = DBI->connect('dbi:Pg:dbname=postgres', 'postgres', '', {AutoCommit=>0,RaiseError=>1}); ## Kick off a long running query on the first database: my $sth = $dbh->prepare("SELECT pg_sleep(?)", {pg_async => PG_ASYNC}); $sth->execute(5); ## While that is running, do some other things print "Your query is processing. Thanks for waiting\n"; check_on_the_kids(); ## Expensive sub, takes at least three seconds. while (!$dbh->pg_ready) { check_on_the_kids(); ## If the above function returns quickly for some reason, we add a small sleep sleep 0.1; } print "The query has finished. Gathering results\n"; my $result = $sth->pg_result; print "Result: $result\n"; my $info = $sth->fetchall_arrayref(); Without asynchronous queries, the above script would take about 8 seconds to run: five seconds waiting for the execute to finish, then three for the check_on_the_kids() function to return. With asynchronous queries, the script takes about 6 seconds to run, and gets in two iterations of check_on_the_kids in the process. Here's an example showing the ability to cancel a long-running query. Imagine two slave databases in different geographic locations over a slow network. You need information as quickly as possible, so you query both at once. When you get an answer, you tell the other one to stop working on your query, as you don't need it anymore. use strict; use warnings; use Time::HiRes 'sleep'; use DBD::Pg ':async'; my $dbhslave1 = DBI->connect('dbi:Pg:dbname=postgres;host=slave1', 'postgres', '', {AutoCommit=>0,RaiseError=>1}); my $dbhslave2 = DBI->connect('dbi:Pg:dbname=postgres;host=slave2', 'postgres', '', {AutoCommit=>0,RaiseError=>1}); $SQL = "SELECT count(*) FROM largetable WHERE flavor='blueberry'"; my $sth1 = $dbhslave1->prepare($SQL, {pg_async => PG_ASYNC}); my $sth2 = $dbhslave2->prepare($SQL, {pg_async => PG_ASYNC}); $sth1->execute(); $sth2->execute(); my $winner; while (!defined $winner) { if ($sth1->pg_ready) { $winner = 1; } elsif ($sth2->pg_ready) { $winner = 2; } Time::HiRes::sleep 0.05; } my $count; if ($winner == 1) { $sth2->pg_cancel(); $sth1->pg_result(); $count = $sth1->fetchall_arrayref()->[0][0]; } else { $sth1->pg_cancel(); $sth2->pg_result(); $count = $sth2->fetchall_arrayref()->[0][0]; } =head2 Array support DBD::Pg allows arrays (as arrayrefs) to be passed in to both the L and the L methods. In both cases, the array is flattened into a string representing a Postgres array. When fetching rows from a table that contains a column with an array type, the result will be passed back to your script as an arrayref. To turn off the automatic parsing of returned arrays into arrayrefs, you can set the attribute L, which is true by default. $dbh->{pg_expand_array} = 0; =head2 COPY support DBD::Pg allows for quick (bulk) reading and storing of data by using the B command. The basic process is to use C<< $dbh->do >> to issue a COPY command, and then to either add rows using L, or to read them by using L. The first step is to put the server into "COPY" mode. This is done by sending a complete COPY command to the server, by using the L method. For example: $dbh->do("COPY foobar FROM STDIN"); This would tell the server to enter a COPY IN mode (yes, that's confusing, but the I is COPY IN because of the I COPY FROM). It is now ready to receive information via the L method. The complete syntax of the COPY command is more complex and not documented here: the canonical PostgreSQL documentation for COPY can be found at: http://www.postgresql.org/docs/current/static/sql-copy.html Once a COPY command has been issued, no other SQL commands are allowed until L has been issued (for COPY FROM), or the final L has been called (for COPY TO). Note: All other COPY methods (pg_putline, pg_getline, etc.) are now heavily deprecated in favor of the pg_getcopydata, pg_putcopydata, and pg_putcopyend methods. =head3 B Used to retrieve data from a table after the server has been put into a COPY OUT mode by calling "COPY tablename TO STDOUT". Data is always returned one data row at a time. The first argument to pg_getcopydata is the variable into which the data will be stored (this variable should not be undefined, or it may throw a warning, although it may be a reference). The pg_gecopydata method returns a number greater than 1 indicating the new size of the variable, or a -1 when the COPY has finished. Once a -1 has been returned, no other action is necessary, as COPY mode will have already terminated. Example: $dbh->do("COPY mytable TO STDOUT"); my @data; my $x=0; 1 while $dbh->pg_getcopydata($data[$x++]) >= 0; There is also a variation of this method called B, which, as the name suggests, returns immediately. The only difference from the original method is that this version may return a 0, indicating that the row is not ready to be delivered yet. When this happens, the variable has not been changed, and you will need to call the method again until you get a non-zero result. (Data is still always returned one data row at a time.) =head3 B Used to put data into a table after the server has been put into COPY IN mode by calling "COPY tablename FROM STDIN". The only argument is the data you want inserted. Issue a pg_putcopyend() when you have added all your rows. The default delimiter is a tab character, but this can be changed in the COPY statement. Returns a 1 on successful input. Examples: ## Simple example: $dbh->do("COPY mytable FROM STDIN"); $dbh->pg_putcopydata("123\tPepperoni\t3\n"); $dbh->pg_putcopydata("314\tMushroom\t8\n"); $dbh->pg_putcopydata("6\tAnchovies\t100\n"); $dbh->pg_putcopyend(); ## This example uses explicit columns and a custom delimiter $dbh->do("COPY mytable(flavor, slices) FROM STDIN WITH DELIMITER '~'"); $dbh->pg_putcopydata("Pepperoni~123\n"); $dbh->pg_putcopydata("Mushroom~314\n"); $dbh->pg_putcopydata("Anchovies~6\n"); $dbh->pg_putcopyend(); =head3 B When you are finished with pg_putcopydata, call pg_putcopyend to let the server know that you are done, and it will return to a normal, non-COPY state. Returns a 1 on success. This method will fail if called when not in COPY IN mode. =head2 Large Objects DBD::Pg supports all largeobject functions provided by libpq via the C<< $dbh->pg_lo* >> methods. Please note that access to a large object, even read-only large objects, must be put into a transaction. =head2 Cursors Although PostgreSQL supports cursors, they have not been used in the current implementation. When DBD::Pg was created, cursors in PostgreSQL could only be used inside a transaction block. Because only one transaction block at a time is allowed, this would have implied the restriction not to use any nested C