r2536 - in packages: . libdbd-pg-perl libdbd-pg-perl/branches
libdbd-pg-perl/branches/upstream
libdbd-pg-perl/branches/upstream/current
libdbd-pg-perl/branches/upstream/current/t
libdbd-pg-perl/branches/upstream/current/t/lib
libdbd-pg-perl/branches/upstream/current/t/lib/App
libdbd-pg-perl/branches/upstream/current/t/lib/App/Info
libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Handler
libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/RDBMS
Raphaël Hertzog
hertzog at costa.debian.org
Thu Apr 13 20:25:23 UTC 2006
Author: hertzog
Date: 2006-04-13 20:25:19 +0000 (Thu, 13 Apr 2006)
New Revision: 2536
Added:
packages/libdbd-pg-perl/
packages/libdbd-pg-perl/branches/
packages/libdbd-pg-perl/branches/upstream/
packages/libdbd-pg-perl/branches/upstream/current/
packages/libdbd-pg-perl/branches/upstream/current/Changes
packages/libdbd-pg-perl/branches/upstream/current/MANIFEST
packages/libdbd-pg-perl/branches/upstream/current/MANIFEST.SKIP
packages/libdbd-pg-perl/branches/upstream/current/META.yml
packages/libdbd-pg-perl/branches/upstream/current/Makefile.PL
packages/libdbd-pg-perl/branches/upstream/current/Pg.h
packages/libdbd-pg-perl/branches/upstream/current/Pg.pm
packages/libdbd-pg-perl/branches/upstream/current/Pg.xs
packages/libdbd-pg-perl/branches/upstream/current/README
packages/libdbd-pg-perl/branches/upstream/current/README.dev
packages/libdbd-pg-perl/branches/upstream/current/README.win32
packages/libdbd-pg-perl/branches/upstream/current/SIGNATURE
packages/libdbd-pg-perl/branches/upstream/current/TODO
packages/libdbd-pg-perl/branches/upstream/current/dbdimp.c
packages/libdbd-pg-perl/branches/upstream/current/dbdimp.h
packages/libdbd-pg-perl/branches/upstream/current/quote.c
packages/libdbd-pg-perl/branches/upstream/current/quote.h
packages/libdbd-pg-perl/branches/upstream/current/t/
packages/libdbd-pg-perl/branches/upstream/current/t/00-signature.t
packages/libdbd-pg-perl/branches/upstream/current/t/00basic.t
packages/libdbd-pg-perl/branches/upstream/current/t/01connect.t
packages/libdbd-pg-perl/branches/upstream/current/t/01constants.t
packages/libdbd-pg-perl/branches/upstream/current/t/01setup.t
packages/libdbd-pg-perl/branches/upstream/current/t/02attribs.t
packages/libdbd-pg-perl/branches/upstream/current/t/03dbmethod.t
packages/libdbd-pg-perl/branches/upstream/current/t/03smethod.t
packages/libdbd-pg-perl/branches/upstream/current/t/04misc.t
packages/libdbd-pg-perl/branches/upstream/current/t/05arrays.t
packages/libdbd-pg-perl/branches/upstream/current/t/06bytea.t
packages/libdbd-pg-perl/branches/upstream/current/t/07copy.t
packages/libdbd-pg-perl/branches/upstream/current/t/12placeholders.t
packages/libdbd-pg-perl/branches/upstream/current/t/20savepoints.t
packages/libdbd-pg-perl/branches/upstream/current/t/99_pod.t
packages/libdbd-pg-perl/branches/upstream/current/t/99cleanup.t
packages/libdbd-pg-perl/branches/upstream/current/t/lib/
packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/
packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info.pm
packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/
packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Handler.pm
packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Handler/
packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Handler/Prompt.pm
packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/RDBMS.pm
packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/RDBMS/
packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/RDBMS/PostgreSQL.pm
packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Request.pm
packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Util.pm
packages/libdbd-pg-perl/branches/upstream/current/types.c
packages/libdbd-pg-perl/branches/upstream/current/types.h
packages/libdbd-pg-perl/branches/upstream/current/win32.mak
packages/libdbd-pg-perl/tags/
Log:
[svn-inject] Installing original source of libdbd-pg-perl
Added: packages/libdbd-pg-perl/branches/upstream/current/Changes
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/Changes 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/Changes 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,566 @@
+('GSM' is Greg Sabino Mullane, greg at turnstep.com)
+
+1.45 February 27, 2006
+ - Fix bug preventing bytea values over 20 characters from showing.
+ Spotted by Igor Shevchenko. [GSM]
+
+1.44 February 21, 2006
+ - Make sure pg_warn does not warn if the database attribute
+ PrintWarn is off. (Tyler MacDonald tyler at yi.org) [GSM]
+ - Add SIGNATURE file for Module::Signature verification. [GSM]
+ - Fix error in documentation for pg_errorlevel.
+ (CPAN bug #17434)
+ - Add experimental support for using DEFAULT values inside
+ of execute with $DBDPG_DEFAULT. [GSM]
+ - Return the proper SQLSTATE codes on connection failures.
+ (CPAN bug #17115) [GSM]
+ - Fix parser to handle leading parens. (CPAN bug #15481) [GSM]
+ - Make statement handles destruction abort early if
+ InactiveDestroy is set (CPAN bug #14978) [GSM]
+ - Make quote work properly for time/date types
+ (CPAN bug #15082) [GSM]
+ - Ensure all lo_ functions begin a transaction as needed
+ if they are the first action in a script
+ (CPAN bug # 13810) [GSM]
+ - Fix memory leak in dbdimp.c (k at sawada.cc) [Kenchi Sawada]
+ - Fix memory leak in dbdimp.c (dmitri at karasik.eu.org)
+ (CPAN bug #16054)
+ - Move package declaration lines to fix RPM parser problems
+ (CPAN bug #14509) [GSM]
+ - Add support for dollar quoting (CPAN bug #13608) [GSM]
+ - Added $dbh->{pg_default_port} method [GSM]
+ - Overhaul get_info data, add many more values [GSM]
+ - Overhaul type_info data (CPAN bug #13806) [GSM]
+ - Rewrite some of the quoting functions, reduce dependence
+ on libpq versions [GSM]
+ - Rewrite and optimize the do() method. Should be much faster
+ when called without placeholders. Thanks to Tom Lane
+ for suggesting this. [GSM]
+ - Double check PQserverVersion return and use alternate
+ method if it returns 0 (CPAN bug #14302)
+ - Add support for specifying type in $dbh->quote(),
+ such as $dbh->quote($var, {pg_type => DBD::Pg::PG_BYTEA})
+ Also support type => SQL_xx [GSM] (CPAN bug #13942)
+ - Fix pg_notifies() bug (CPAN bug #14232) [door at lcpi.ru]
+ - Add pg_ping() method [GSM]
+ - Make sure ping returns true, even if in failed transaction state
+ [thanks to Bill Moseley] [GSM]
+ - Fix COPY-related core dump [GSM]
+ - Fix strncpy bug in quote.c [Jun Kuriyama] (CPAN bug #14897)
+ - Fix error in is_high_bit_set() [Alexey Tourbin] (CPAN bug #13406)
+
+1.43 June 23, 2005
+ - Added README.dev file. [GSM]
+ - Fix statement-name related core dump. [GSM]
+ - Ensure state() returns an empty string, not 00000 on success.
+ (CPAN bug #13237) [michael.bell at web.de of OpenCA] [GSM]
+ - Fix rare core dump when $sth still in scope after disconnect [GSM]
+ - Enhancements to README.win32 [fenlisesi at gmail.com]
+ - Fix incorrect sprintf calls (CPAN bug #12204)
+ [Jakub Jelinek]
+ - Fix get_info(18) ("ODBCVERSION") (CPAN bug #12968)
+ [thanks to szinger at lanl.gov] [GSM]
+
+1.42 May 21, 2005
+ - Fix minor issues with copying and bytea quoting on older
+ servers. Fix some other memory leaks. [GSM]
+ - Fix backslash parsing in statements (CPAN bug #12870)
+ [felix.klee at inka.de] [GSM]
+ - Make rollback/commit reset copy state (CPAN bug #12866)
+ [imb at rentrak.com] [GSM]
+ - Make sure lo_creat issues a begin if necessary [GSM]
+ - Fix incorrect behavior when AutoCommit switched on. (CPAN bug #12748)
+ [thanks to Vivek Khera] [GSM]
+ - Have last_insert_id use set_err, not die. (CPAN bug #12503)
+ [thanks to Alexandra Walford] [GSM]
+ - Fixed tests to correctly handle older DBI versions reporting
+ failures on last_insert_id() (CPAN bug #12204)
+ [jpo at di.uminho.pt] [GSM]
+ - Re-enable REMARKS field on column_info (CPAN bug #12399)
+ [thanks to morni at cpan.org] [GSM]
+ - Many minor compiler optimizations and cleanups [GSM]
+ - Fix two separate memory leaks in dbdimp.c
+ [hertzog at debian.org and richardg at eSentire.com]
+ - Change VARCHAROID to UNKNOWNOID, suggested by users on mailing
+ list [GSM]
+
+1.41 April 6, 2005
+ - Make sure tests remove all temporary tables.
+ [Frank Bax] [GSM]
+ - Preserve sqlstate if rolling back on deallocate, fix
+ potential segfault. [Stephen Clouse]
+ - Fix CPAN bug #12004: commit and rollback now return true
+ [GSM] (thanks to ivan-dbdpg at 420.am)
+ - Overhaul and update COPY support; use new protocol.
+ New dbh methods: pg_putline, pg_getline, pg_endcopy.
+ [GSM]
+ - Rewrote version detection code. Compiled version and target
+ version are now available via $dbh->{pg_lib_version} and
+ $dbh->{pg_server_version} [GSM]
+ - Set our default type_id to 0, not 1043 (VARCHAR) when possible.
+ Suggested by Abhijit Menon-Sen via David Wheeler. [GSM]
+ - Add $dbh methods pg_savepoint(), pg_rollback_to(), and pg_release()
+ [Stephen Clouse] [GSM]
+
+1.40 Tue Feb 22 06:06:45 UTC 2005
+ - Raise required DBI version to 1.38
+ - Execute returns 0 (0E0) not -1 for successful DDL commands.
+ [Robert Treat] [GSM]
+ - Change all string lengths to use STRLEN [rink at stack.nl]
+ - Added $dbh->pg_server_trace($fh) [GSM]
+ - Added $dbh->{pg_errorlevel}. [GSM]
+ - Fix utf8 quote() support [Dominic Mitchell <dom at semantico.com>]
+ - Added explicit support for types SQL_BOOLEAN, DATE, TIME,
+ TIMESTAMP, and TIMESTAMPTZ. Return correct values for
+ DATEOID and TIMEOID. [GSM]
+ - Added tablespace support for table_info and primary_key_info.
+ [GSM]
+ - Added new attributes to $dbh: pg_db, pg_user, pg_pass,
+ pg_host, pg_port, pg_options, pg_socket, pg_pid [GSM]
+ - Minor fixes in quote.c, dbdimp.c, and types.h
+ [Christophe Martin: schplurtz at free.fr]
+ - Added support for SQLSTATE via $dbh->state and $sth->state [GSM]
+ - Major overhaul of prepare/execute to handle new server-side
+ prepare system. See Pg.pm for details. [GSM]
+ - Make the tests honor the DBD_SCHEMA variable instead of
+ assuming that the "public" schema is available.
+ [Rainer Weikusat]
+ - dbdimp.c cleanups: better error messages, ensure commit
+ is only called once after a transaction fails.
+ [Alexey Slynko]
+ - primary_key() returns empty list not undef if no match.
+ [Julian Mehnle]
+ - Added the pg_protocol database handle attribute
+ [GSM]
+ - Changed "noprefix" to pg_noprefix
+
+1.32 Wed Feb 25 18:24:18 UTC 2004
+ - Bugfix for memory allocation problems on win systems
+ [Rafael Kitover <caelum at debian.org>]
+ - Rewrote the foreign_key_info() method to handle
+ multi-column keys. [GSM]
+ - Rewrote the primary_key_info() and primary_key() methods to
+ cleanly handle multi-column primary keys. Also added a "pg_onerow"
+ attribute to allow primary_key_info() to return a single
+ row containing multiple-column information. [GSM]
+ - Switched commit behavior from commit->execute->begin
+ to begin->execute->commit
+ [xelah-junk at xelah.com] [GSM]
+ - Made the _pg_use_catalog subroutine use {private_dbgpg}.
+ (CPAN bug #4841) [GSM]
+ - Changed strdup to safemalloc/strcpy in dbdimp.c
+ (CPAN bug #4578) [anonymous CPAN user]
+ - Made the data_sources method escape the database names as needed.
+ Added support for databases with spaces in their names. [GSM]
+ - Added the "noprefix" attribute to prevent the tables() method
+ from prepending the schema name. [GSM]
+ - Rewrote the testing suite. Many more tests are performed.
+ Servers with a low client_min_messages are handled correctly. [GSM]
+ - Fixed bug causing '$\d' to be picked up as a placeholder.
+ (CPAN bug #4799) [GSM]
+ - pg_notifies now catches and reports when PQconsumeInput fails.
+ (CPAN bug #4027) [nmueller at cs.wisc.edu]
+ - Enabled the "pg_bool_tf" database handle [GSM]
+ - Added required fields to the type_info() method:
+ SQL_DATA_TYPE, SQL_DATETIME_SUB, and INTERVAL PRECISION [GSM]
+ - Fixed bug where the table_attributes() method was incorrectly
+ removing the NULLABLE column. [GSM]
+ - Fixed bug where case was not being preserved by the
+ foreign_key_info() method [GSM]
+ - a fetch on any column that had a type that did not have an entry
+ in the type_info array would segfault DBD::Pg.
+ (CPAN bugs #4818,4432) [Rudy Lippan]
+ - Duplicate rows bug with column_info() REMARKS has been fixed. However,
+ support for Postgres 7.1.x which worked briefly for 1.31 has now been
+ dropped for this feature. (Mark Stosberg)
+ - Bumped required Perl version to 5.6.1 in Makefile.PL. We were already
+ already requiring 5.6.1 for Pg.pm since 1.31.
+ - Removed extra "return" statement in quote.c to make Solaris happy
+ (CPAN bug #4419) [Rudy Lippan]
+ - Changed get_info(29) to return (") instead of (\")
+ (CPAN bug #4829) [GSM]
+
+1.31 Mon Nov 17 21:21:21 UTC 2003
+ - $dbh->{TYPE} now returns SQL_TYPE_TIMESTAMP instead of 1114 for
+ timestamp columns. (In 1.31_x {x| x<8} $sth->{TYPE} returned 0
+ but reported by ["Hirche, Joachim" <Joachim.Hirche at cimconcepts.com>]).
+ - Raised required versions to Perl 5.6.1 and DBI 1.35
+ - Fix syntax error related to pg_server_version (CPAN bugs #2492,2755,3121)
+ - Cache multiple calls to pg_server_version.
+ - Notice messages generated by the database now use the perl
+ warning mechanism instead of going to stderr.
+ [Dominic Mitchell <dom at semantico.com>]
+ - $dbh->prepare() rewrites the SQL statement into an internal form,
+ striping out comments and whitespace, and if PostgreSQL > 7.3 takes the
+ stripped statement and passes that to Postgres' PREPARE statement,
+ then rewrites the statement as 'EXECUTE "DBD::PG::cached_query n"
+ ($1, $2, ... $n, $n+1)' for DBD::Pg's execute.
+ -- Currently disabled until PREPARE works a little better
+ - Allows the use of :n and :foo bind params. So:
+ (SELECT * FROM foo WHERE 1 = :this and 2 = :that) will now work.
+ - Complains on execute when unbound bind params are submitted
+ (instead of defaulting to NULL)
+ - Switched over to use driver.xst.
+ - pg_error() removes \n's rather than truncating the message on the first \n.
+ - Fixed statement scan problem where the preparse of
+ "SELECT foo[3:33] from bar" was scanning :33 as a placeholder
+ - Moved the quoting of bind values out of execute() and into
+ bind -- as there is no need to requote the value every time execute
+ is called.
+ - :veryverylongplaceholdername == Long walk, short pier -- fixed.
+ - quote() is now in C and uses same code as bind_param.
+ - Quoting and dequoting now use libpq quoting functions where available
+ (I still need to take the libpq functions swiped out of quote.c and move
+ it into libpqswip.c with license info &c., and switch ifndefs to ifdefs)
+ - bind_param() will convert from 1,0 to TRUE/FALSE when pg_type
+ is PGBOOLOID.
+ - Fixed many heap buffer overruns.
+ - Added support for the get_info() method [GSM]
+ - Added tests for POD validation [Mark Stosberg]
+ - Several improvements to column_info, including:
+ - Fixed column_info so NULLABLE field shows correctly. [kevin at sysexperts.com]
+ - REMARKS field works now [Mark Stosberg]
+ - COLUMN_DEF fixed
+ - COLUMN_SIZE fixed
+ - pg_constraint column added to display column constraints
+ - additional documentation and tests added
+ - make test is now more intelligent and will bail out early if
+ db connection fails. [GSM]
+
+1.22 Wed Mar 26 22:33:44 EST 2003
+ - Win32 compile fix for snprintf [Joe Spears]
+ - Fix memory allocation problem in bytea escaping [Barrie Slaymaker]
+ - Add utf8 support [Dominic Mitchell <dom at semantico.com>]
+ - Transform Perl arrays into PostgreSQL arrays [Alexey Slynko]
+ - Fix for foreign_key_info() [Keith Keller]
+ - Fix PG_TEXT parameter binding
+ - Doc cleanups [GSM]
+ - Fix warning from func($table, 'table_attributes') [GSM]
+ - Added support for schemas [GSM]
+ - Fix binary to a bytea field conversion [Chris Dunlop <chris at onthe.net.au>]
+
+1.21 Sun Jan 12 21:00:44 EST 2003
+ - System tables no longer returned by tables(). [Dave Rolsky]
+ - Fix table_attributes to handle removal of pg_relcheck in 7.3,
+ from Ian Barwick <barwick at gmx.net>
+ - Properly reset transaction status after failed transaction when
+ autocommit is off. Properly report transaction failure message.
+ Kai <kai at xs4all.nl>
+ - New pg_bool_tf database handle that when set to true booleans are
+ returned as 't'/'f' rather than 1/0.
+
+1.20 Wed Nov 27 16:19:26 2002
+ - Maintenance transferred to GBorg,
+ http://gborg.postgresql.org/project/dbdpg/projdisplay.php. Incremented
+ version number to reflect new management. [Bruce Momjian]
+ - README cleaned up. [Bruce Momjian]
+ - Added t/15funct.t, a series of tests that determine if the meta data
+ is working. [Thomas Lowery]
+ - Added implementations of column_info() and table_info(), and
+ primary_key_info(). [Thomas Lowery]
+ - The POD formatting was cleaned up. [David Wheeler]
+ - The preparser was updated to better handle escaped characters.
+ [Rudy Lippan]
+ - Removed redundant use of strlen() in pg_error() (Jason E. Stewart).
+ - Test suite cleaned up, converted to use Test::More, and updated to use
+ standard DBI environment variables for connecting to a test database.
+ [Jason E. Stewart]
+ - Added eg/lotest.pl as a demonstration of using large objects in buffers
+ rather than files. Contributed by Garth Webb.
+ - Added LISTEN/NOTIFY functionality. Contributed by Alex Pilosov.
+ - Added constants for common PostgreSQL data types, plus simple tests to
+ make sure that they work. These are exportable via
+ "use DBD::Pg qw(:pg_types);". [David Wheeler]
+ - Deprecated the undocumented (and invalid) use of SQL_BINARY in
+ bind_param() and documented the correct approach: "bind_param($num,
+ $val { pg_type => PG_BYTEA });". Use of SQL_BINARY in bind_param() will
+ now issue a warning if $h->{Warn} is true. [David Wheeler]
+ - Removed invalid (and broken) support for SQL_BINARY in quote().
+ [David Wheeler]
+ - Added App::Info::RDBMS::PostgreSQL to the distribution (but it won't
+ be installed) to help Makefile.PL find the PostgreSQL include and
+ library files. [David Wheeler]
+ - Fixed compile-time warnings. [David Wheeler and Jason E. Stewart]
+
+2002-04-27 Jeffrey W. Baker <jwbaker at acm.org>
+ - dbdimp.c: Add default at end of switch statement for pg_type attrib.
+ - t/13pgtype.t: test for above.
+
+2002-04-09 Jeffrey W. Baker <jwbaker at acm.org>
+ - Pg.pm, dbdimp.c: Applied patch from
+ Thomas A. Lowery <tlowery at stlowery.net> concerning metadata in
+ table_info and so forth.
+
+2002-03-06 Jeffrey W. Baker <jwbaker at acm.org>
+ - Pg.pm (quote): Applied patch from David Wheeler <david at wheeler.net>
+ to simplify and speed up quoting.
+ - t/11quoting.t: Tests for above patch.
+ - t/12placeholders.t: Tests for placeholder parsing in quoted strings.
+
+2002-03-06 Jeffrey W. Baker
+ - Version 1.10 uploaded to CPAN.
+
+1.01 Jun 27, 2001
+ - fixed core dump when trying to use a BYTEA value with
+ a byte outside 0..127 Alex Pilosov <alex at pilosoft.com>
+
+1.00 May 27, 2001
+ - Fetching all records now resets Active flag as it should.
+
+0.99 May 24, 2001
+ - fix the segmentation fault in pg_error.
+
+0.98 Apr 25, 2001
+ - bug-fix for core-dump after any failed function call.
+ - applied patch from Alex Pilosov <alex at pilosoft.com>
+ which adds support for the datatype bytea
+
+0.97 Apr 20, 2001
+ - fix bug in connect method, which erroneously set the userid
+ and the password to the environment variables DBI_USER and
+ DBI_PASS.
+ - applied patch from Jan-Pieter Cornet <john at pc.xs4all.nl>,
+ which removed the special handling of a backslash when
+ used for octal presentation. Now a backslash always will
+ be escaped.
+
+0.96 Apr 09, 2001
+ - remove memory-leak in ping function, bug-fix
+ from Doug Perham <dperham at wgate.com>
+ - correct the recognition of primary keys in
+ table_attributes(). Patch from Brian Powell <brian at nicklebys.com>.
+ - applied patch from David D. Kilzer <ddkilzer at lubricants-oil.com>
+ which fixes a segmentation fault in DBD::pg::blob_read() when
+ reading LOBs that required perl to reallocate space for the
+ variable holding the scalar value
+ - updated test.pl to create a test blob larger than 256 bytes
+ (now 128 Kbytes)
+ - apply patch from Tom Lane, which fixes a segmentation fault when
+ inserting large amounts of text.
+ - apply patch from Peter Haworth pmh at edison.ioppublishing.com,
+ which removes the newlines from the error messages and which
+ quotes date placeholders.
+
+0.95 Jul 10, 2000
+ - add Win32 port from Bob Kline <bkline at rksystems.com>.
+
+0.94 Jul 07, 2000
+ - applied patch from Rudy Lippan <almighty at randomc.com>
+ which fixes a memory-leak with failed connections.
+ - applied patch from Hein Roehrig <hein at acm.org>
+ which fixes a bug with escaping a backslash except for
+ octal presentation
+ - applied patch from Francis J. Lacoste <francis.lacoste at iNsu.COM
+ which fixes a segmentation fault when all bound parameters are NULL
+ - adapt test.pl to avoid warnings with postgresql-7.0
+ - added support for 'COPY FROM STDIN' and 'COPY TO STDOUT'
+ - added patch from Mark Stosberg <mark at summersault.com>
+ to enhance the table_attributes subroutine
+
+0.93 Sep 29, 1999
+ - it is required now to set the environment variables POSTGRES_INCLUDE
+ and POSTGRES_LIB for compiling the module.
+ - add Win32 port from Bob Kline <bkline at rksystems.com>.
+ - support for all large-object functions via the func interface.
+ - fixed bug with placeholders and casts spotted bymschout at gkg.net
+ - replaced the method attributes by the method table_attributes,
+ from Scott Williams <scott at james.com>.
+ - fix type definitions for type_info_all().
+ bug spotted by "carlos" <emarcet at intramed.net.ar>.
+ - now the Pg-specific quote() method also evaluates the data-type parameter.
+
+0.92 Jun 16, 1999
+ - proposal from Philip Warner <pjw at rhyme.com.au>:
+ increase BUFSIZE from 1024 to 32768 in order to improve I/O performance.
+ - bug-fix in Makefile.PL for $POSTGRES_HOME not defined
+ spotted by mdalphin at amgen.com (Mark Dalphin)
+ - bug-fix for data-type datetime in type_info_all
+ spotted by Alan Grover <awgrover at iconnect-inc.com>
+ - bug-fix for escaped 's spotted by Hankin <hankin at consultco.com>
+ - removed 'large objects' related tests from test.pl
+
+0.91 Feb 14, 1999
+ - removed restriction for commercial use in copyright
+ - corrected DATA_TYPE in type_info_all()
+
+0.90 Jan 15, 1998
+ - discard parameter authtype from connect string
+ - remove work-around for bug in the large object interface of postgresql
+
+0.89 Nov 05, 1998
+ - bug-fix from Jan Iven <j.iven at rz.uni-sb.de>:
+ fix problem with quoting Null in bind variables.
+
+0.88 Oct 10, 1998
+ - fixed blob_read
+ - suppressed warning when testing DBI::errstr
+
+0.87 Sep 05, 1998
+ - Pg.xs adapted to Driver.xst from DBI-1.0
+ - major rewrite of module documentation
+ - major rewrite of the test script
+ - use built-in DBI method for $dbh->do
+ - add macro dHTR in order to avoid compile errors
+ with threaded perl5.005
+ - renamed attribute AutoEscape to pg_auto_escape
+ - renamed attribute SIZE to pg_size
+ - new attribute pg_type
+ - added support for DBI->data_sources($driver)
+ - added support for $dbh->table_info
+ - blob_read documented and added to test.pl
+ - added support for attr parameter in bind_param()
+
+0.86 Aug 21, 1998
+ - added /usr/lib/ to search path for libpq.
+ - added ChopBlanks, patch from
+ Victor Krasinsky <victor at rdovira.lviv.ua>
+ - changed test.pl to test multiple database handles
+
+0.85 July 19, 1998
+ - non-printable characters in parameters will not be converted
+ to '.'. They are passed unchanged to the database.
+
+0.84 July 18, 1998
+ - bug-fix from Max Cohan <mcohan at adnc.net>:
+ check for \xxx presentation before escaping backslash in parameters.
+ - introduce new database handle attribute AutoEscape, which
+ controls escaping of quotes and backslashes in parameters.
+ When set to on, all quotes except at the beginning and
+ at the end of a line will be escaped and all backslashes
+ except when used to indicate an octal presentation (\xxx)
+ will be escaped. Default of AutoEscape is on.
+
+0.83 July 10, 1998
+ - bug-fix from Max Cohan <mcohan at adnc.net>:
+ using traces together with undef in place-holders dumped core.
+
+0.82 June 20, 1998
+ - bug-fix from Matthew Lenz <matthew at nocturnal.org>:
+ corrected include path in Makefile.PL .
+ - added 'use strict;' to test.pl
+
+0.81 June 13, 1998
+ - bug-fix from Rolf Grossmann <grossman at securitas.net>:
+ undefined parameters in an execute statement will be
+ translated from 'undef' to 'NULL'. Also every parameter
+ for bind_param() will be quoted by default (escape quote
+ and backslash). Appropriate tests have been added to test.pl.
+ - change ping method to use libpq-interface.
+
+0.80 June 07, 1998
+ - adapted to postgresql-6.4:
+ the backend protocol has changed, which needs an adapted
+ ping method. A ping-test has been added to the test-script.
+ Also some type identifiers have changed.
+
+0.73 June 03, 1998
+ - changed include directives in Makefile.PL from
+ archlib to installarchlib and from sitearch to
+ installsitearch (Tony.Curtis at vcpc.univie.ac.at).
+ - applied patch from Junio Hamano <junio at twinsun.com>
+ quote method also doubles backslash.
+
+0.72 April 20, 1998
+ - applied patch from Michael J Schout <mschout at gkg.net>
+ which fixed the bug with queries containing the cast operator.
+ - applied patch from "Irving Reid" <irving at tor.securecomputing.com>
+ which fixed a memory leak.
+
+0.71 April 04, 1998
+ - applied patch from "Irving Reid"
+ <irving at tor.securecomputing.com> which fixed the
+ the problem with the InactiveDestroy message.
+
+0.70 March 28, 1998
+ - linking again with the shared version of libpq
+ due to problems on several operating systems.
+
+0.69 March 6, 1998
+ - expanded the search path for include files
+ - module is now linked with static libpq.a
+
+0.68 March 3, 1998
+ - return to UNIX domain sockets in test-scripts
+
+0.67 February 21, 1998
+ - remove part of Driver.xst due to compile error on some systems.
+
+0.66 February 19, 1998
+ - remove defines in Pg.h so that
+ it compiles also with postgresql-6.2.1
+ - changed ping method: set RaiseError=0
+
+0.65 February 14, 1998
+ - adapted to changes in DBI-0.91, so that the
+ default setting for AutoCommit and PrintError is
+ again conformant to the DBI specs.
+
+0.64 February 01, 1998
+ - changed syntax of data_source (ODBC-conformant):
+ 'dbi:Pg:dbname=dbname;host=host;port=port'
+ !!! PLEASE ADAPT YOUR SCRIPTS !!!
+ - implemented place-holders
+ - implemented ping-method
+ - added support for $dbh->{RaiseError} and $dbh->{PrintError},
+ note: DBI-default for PrintError is on !
+ - allow commit and rollback only if AutoCommit = off
+ - added documentation for $dbh->tables;
+ - new method to get meta-information about a given table:
+ $dbh->DBD::Pg::db::attributes($table);
+ - host-parameter in test.pl is set explicitly to localhost
+
+0.63 October 05, 1997
+ - adapted to PostgreSQL-6.2:
+ o $sth->rows as well as $sth->execute and $sth->do return the
+ number of affected rows even for non-Select statements.
+ o support for password authorization added,
+ please check the man-page for pg_passwd.
+ - the data_source parameter of the connect
+ method accepts two additional parameters
+ which are treated as host and port:
+ DBI->connect("dbi:Pg:dbname:host:port", "uid", "pwd")
+ - support for AutoCommit, please read the
+ module documentation for impacts on your
+ scripts !
+ - more perl-ish handling of data type bool,
+ please read the module documentation for
+ impacts on your scripts !
+
+0.62 August 26, 1997
+ - added blobs/README
+
+0.61 August 23, 1997
+ - adapted to DBI-0.89/Driver.xst
+ - added support for blob_read
+
+0.52 August 15, 1997
+ - added support for literal $sth->{'TYPE'}, pg_type.pl / pg_type.pm.
+
+0.51 August 12, 1997
+ - changed attributes to be DBI conformant:
+ o OID_STATUS to pg_oid_status
+ o CMD_STATUS to pg_cmd_status
+
+0.5 August 05, 1997
+ - support for user authentication
+ - support for bind_columns
+ - added $dbh->tables
+
+0.4 Jun 24, 1997
+ - adapted to DBI-0.84:
+ o new syntax for DBI->connect !
+ o execute returns 0E0 -> n for SELECT statement
+ -1 for non SELECT statement
+ -2 on error
+ - new attribute $sth->{'OID_STATUS'}
+ - new attribute $sth->{'CMD_STATUS'}
+
+0.3 Apr 24, 1997
+ - bug fix release, ( still alpha ! )
+
+0.2 Mar 13, 1997
+ - complete rewrite, ( still alpha ! )
+
+0.1 Feb 15, 1997
+ - creation, ( totally pre-alpha ! )
+
Added: packages/libdbd-pg-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/MANIFEST 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/MANIFEST 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,43 @@
+SIGNATURE
+Changes
+dbdimp.c
+dbdimp.h
+Makefile.PL
+MANIFEST
+MANIFEST.SKIP
+Pg.h
+Pg.pm
+Pg.xs
+quote.c
+quote.h
+README
+README.win32
+README.dev
+win32.mak
+t/00-signature.t
+t/00basic.t
+t/01connect.t
+t/01constants.t
+t/01setup.t
+t/02attribs.t
+t/03dbmethod.t
+t/03smethod.t
+t/04misc.t
+t/05arrays.t
+t/06bytea.t
+t/07copy.t
+t/12placeholders.t
+t/20savepoints.t
+t/99_pod.t
+t/99cleanup.t
+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
+TODO
+types.c
+types.h
+META.yml Module meta-data (added by MakeMaker)
Added: packages/libdbd-pg-perl/branches/upstream/current/MANIFEST.SKIP
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/MANIFEST.SKIP 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/MANIFEST.SKIP 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,20 @@
+^_build
+^Build$
+^Makefile$
+^Makefile\.old$
+^blib
+~$
+\.bak$
+^MANIFEST\.SKIP$
+^DBD-Pg
+.cvsignore
+CVS
+Pg.o
+Pg.c
+Pg.bs
+Pg.xsi
+quote.o
+types.o
+dbdimp.o
+pm_to_blib
+\.tmp$
Added: packages/libdbd-pg-perl/branches/upstream/current/META.yml
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/META.yml 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/META.yml 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,12 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: DBD-Pg
+version: 1.45
+version_from: Pg.pm
+installdirs: site
+requires:
+ Test::Harness: 2.03
+ Test::Simple: 0.17
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: packages/libdbd-pg-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/Makefile.PL 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/Makefile.PL 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,166 @@
+# $Id: Makefile.PL,v 1.52 2006/02/26 19:04:23 turnstep Exp $
+
+use ExtUtils::MakeMaker;
+use Config;
+use strict;
+use 5.006001;
+use DBI 1.38;
+use DBI::DBD;
+
+my $VERSION = "1.45";
+
+my $lib;
+BEGIN {
+ my %sep = (MacOS => ':',
+ MSWin32 => '\\',
+ os2 => '\\',
+ VMS => '\\',
+ NetWare => '\\',
+ dos => '\\');
+ my $s = $sep{$^O} || '/';
+ $lib = join $s, 't', 'lib';
+}
+
+use lib $lib;
+if ($VERSION =~ /_/) {
+ print "WARNING! This is a test version ($VERSION) and should not be used in production!\n";
+}
+
+print "Configuring DBD::Pg $VERSION\n";
+print "Remember to actually read the README file!\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) = map {$pg->$_} qw/major_version minor_version patch_version configure/;
+my $serverversion = sprintf("%d%.02d%.02d", $major_ver, $minor_ver, $patch);
+my $defaultport = $conf =~ /with-pgport=(\d+)/ ? $1 : 5432;
+
+if ((!$ENV{POSTGRES_INCLUDE} or !$ENV{POSTGRES_LIB}) and !$ENV{POSTGRES_HOME}) {
+ $POSTGRES_INCLUDE = $pg->inc_dir;
+ $POSTGRES_LIB = $pg->lib_dir;
+} elsif ((!$ENV{POSTGRES_INCLUDE} or !$ENV{POSTGRES_LIB}) and $ENV{POSTGRES_HOME}) {
+ $POSTGRES_INCLUDE = "$ENV{POSTGRES_HOME}/include";
+ $POSTGRES_LIB = "$ENV{POSTGRES_HOME}/lib";
+} else {
+ $POSTGRES_INCLUDE = "$ENV{POSTGRES_INCLUDE}";
+ $POSTGRES_LIB = "$ENV{POSTGRES_LIB}";
+}
+
+my $os = $^O;
+print "OS: $os\n";
+print "PostgreSQL version: $serverversion (default port: $defaultport)\n";
+
+if ($serverversion < 1) {
+ die "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, PSOTGRES_INCLUDE, and POSTGRES_LIB\n";
+}
+
+if ($os =~ /Win32/) {
+ for ($POSTGRES_INCLUDE, $POSTGRES_LIB) {
+ $_ = qq{"$_"} if index($_,'"');
+ }
+}
+
+## Warn about older versions
+if ($serverversion < 70200) {
+ print "\n****************\n";
+ print "WARNING! DBD::Pg no longer supports versions less than 7.2.\n";
+ print "It is highly recommended that you upgrade PostgreSQL to a newer version.\n";
+ print "If you continue, DBD::Pg may not work.\n";
+ print "****************\n\n";
+}
+elsif ($serverversion < 70400) {
+ print "\n****************\n";
+ print "WARNING! Support for servers older than version 7.4 will soon end.\n";
+ print "It is highly recommended that you upgrade PostgreSQL to a newer version.\n";
+ print "****************\n\n";
+}
+
+my $dbi_arch_dir;
+if ($os eq 'MSWin32') {
+ $dbi_arch_dir = "\$(INSTALLSITEARCH)/auto/DBI";
+}
+else {
+ {
+ local *STDOUT; ## Prevent duplicate debug info as WriteMakefile also calls this
+ $dbi_arch_dir = dbd_dbi_arch_dir();
+ }
+}
+
+my $comp_opts = $Config{q{ccflags}} . " -DPGLIBVERSION=$serverversion -DPGDEFPORT=$defaultport";
+
+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 -Wconversion -Wsign-compare -Waggregate-return";
+ $comp_opts .= " -Wmissing-prototypes -Wmissing-declarations -Wmissing-format-attribute -Wpacked -Winline -Winvalid-pch";
+ $comp_opts .= " -Wdisabled-optimization"; ## Not terribly useful
+ $comp_opts .= " -Wnested-externs"; ## Does not like Perl__notused (from DBIXS;)
+}
+
+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"],
+ AUTHOR => 'http://gborg.postgresql.org/project/dbdpg/',
+ ABSTRACT => 'PostgreSQL database driver for the DBI module',
+ PREREQ_PM => { 'Test::Simple' => '0.17', # Need Test::More.
+ 'Test::Harness' => '2.03', # Need TODO tests.
+ },
+ CCFLAGS => $comp_opts,
+ PERL_MALLOC_OK => 1,
+ NEEDS_LINKING => 1,
+ clean => { FILES => 'trace' },
+);
+
+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";
+}
+
+if ($Config{dlsrc} =~ /dl_none/) {
+ $opts{LINKTYPE} = 'static';
+}
+
+sub MY::postamble {
+ my $string = &dbd_postamble;
+ ## 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\\\(/#;
+ return $string;
+}
+
+WriteMakefile(%opts);
+
+exit(0);
+
+# end of Makefile.PL
Added: packages/libdbd-pg-perl/branches/upstream/current/Pg.h
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/Pg.h 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/Pg.h 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,61 @@
+/*
+ $Id: Pg.h,v 1.13 2006/01/30 03:11:56 turnstep Exp $
+
+ Copyright (c) 2000-2006 PostgreSQL Global Development Group
+ 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.
+
+*/
+
+
+#ifdef WIN32
+static int errno;
+#endif
+
+#define DBDPG_TRUE (bool)1
+#define DBDPG_FALSE (bool)0
+
+#include "libpq-fe.h"
+
+#ifdef NEVER
+#include<sys/stat.h>
+#include "libpq/libpq-fs.h"
+#endif
+#ifndef INV_READ
+#define INV_READ 0x00040000
+#endif
+#ifndef INV_WRITE
+#define INV_WRITE 0x00020000
+#endif
+
+/* For versions of DBI older than 1.41 */
+#ifndef DBIcf_Executed
+#define DBIcf_Executed 0x080000
+#endif
+
+#ifdef BUFSIZ
+#undef BUFSIZ
+#endif
+/* this should improve I/O performance for large objects */
+#define BUFSIZ 32768
+
+
+#define NEED_DBIXS_VERSION 93
+
+#include <DBIXS.h> /* installed by the DBI module */
+
+#include <dbd_xsh.h> /* installed by the DBI module */
+
+#include "dbdimp.h"
+#include "quote.h"
+#include "types.h"
+
+/* defines for Driver.xst to let it know what functions to include */
+#define dbd_st_rows dbd_st_rows
+#define dbd_discon_all dbd_discon_all
+#define dbd_st_fetchrow_hashref valid
+
+/* end of Pg.h */
Added: packages/libdbd-pg-perl/branches/upstream/current/Pg.pm
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/Pg.pm 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/Pg.pm 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,2969 @@
+# -*-cperl-*-
+# $Id: Pg.pm,v 1.187 2006/02/26 19:04:23 turnstep Exp $
+#
+# Copyright (c) 2002-2006 PostgreSQL Global Development Group
+# 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 5.006001;
+
+
+{
+ package DBD::Pg;
+
+ our $VERSION = '1.45';
+
+ use DBI ();
+ use DynaLoader ();
+ use Exporter ();
+ use vars qw(@ISA %EXPORT_TAGS $err $errstr $sqlstate $drh $dbh $DBDPG_DEFAULT);
+ @ISA = qw(DynaLoader Exporter);
+
+ %EXPORT_TAGS =
+ (
+ pg_types => [qw(
+ PG_BOOL PG_BYTEA PG_CHAR PG_INT8 PG_INT2 PG_INT4 PG_TEXT PG_OID
+ PG_FLOAT4 PG_FLOAT8 PG_ABSTIME PG_RELTIME PG_TINTERVAL PG_BPCHAR
+ PG_VARCHAR PG_DATE PG_TIME PG_DATETIME PG_TIMESPAN PG_TIMESTAMP
+ )]
+ );
+
+ {
+ package DBD::Pg::DefaultValue;
+ sub new { my $self = {}; return bless $self, shift; }
+ }
+ $DBDPG_DEFAULT = DBD::Pg::DefaultValue->new();
+ Exporter::export_ok_tags('pg_types');
+ @EXPORT = qw($DBDPG_DEFAULT);
+
+ require_version DBI 1.38;
+
+ 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
+
+ sub CLONE {
+ $drh = undef;
+ }
+
+
+ sub driver {
+ return $drh if defined $drh;
+ my($class, $attr) = @_;
+
+ $class .= "::dr";
+
+ # not a 'my' since we use it above to prevent multiple drivers
+
+ $drh = DBI::_new_drh($class, {
+ 'Name' => 'Pg',
+ 'Version' => $VERSION,
+ 'Err' => \$DBD::Pg::err,
+ 'Errstr' => \$DBD::Pg::errstr,
+ 'State' => \$DBD::Pg::sqlstate,
+ 'Attribution' => 'PostgreSQL DBD by Edmund Mergl',
+ });
+
+
+ DBD::Pg::db->install_method("pg_endcopy");
+ DBD::Pg::db->install_method("pg_getline");
+ DBD::Pg::db->install_method("pg_ping");
+ DBD::Pg::db->install_method("pg_putline");
+ DBD::Pg::db->install_method("pg_release");
+ 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");
+
+ $drh;
+
+ }
+
+
+ ## Deprecated: use $dbh->{pg_server_version} if possible instead
+ sub _pg_use_catalog {
+ my $dbh = shift;
+ return $dbh->{private_dbdpg}{pg_use_catalog} if defined $dbh->{private_dbdpg}{pg_use_catalog};
+ $dbh->{private_dbdpg}{pg_use_catalog} = $dbh->{private_dbdpg}{version} >= 70300 ? 'pg_catalog.' : '';
+ }
+
+
+ 1;
+}
+
+
+{
+ package DBD::Pg::dr;
+
+ use strict;
+
+ our $CATALOG = 123; ## Set later on, this is to catch seriously misplaced code
+
+
+ ## Returns an array of formatted database names from the pg_database table
+ sub data_sources {
+ my $drh = shift;
+ my $dbh = DBD::Pg::dr::connect($drh, 'dbname=template1') or return undef;
+ $dbh->{AutoCommit}=1;
+ my $SQL = "SELECT ${CATALOG}quote_ident(datname) FROM ${CATALOG}pg_database ORDER BY 1";
+ my $sth = $dbh->prepare($SQL);
+ $sth->execute() or die $DBI::errstr;
+ my @sources = map { "dbi:Pg:dbname=$_->[0]" } @{$sth->fetchall_arrayref()};
+ $dbh->disconnect;
+ return @sources;
+ }
+
+
+ sub connect {
+ my($drh, $dbname, $user, $pass)= @_;
+
+ ## 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 = "" unless defined($user);
+ $pass = "" unless defined($pass);
+
+ $user = $ENV{DBI_USER} if $user eq "";
+ $pass = $ENV{DBI_PASS} if $pass eq "";
+
+ $user = "" unless defined($user);
+ $pass = "" unless defined($pass);
+
+ my ($dbh) = DBI::_new_dbh($drh, {
+ 'Name' => $Name,
+ 'User' => $user, 'CURRENT_USER' => $user,
+ });
+
+ # Connect to the database..
+ DBD::Pg::db::_login($dbh, $dbname, $user, $pass) or return undef;
+
+ my $version = $dbh->{pg_server_version};
+ $dbh->{private_dbdpg}{version} = $version;
+
+ ## If the version is 7.3 or later, fully qualify the system relations
+ $CATALOG = $version >= 70300 ? 'pg_catalog.' : '';
+
+ $dbh;
+ }
+
+}
+
+
+{
+ package DBD::Pg::db;
+
+ use DBI qw(:sql_types);
+
+ use strict;
+
+
+ sub prepare {
+ my($dbh, $statement, @attribs) = @_;
+
+ return undef if ! defined $statement;
+
+ # Create a 'blank' statement handle:
+ my $sth = DBI::_new_sth($dbh, {
+ 'Statement' => $statement,
+ });
+
+ my $ph = DBD::Pg::st::_prepare($sth, $statement, @attribs) || 0;
+
+ if ($ph < 0) {
+ return undef;
+ }
+
+ if (@attribs and ref $attribs[0] and ref $attribs[0] eq 'HASH') {
+ # Feel ambitious? Move all this to dbdimp.c! :)
+ if (exists $attribs[0]->{bind_types}) {
+ my $bind = $attribs[0]->{bind_types};
+ ## Until we are allowed to set just the type, we use a null
+ $sth->bind_param("$1",undef,"foo");
+ }
+ }
+
+ $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') {
+ return $dbh->set_err(1, "last_insert_id must be passed a hashref as the final argument");
+ }
+ ## 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) {
+ return $dbh->set_err(1, "last_insert_id needs at least a sequence or table name");
+ }
+ my @args = ($table);
+
+ ## Only 7.3 and up can use schemas
+ $schema = '' if $dbh->{private_dbdpg}{version} < 70300;
+
+ ## 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 ${DBD::Pg::dr::CATALOG}pg_class c $schemajoin\n WHERE relname = ?$schemawhere";
+ $sth = $dbh->prepare($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"};
+ return $dbh->set_err(1, $message);
+ }
+ my $oid = $sth->fetchall_arrayref()->[0][0];
+ ## This table has a primary key. Is there a sequence associated with it via a unique, indexed column?
+ $SQL = "SELECT a.attname, i.indisprimary, substring(d.adsrc for 128) AS def\n".
+ "FROM ${DBD::Pg::dr::CATALOG}pg_index i, ${DBD::Pg::dr::CATALOG}pg_attribute a, ${DBD::Pg::dr::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".
+ " 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"});
+ }
+ 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("SELECT currval(?)");
+ $sth->execute($sequence);
+ return $sth->fetchall_arrayref()->[0][0];
+
+ } ## end of last_insert_id
+
+ sub ping {
+ my $dbh = shift;
+ local $SIG{__WARN__} = sub { } if $dbh->{PrintError};
+ local $dbh->{RaiseError} = 0 if $dbh->{RaiseError};
+ my $ret = DBD::Pg::db::_ping($dbh);
+ return $ret < 1 ? 0 : $ret;
+ }
+
+ sub pg_ping {
+ my $dbh = shift;
+ local $SIG{__WARN__} = sub { } if $dbh->{PrintError};
+ local $dbh->{RaiseError} = 0 if $dbh->{RaiseError};
+ return DBD::Pg::db::_ping($dbh);
+ }
+
+ sub pg_type_info {
+ my($dbh,$pg_type) = @_;
+ local $SIG{__WARN__} = sub { } if $dbh->{PrintError};
+ local $dbh->{RaiseError} = 0 if $dbh->{RaiseError};
+ 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 $version = $dbh->{private_dbdpg}{version};
+
+ my @search;
+ ## If the schema or table has an underscore or a %, use a LIKE comparison
+ if (defined $schema and length $schema and $version >= 70300) {
+ 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 $showschema = $version >= 70300 ? "quote_ident(n.nspname)" : "NULL::text";
+
+ my $schemajoin = $version >= 70300 ?
+ "JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)" : "";
+
+ # col_description is not available for Pg < 7.2
+ my $remarks = $version > 70200 ?
+ "${DBD::Pg::dr::CATALOG}col_description(a.attrelid, a.attnum)" : "NULL::text";
+
+ my $col_info_sql = qq!
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , $showschema AS "TABLE_SCHEM"
+ , quote_ident(c.relname) AS "TABLE_NAME"
+ , quote_ident(a.attname) AS "COLUMN_NAME"
+ , a.atttypid AS "DATA_TYPE"
+ , ${DBD::Pg::dr::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"
+ , af.adsrc 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"
+ , ${DBD::Pg::dr::CATALOG}format_type(a.atttypid, a.atttypmod) AS "pg_type"
+ , a.attrelid AS "pg_attrelid"
+ , a.attnum AS "pg_attnum"
+ , a.atttypmod AS "pg_atttypmod"
+ FROM
+ ${DBD::Pg::dr::CATALOG}pg_type t
+ JOIN ${DBD::Pg::dr::CATALOG}pg_attribute a ON (t.oid = a.atttypid)
+ JOIN ${DBD::Pg::dr::CATALOG}pg_class c ON (a.attrelid = c.oid)
+ LEFT JOIN ${DBD::Pg::dr::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
+ /);
+
+ my $oldconstraint_sth;
+ if ($version < 70300) {
+ my $constraint_query = "SELECT rcsrc FROM pg_relcheck WHERE rcname = ?";
+ $oldconstraint_sth = $dbh->prepare($constraint_query);
+ }
+
+ for my $row (@$data) {
+ 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
+ my $w = $row->[$col_map{DATA_TYPE}];
+ $row->[$col_map{DATA_TYPE}] = DBD::Pg::db::pg_type_info($dbh,$row->[$col_map{DATA_TYPE}]);
+ $w = $row->[$col_map{DATA_TYPE}];
+
+ # Add pg_constraint
+ if ($version >= 70300) {
+ my $SQL = "SELECT consrc FROM pg_catalog.pg_constraint WHERE contype = 'c' AND ".
+ "conrelid = $aid AND conkey = '{$attnum}'";
+ my $info = $dbh->selectall_arrayref($SQL);
+ if (@$info) {
+ $row->[19] = $info->[0][0];
+ }
+ else {
+ $row->[19] = undef;
+ }
+ }
+ else {
+ $oldconstraint_sth->execute("$row->[$col_map{TABLE_NAME}]_$row->[$col_map{COLUMN_NAME}]");
+ ($row->[19]) = $oldconstraint_sth->fetchrow_array;
+ }
+ $col_map{pg_constraint} = 19;
+ }
+
+ # get rid of atttypmod that we no longer need
+ delete $col_map{pg_atttypmod};
+
+ # Since we've processed the data in Perl, we have to jump through a hoop
+ # To turn it back into a statement handle
+ #
+ my $sth = _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 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 $version = $dbh->{private_dbdpg}{version};
+ my $whereclause = "AND c.relname = " . $dbh->quote($table);
+
+ my $gotschema = $version >= 70300 ? 1 : 0;
+ if (defined $schema and length $schema and $gotschema) {
+ $whereclause .= "\n\t\t\tAND n.nspname = " . $dbh->quote($schema);
+ }
+ my $showschema = $gotschema ? "quote_ident(n.nspname)" : "NULL::text";
+ my $schemajoin = $gotschema ?
+ "LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)" : "";
+ my $showtablespace = '';
+ my $tablespacejoin = '';
+ if ($version >= 70500) {
+ $tablespacejoin = 'LEFT JOIN pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace)';
+ $showtablespace = ', quote_ident(t.spcname), quote_ident(t.spclocation)';
+ }
+ my $pri_key_sql = qq{
+ SELECT
+ c.oid
+ , $showschema
+ , quote_ident(c.relname)
+ , quote_ident(c2.relname)
+ , i.indkey $showtablespace
+ FROM
+ ${DBD::Pg::dr::CATALOG}pg_class c
+ JOIN ${DBD::Pg::dr::CATALOG}pg_index i ON (i.indrelid = c.oid)
+ JOIN ${DBD::Pg::dr::CATALOG}pg_class c2 ON (c2.oid = i.indexrelid)
+ $schemajoin $tablespacejoin
+ WHERE
+ i.indisprimary IS TRUE
+ $whereclause
+ };
+
+ 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, ${DBD::Pg::dr::CATALOG}quote_ident(a.attname) AS colname,
+ ${DBD::Pg::dr::CATALOG}quote_ident(t.typname) AS typename
+ FROM ${DBD::Pg::dr::CATALOG}pg_attribute a, ${DBD::Pg::dr::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};
+ if ($tablespacejoin) {
+ $pkinfo->[$x][7] = $info->[5];
+ $pkinfo->[$x][8] = $info->[6];
+ }
+ $x++;
+ }
+ }
+ else { ## Nicer way: return only one row
+
+ # TABLE_CAT
+ $info->[0] = undef;
+ # TABLESPACES
+ if ($tablespacejoin) {
+ $info->[7] = $info->[5];
+ $info->[8] = $info->[6];
+ }
+ # 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' if $tablespacejoin;
+
+ 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
+
+ ## 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;
+
+ ## Versions 7.2 or less have no pg_constraint table, so we cannot support
+ my $version = $dbh->{private_dbdpg}{version};
+ return undef unless $version >= 70300;
+
+ my $C = 'pg_catalog.';
+
+ ## 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 ${C}pg_class c, ${C}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 ? "((contype = 'p'" : "((contype IN ('p','u')";
+ if (length $ptable) {
+ $WHERE .= " AND conrelid=$oid{'P'}::oid";
+ }
+ else {
+ $WHERE .= " AND conrelid IN (SELECT DISTINCT confrelid FROM ${C}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,
+ ${C}quote_ident(c.relname) AS t_name, ${C}quote_ident(n2.nspname) AS t_schema,
+ ${C}quote_ident(n.nspname) AS c_schema, ${C}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 ${C}pg_constraint k, ${C}pg_class c, ${C}pg_namespace n, ${C}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 (@$info) {
+ $colnum{$_->{'conrelid'}}{$1}++ while $_->{'conkey'} =~ /(\d+)/go;
+ if ($_->{'contype'} eq 'f') {
+ $colnum{$_->{'confrelid'}}{$1}++ while $_->{'confkey'} =~ /(\d+)/go;
+ }
+ }
+
+ ## Get the information about the columns computed above
+ my $SQL = qq{
+ SELECT a.attrelid, a.attnum, ${C}quote_ident(a.attname) AS colname,
+ ${C}quote_ident(t.typname) AS typename
+ FROM ${C}pg_attribute a, ${C}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 split/\s*/, $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 split/\s*/, $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];
+ }
+
+ ## ODBC is primary keys only
+ next if $odbc and ($u->{'contype'} ne 'p' or $multi eq 'index');
+
+ my (@conkey, @confkey);
+ push (@conkey, $1) while $t->{'conkey'} =~ /(\d+)/go;
+ push (@confkey, $1) while $t->{'confkey'} =~ /(\d+)/go;
+ 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
+ ));
+
+ 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 $version = $dbh->{private_dbdpg}{version};
+
+ if ( # Rule 19a
+ (defined $catalog and $catalog eq '%')
+ and (defined $schema and $schema eq '')
+ and (defined $table and $table eq '')
+ ) {
+ $tbl_sql = q{
+ 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"
+ };
+ }
+ elsif (# Rule 19b
+ (defined $catalog and $catalog eq '')
+ and (defined $schema and $schema eq '%')
+ and (defined $table and $table eq '')
+ ) {
+ $tbl_sql = $version >= 70300 ?
+ q{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"
+ FROM pg_catalog.pg_namespace n
+ ORDER BY "TABLE_SCHEM"
+ } :
+ q{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"
+ };
+ }
+ 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 = q{
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , NULL::text AS "TABLE_SCHEM"
+ , NULL::text AS "TABLE_NAME"
+ , 'TABLE' AS "TABLE_TYPE"
+ , 'relkind: r' AS "REMARKS"
+ 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"
+ };
+ }
+ else {
+ # Default SQL
+ my $showschema = "NULL::text";
+ my $schemajoin = '';
+ my $has_objsubid = '';
+ my $tablespacejoin = '';
+ my $showtablespace = '';
+ my @search;
+ if ($version >= 70300) {
+ $showschema = "quote_ident(n.nspname)";
+ $schemajoin = "LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)";
+ $has_objsubid = "AND d.objsubid = 0";
+ }
+ if ($version >= 70500) {
+ $tablespacejoin = 'LEFT JOIN pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace)';
+ $showtablespace = ', quote_ident(t.spcname) AS "pg_tablespace_name", quote_ident(t.spclocation) AS "pg_tablespace_location"';
+ }
+
+ ## If the schema or table has an underscore or a %, use a LIKE comparison
+ if (defined $schema and length $schema and $version >= 70300) {
+ 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 = "IN ('r','v')";
+ if (defined $type and length $type) {
+ if ($type =~ /\btable\b/i and $type !~ /\bview\b/i) {
+ $typesearch = "= 'r'";
+ }
+ elsif ($type =~ /\bview\b/i and $type !~ /\btable\b/i) {
+ $typesearch = "= 'v'";
+ }
+ }
+ push @search, "c.relkind $typesearch";
+
+ my $whereclause = join "\n\t\t\t\t\t AND " => @search;
+ my $schemacase = $version >= 70300 ? "quote_ident(n.nspname)" : "quote_ident(c.relname)";
+ $tbl_sql = qq{
+ SELECT NULL::text AS "TABLE_CAT"
+ , $showschema AS "TABLE_SCHEM"
+ , quote_ident(c.relname) AS "TABLE_NAME"
+ , CASE
+ WHEN c.relkind = 'v' THEN
+ CASE WHEN $schemacase ~ '^pg_' THEN 'SYSTEM VIEW' ELSE 'VIEW' END
+ ELSE
+ CASE WHEN $schemacase ~ '^pg_' THEN 'SYSTEM TABLE' ELSE 'TABLE' END
+ END AS "TABLE_TYPE"
+ , d.description AS "REMARKS" $showtablespace
+ FROM ${DBD::Pg::dr::CATALOG}pg_class AS c
+ LEFT JOIN ${DBD::Pg::dr::CATALOG}pg_description AS d
+ ON (c.relfilenode = d.objoid $has_objsubid)
+ $schemajoin $tablespacejoin
+ 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 $version = $dbh->{private_dbdpg}{version};
+ my @tables = map { ($version >= 70300
+ and (! (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 = ();
+ @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 = undef;
+ 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, "'","'", $UN, 1,0,3, $UN,0,0, 'BYTEA', $UN,$UN,
+ SQL_VARBINARY, $UN, $UN, $UN ],
+['bpchar', SQL_CHAR, $GIG, "'","'", $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, "'","'", $UN, 1,0,2, $UN,0,0, 'DATE', 0,0,
+ SQL_DATE, $UN, $UN, $UN ],
+['tinterval',SQL_TIME, 18, "'","'", $UN, 1,0,2, $UN,0,0, 'TINTERVAL', 0,6,
+ SQL_TIME, $UN, $UN, $UN ],
+['timestamp',SQL_TIMESTAMP, 29, "'","'", $UN, 1,0,2, $UN,0,0, 'TIMESTAMP', 0,6,
+ SQL_TIMESTAMP, $UN, $UN, $UN ],
+['text', SQL_VARCHAR, $GIG, "'","'", $LEN, 1,1,3, $UN,0,0, 'TEXT', $UN,$UN,
+ SQL_VARCHAR, $UN, $UN, $UN ],
+['bool', SQL_BOOLEAN, 1, "'","'", $UN, 1,0,2, $UN,0,0, 'BOOLEAN', $UN,$UN,
+ SQL_BOOLEAN, $UN, $UN, $UN ],
+['array', SQL_ARRAY, 1, "'","'", $UN, 1,0,2, $UN,0,0, 'ARRAY', $UN,$UN,
+ SQL_ARRAY, $UN, $UN, $UN ],
+['date', SQL_TYPE_DATE, 10, "'","'", $UN, 1,0,2, $UN,0,0, 'DATE', 0,0,
+ SQL_TYPE_DATE, $UN, $UN, $UN ],
+['time', SQL_TYPE_TIME, 18, "'","'", $UN, 1,0,2, $UN,0,0, 'TIME', 0,6,
+ SQL_TYPE_TIME, $UN, $UN, $UN ],
+['timestamp',SQL_TYPE_TIMESTAMP,29, "'","'", $UN, 1,0,2, $UN,0,0, 'TIMESTAMP', 0,6,
+ SQL_TYPE_TIMESTAMP, $UN, $UN, $UN ],
+['timetz', SQL_TYPE_TIME_WITH_TIMEZONE,
+ 29, "'","'", $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, "'","'", $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 = (
+ "'" => '\\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 $version = $dbh->{private_dbdpg}{version};
+
+ my %type = (
+
+## Driver information:
+
+ 116 => ["SQL_ACTIVE_ENVIRONMENTS", 0 ],
+ 10021 => ["SQL_ASYNC_MODE", 0 ],
+ 120 => ["SQL_BATCH_ROW_COUNT", 2 ],
+ 121 => ["SQL_BATCH_SUPPORT", 3 ], ## ??
+ 2 => ["SQL_DATA_SOURCE_NAME", 'dbi:Pg:db='.$dbh->{Name} ], ## TODO: support port and other args
+ 3 => ["SQL_DRIVER_HDBC", 0 ], ## ??
+ 135 => ["SQL_DRIVER_HDESC", 0 ],
+ 4 => ["SQL_DRIVER_HENV", 0 ],
+ 76 => ["SQL_DRIVER_HLIB", 0 ],
+ 5 => ["SQL_DRIVER_HSTMT", 0 ],
+ 6 => ["SQL_DRIVER_NAME", 'DBD/Pg.pm' ],
+ 77 => ["SQL_DRIVER_ODBC_VERSION", '03.00' ], ## ??
+ 7 => ["SQL_DRIVER_VER", 'DBDVERSION' ],
+ 144 => ["SQL_DYNAMIC_CURSOR_ATTRIBUTES1", 0 ], ## ?? 519
+ 145 => ["SQL_DYNAMIC_CURSOR_ATTRIBUTES2", 0 ], ## ?? 5209
+ 84 => ["SQL_FILE_USAGE", 0 ],
+ 146 => ["SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1", 519 ], ## ??
+ 147 => ["SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2", 5209 ], ## ??
+ 81 => ["SQL_GETDATA_EXTENSIONS", 15 ],
+ 149 => ["SQL_INFO_SCHEMA_VIEWS", $version<70400? 0:3932149 ], # not: assert, charset, collat, trans
+ 150 => ["SQL_KEYSET_CURSOR_ATTRIBUTES1", 0 ],
+ 151 => ["SQL_KEYSET_CURSOR_ATTRIBUTES2", 0 ],
+ 10022 => ["SQL_MAX_ASYNC_CONCURRENT_STATEMENTS", 0 ],
+ 0 => ["SQL_MAX_DRIVER_CONNECTIONS", 'MAXCONNECTIONS' ],
+ 152 => ["SQL_ODBC_INTERFACE_CONFORMANCE", 1 ], ## ??
+ 10 => ["SQL_ODBC_VER", '03.00.0000' ], ## ??
+ 153 => ["SQL_PARAM_ARRAY_ROW_COUNTS", 2 ],
+ 154 => ["SQL_PARAM_ARRAY_SELECTS", 3 ],
+ 11 => ["SQL_ROW_UPDATES", 'N' ],
+ 14 => ["SQL_SEARCH_PATTERN_ESCAPE", '\\' ],
+ 13 => ["SQL_SERVER_NAME", $dbh->{Name} ],
+ 166 => ["SQL_STANDARD_CLI_CONFORMANCE", 2 ], ## ??
+ 167 => ["SQL_STATIC_CURSOR_ATTRIBUTES1", 519 ], ## ??
+ 168 => ["SQL_STATIC_CURSOR_ATTRIBUTES2", 5209 ], ## ??
+
+## DBMS Information
+
+ 16 => ["SQL_DATABASE_NAME", $dbh->{Name} ],
+ 17 => ["SQL_DBMS_NAME", 'PostgreSQL' ],
+ 18 => ["SQL_DBMS_VERSION", 'ODBCVERSION' ],
+
+## Data source information
+
+ 20 => ["SQL_ACCESSIBLE_PROCEDURES", "Y" ],
+ 19 => ["SQL_ACCESSIBLE_TABLES", "Y" ],
+ 82 => ["SQL_BOOKMARK_PERSISTENCE", 0 ],
+ 42 => ["SQL_CATALOG_TERM", '' ],
+ 10004 => ["SQL_COLLATION_SEQ", 'ENCODING' ], ## ??
+ 22 => ["SQL_CONCAT_NULL_BEHAVIOR", 0 ],
+ 23 => ["SQL_CURSOR_COMMIT_BEHAVIOR", 1 ],
+ 24 => ["SQL_CURSOR_ROLLBACK_BEHAVIOR", 1 ],
+ 10001 => ["SQL_CURSOR_SENSITIVITY", 1 ],
+ 25 => ["SQL_DATA_SOURCE_READ_ONLY", "N" ],
+ 26 => ["SQL_DEFAULT_TXN_ISOLATION", 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 ],
+ 40 => ["SQL_PROCEDURE_TERM", "function" ], ## for now
+ 39 => ["SQL_SCHEMA_TERM", "schema" ],
+ 44 => ["SQL_SCROLL_OPTIONS", 8 ], ## ??
+ 45 => ["SQL_TABLE_TERM", "table" ],
+ 46 => ["SQL_TXN_CAPABLE", 2 ],
+ 72 => ["SQL_TXN_ISOLATION_OPTION", 15 ],
+ 47 => ["SQL_USER_NAME", $dbh->{CURRENT_USER} ],
+
+## Supported SQL
+
+ 169 => ["SQL_AGGREGATE_FUNCTIONS", 127 ],
+ 117 => ["SQL_ALTER_DOMAIN", 31 ],
+ 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 ],
+ 127 => ["SQL_CREATE_ASSERTION", 0 ],
+ 128 => ["SQL_CREATE_CHARACTER_SET", 0 ],
+ 129 => ["SQL_CREATE_COLLATION", 0 ],
+ 130 => ["SQL_CREATE_DOMAIN", 23 ],
+ 131 => ["SQL_CREATE_SCHEMA", $version<70300 ? 0 : 3 ],
+ 132 => ["SQL_CREATE_TABLE", 13845 ],
+ 133 => ["SQL_CREATE_TRANSLATION", 0 ],
+ 134 => ["SQL_CREATE_VIEW", 9 ],
+ 119 => ["SQL_DATETIME_LITERALS", 65535 ],
+ 170 => ["SQL_DDL_INDEX", 3 ],
+ 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", $version<70300 ? 0 : 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 ],
+ 28 => ["SQL_IDENTIFIER_CASE", 2 ], ## kinda
+ 29 => ["SQL_IDENTIFIER_QUOTE_CHAR", '"' ],
+ 148 => ["SQL_INDEX_KEYWORDS", 0 ],
+ 172 => ["SQL_INSERT_STATEMENT", 7 ],
+ 73 => ["SQL_INTEGERITY", "Y" ], ## e.g. ON DELETE CASCADE?
+ 89 => ["SQL_KEYWORDS", 'KEYWORDS' ],
+ 113 => ["SQL_LIKE_ESCAPE_CLAUSE", "Y" ],
+ 75 => ["SQL_NON_NULLABLE_COLUMNS", 1 ],
+ 115 => ["SQL_OJ_CAPABILITIES", 127 ],
+ 90 => ["SQL_ORDER_BY_COLUMNS_IN_SELECT", "N" ],
+ 38 => ["SQL_OUTER_JOINS", "Y" ],
+ 21 => ["SQL_PROCEDURES", "Y" ],
+ 93 => ["SQL_QUOTED_IDENTIFIER_CASE", 3 ],
+ 91 => ["SQL_SCHEMA_USAGE", $version<70300 ? 0 : 31 ],
+ 94 => ["SQL_SPECIAL_CHARACTERS", '$' ],
+ 118 => ["SQL_SQL_CONFORMANCE", 4 ], ## ??
+ 95 => ["SQL_SUBQUERIES", 31 ],
+ 96 => ["SQL_UNION", 3 ],
+
+## 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' ],
+ 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", 1600 ], ## depends on column types
+ 31 => ["SQL_MAX_CURSOR_NAME_LEN", 'NAMEDATALEN' ],
+ 10005 => ["SQL_MAX_IDENTIFIER_LEN", 'NAMEDATALEN' ],
+ 102 => ["SQL_MAX_INDEX_SIZE", 0 ],
+ 102 => ["SQL_MAX_PROCEDURE_NAME_LEN", 'NAMEDATALEN' ],
+ 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' ],
+ 105 => ["SQL_MAX_STATEMENT_LEN", 0 ],
+ 35 => ["SQL_MAX_TABLE_NAME_LEN", 'NAMEDATALEN' ],
+ 106 => ["SQL_MAX_TABLES_IN_SELECT", 0 ],
+ 107 => ["SQL_MAX_USER_NAME_LEN", 'NAMEDATALEN' ],
+
+## Scalar function information
+
+ 48 => ["SQL_CONVERT_FUNCTIONS", 2 ], ## ??
+ 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 $version >= 70300 ? 63 : 31; ## Could technically be more
+ }
+ elsif ($ans eq 'ODBCVERSION') {
+ 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 ILIKE INITIALLY ISNULL LIMIT NOTNULL OFF OFFSET PLACING VERBOSE));
+ }
+
+ return $ans;
+ } # end of get_info
+}
+
+
+{
+ package DBD::Pg::st;
+
+ sub bind_param_array { ## The DBI version is broken, so we implement a near-copy here
+ my $sth = shift;
+ my ($p_id, $value_array, $attr) = @_;
+
+ 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';
+
+ return $sth->set_err(1, "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
+
+ # get/create arrayref to hold params
+ my $hash_of_arrays = $sth->{ParamArrays} ||= { };
+
+ if (ref $value_array eq 'ARRAY') {
+ # check that input has same length as existing
+ # find first arrayref entry (if any)
+ for (keys %$hash_of_arrays) {
+ my $v = $$hash_of_arrays{$_};
+ next unless ref $v eq 'ARRAY';
+ return $sth->set_err
+ (1,"Arrayref for parameter $p_id has ".@$value_array." elements"
+ ." but parameter $_ has ".@$v)
+ if @$value_array != @$v;
+ }
+ }
+
+ $$hash_of_arrays{$p_id} = $value_array;
+ return $sth->bind_param($p_id, '', $attr) if $attr; ## This is the big change so -w does not complain
+ 1;
+ }
+
+
+} ## end st section
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBD::Pg - PostgreSQL database driver for the DBI module
+
+=head1 VERSION
+
+This documents version 1.45 of the DBD::Pg module
+
+=head1 SYNOPSIS
+
+ use DBI;
+
+ $dbh = DBI->connect("dbi:Pg:dbname=$dbname", "", "", {AutoCommit => 0});
+
+ # For some advanced uses you may need PostgreSQL type values:
+ use DBD::Pg qw(:pg_types);
+
+ # See the DBI module documentation for full details
+
+=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 L<DBI|DBI> documentation first!
+
+=head1 THE DBI CLASS
+
+=head2 DBI Class Methods
+
+=over 4
+
+=item B<connect>
+
+To connect to a database with a minimum of parameters, use the following
+syntax:
+
+ $dbh = DBI->connect("dbi:Pg:dbname=$dbname", "", "");
+
+This connects to the database $dbname at localhost without any user
+authentication. This is sufficient for the defaults of PostgreSQL (excluding
+some package-installed versions).
+
+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});
+
+If a parameter is undefined PostgreSQL first looks for specific environment
+variables and then it uses 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 ""
+ options PGOPTIONS ""
+ service* PGSERVICE ""
+ sslmode* PGSSLMODE ""
+
+* Only for servers running version 7.4 or greater
+
+** Can also use "db" or "database"
+
+The options parameter specifies runtime options for the Postgres
+backend. Common usage is to increase the number of buffers with the C<-B>
+option. Also important is the C<-F> option, which disables automatic fsync()
+call after each transaction. For further details please refer to the
+PostgreSQL documentation at L<http://www.postgresql.org/docs/>.
+
+For authentication with username and password, appropriate entries have to be
+made in F<pg_hba.conf>. Please refer to the comments in the F<pg_hba.conf> and
+the F<pg_passwd> files for the different types of authentication. Note that
+for these two parameters DBI distinguishes between empty and undefined. If
+these parameters are undefined DBI substitutes the values of the environment
+variables C<DBI_USER> and C<DBI_PASS> if present.
+
+=item B<available_drivers>
+
+ @driver_names = DBI->available_drivers;
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<data_sources>
+
+ @data_sources = DBI->data_sources('Pg');
+
+This driver supports this method. Note that the necessary database connection
+to the database "template1" will be made on the localhost without any user
+authentication. Other preferences can only be set with the environment
+variables C<PGHOST>, C<PGPORT>, C<DBI_USER>, and C<DBI_PASS>.
+
+=back
+
+=head1 METHODS COMMON TO ALL HANDLES
+
+=over 4
+
+=item B<err>
+
+ $rv = $h->err;
+
+Supported by this driver as proposed by DBI. For the connect method it returns
+C<PQstatus>. In all other cases it returns C<PQresultStatus> of the current
+handle.
+
+=item B<errstr>
+
+ $str = $h->errstr;
+
+Supported by this driver as proposed by DBI. It returns the C<PQerrorMessage>
+related to the current handle.
+
+=item B<state>
+
+ $str = $h->state;
+
+Supported by this driver. Returns a five-character "SQLSTATE" code.
+Success is indicated by a "00000" code, which gets mapped to an
+empty string by DBI. A code of S8006 indicates a connection failure,
+usually because the connection to the PostgreSQL server has been lost.
+Note that this can be called as both $sth->state and $dbh->state.
+
+PostgreSQL servers version less than 7.4 will return a small subset
+of the available codes, and should not be relied upon.
+
+The list of codes used by PostgreSQL can be found at:
+L<http://www.postgresql.org/docs/current/static/errcodes-appendix.html>
+
+=item B<trace>
+
+ $h->trace($trace_level, $trace_filename);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<trace_msg>
+
+ $h->trace_msg($message_text);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<func>
+
+This driver supports a variety of driver specific functions accessible via the
+C<func> method. Note that the name of the function comes last, after the arguments.
+
+=over
+
+=item table_attributes
+
+ $attrs = $dbh->func($table, 'table_attributes');
+
+The C<table_attributes> function is no longer recommended. Instead,
+you can use the more portable C<column_info> and C<primary_key> methods
+to access the same information.
+
+The C<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
+
+The REMARKS field will be returned as C<NULL> for Postgres versions 7.1.x and
+older.
+
+=item lo_creat
+
+ $lobjId = $dbh->func($mode, 'lo_creat');
+
+Creates a new large object and returns the object-id. $mode is a bitmask
+describing different attributes of the new object. Use the following
+constants:
+
+ $dbh->{pg_INV_WRITE}
+ $dbh->{pg_INV_READ}
+
+Upon failure it returns C<undef>.
+
+=item lo_open
+
+ $lobj_fd = $dbh->func($lobjId, $mode, 'lo_open');
+
+Opens an existing large object and returns an object-descriptor for use in
+subsequent C<lo_*> calls. For the mode bits see C<lo_creat>. Returns C<undef>
+upon failure. Note that 0 is a perfectly correct object descriptor!
+
+=item lo_write
+
+ $nbytes = $dbh->func($lobj_fd, $buf, $len, 'lo_write');
+
+Writes $len bytes of $buf into the large object $lobj_fd. Returns the number
+of bytes written and C<undef> upon failure.
+
+=item lo_read
+
+ $nbytes = $dbh->func($lobj_fd, $buf, $len, 'lo_read');
+
+Reads $len bytes into $buf from large object $lobj_fd. Returns the number of
+bytes read and C<undef> upon failure.
+
+=item lo_lseek
+
+ $loc = $dbh->func($lobj_fd, $offset, $whence, 'lo_lseek');
+
+Changes the current read or write location on the large object
+$obj_id. Currently $whence can only be 0 (C<L_SET>). Returns the current
+location and C<undef> upon failure.
+
+=item lo_tell
+
+ $loc = $dbh->func($lobj_fd, 'lo_tell');
+
+Returns the current read or write location on the large object $lobj_fd and
+C<undef> upon failure.
+
+=item lo_close
+
+ $lobj_fd = $dbh->func($lobj_fd, 'lo_close');
+
+Closes an existing large object. Returns true upon success and false upon
+failure.
+
+=item lo_unlink
+
+ $ret = $dbh->func($lobjId, 'lo_unlink');
+
+Deletes an existing large object. Returns true upon success and false upon
+failure.
+
+=item lo_import
+
+ $lobjId = $dbh->func($filename, 'lo_import');
+
+Imports a Unix file as large object and returns the object id of the new
+object or C<undef> upon failure.
+
+=item lo_export
+
+ $ret = $dbh->func($lobjId, $filename, 'lo_export');
+
+Exports a large object into a Unix file. Returns false upon failure, true
+otherwise.
+
+=item pg_notifies
+
+ $ret = $dbh->func('pg_notifies');
+
+Returns either C<undef> or a reference to two-element array [ $table,
+$backend_pid ] of asynchronous notifications received.
+
+=item getfd
+
+ $fd = $dbh->func('getfd');
+
+Returns fd of the actual connection to server. Can be used with select() and
+func('pg_notifies'). Deprecated in favor of C<< $dbh->{pg_socket} >>.
+
+=back
+
+=back
+
+=head1 ATTRIBUTES COMMON TO ALL HANDLES
+
+=over 4
+
+=item B<Warn> (boolean, inherited)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<Active> (boolean, read-only)
+
+Supported by this driver as proposed by DBI. A database handle is active while
+it is connected and statement handle is active until it is finished.
+
+=item B<Kids> (integer, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<ActiveKids> (integer, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<CachedKids> (hash ref)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<CompatMode> (boolean, inherited)
+
+Not used by this driver.
+
+=item B<InactiveDestroy> (boolean)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<PrintError> (boolean, inherited)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<RaiseError> (boolean, inherited)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<HandleError> (boolean, inherited)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<ChopBlanks> (boolean, inherited)
+
+Supported by this driver as proposed by DBI. This method is similar to the
+SQL function C<RTRIM>.
+
+=item B<LongReadLen> (integer, inherited)
+
+Implemented by DBI, not used by this driver.
+
+=item B<LongTruncOk> (boolean, inherited)
+
+Implemented by DBI, not used by this driver.
+
+=item B<Taint> (boolean, inherited)
+
+Implemented by DBI, no driver-specific impact.
+
+=back
+
+=head1 DBI DATABASE HANDLE OBJECTS
+
+=head2 Database Handle Methods
+
+=over 4
+
+=item B<selectrow_array>
+
+ @row_ary = $dbh->selectrow_array($statement, \%attr, @bind_values);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<selectrow_arrayref>
+
+ $ary_ref = $dbh->selectrow_arrayref($statement, \%attr, @bind_values);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<selectrow_hashref>
+
+ $hash_ref = $dbh->selectrow_hashref($statement, \%attr, @bind_values);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<selectall_arrayref>
+
+ $ary_ref = $dbh->selectall_arrayref($statement, \%attr, @bind_values);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<selectall_hashref>
+
+ $hash_ref = $dbh->selectall_hashref($statement, $key_field);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<selectcol_arrayref>
+
+ $ary_ref = $dbh->selectcol_arrayref($statement, \%attr, @bind_values);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<prepare>
+
+ $sth = $dbh->prepare($statement, \%attr);
+
+WARNING: DBD::Pg now uses true prepared statements by sending them
+to the backend to be prepared by the PostgreSQL server. Statements
+that were legal before may no longer work. See below for details.
+
+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 execute().
+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.
+
+Statements that do not begin with the word "SELECT", "INSERT",
+"UPDATE", or "DELETE" will not be sent to be server-side prepared.
+
+Deciding whether or not to use prepared statements depends on many
+factors, but you can force them to be used or not used by passing
+the C<pg_server_prepare> attribute to prepare(). A "0" means to never
+use prepared statements. This is the default when connected to servers
+earlier than version 7.4, which is when prepared statements were introduced.
+Setting C<pg_server_prepare> to "1" means that prepared statements
+should be used whenever possible. This is the default for 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 pg_server_prepare 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. Further discussion on this subject is beyond
+the scope of this documentation: please consult the pgsql-performance mailing
+list, L<http://archives.postgresql.org/pgsql-performance/>
+
+Only certain commands will be sent to a server-side prepare: currently these
+include C<SELECT>, C<INSERT>, C<UPDATE>, and C<DELETE>. DBD::Pg uses a simple
+naming scheme for the prepared statements: C<dbdpg_#>, where "#" starts at 1 and
+increases. This number is tracked at the database handle level, so multiple
+statement handles will not collide. If you use your own prepare statements, do
+not name them "dbdpg_"!
+
+The actual C<PREPARE> is not performed until the first execute is called, due
+to the fact that information on the data types (provided by C<bind_param>) may
+be given after the prepare but before the execute.
+
+A server-side prepare can also happen before the first execute. If the server can
+handle the server-side prepare and the statement has no placeholders, it will
+be prepared right away. It will also be prepared if the C<pg_prepare_now> attribute
+is passed. Similarly, the <pg_prepare_now> attribute can be set to 0 to ensure that
+the statement is B<not> prepared immediately, although cases in which you would
+want this may be rare. Finally, you can set the default behavior of all prepare
+statements by setting the C<pg_prepare_now> attribute on the database handle:
+
+ $dbh->{pg_prepare_now} = 1;
+
+The following two examples will be prepared right away:
+
+ $sth->prepare("SELECT 123"); ## no placeholders
+
+ $sth->prepare("SELECT 123, ?", {pg_prepare_now = 1});
+
+The following two examples will NOT be prepared right away:
+
+ $sth->prepare("SELECT 123, ?"); ## has a placeholder
+
+ $sth->prepare("SELECT 123", {pg_prepare_now = 0});
+
+There are times when you may want to prepare a statement yourself. To do this,
+simply send the C<PREPARE> statement directly to the server (e.g. with
+"do"). Create a statement handle and set the prepared name via
+C<pg_prepare_name> attribute. The statement handle can be created with a dummy
+statement, as it will not be executed. However, it should have the same
+number of placeholders as your prepared statement. Example:
+
+ $dbh->do("PREPARE mystat AS SELECT COUNT(*) FROM pg_class WHERE reltuples < ?");
+ $sth = $dbh->prepare("SELECT ?");
+ $sth->bind_param(1, 1, SQL_INTEGER);
+ $sth->{pg_prepare_name} = "mystat";
+ $sth->execute(123);
+
+The above will run this query:
+
+ SELECT COUNT(*) FROM pg_class WHERE reltuples < 123;
+
+Note: DBD::Pg will not escape your custom prepared statement name, so don't
+use a name that needs escaping! DBD::Pg uses the prepare names C<dbdpg_#>
+internally, so please do not use those either.
+
+You can force DBD::Pg to send your query directly to the server by adding
+the C<pg_direct> attribute to your prepare call. This is not recommended,
+but is added just in case you need it.
+
+=item B<Placeholders>
+
+There are three types of placeholders that can be used in DBD::Pg. The first is
+the question mark method, in which each placeholder is represented by a single
+question mark. This is the method recommended by the DBI specs and is the most
+portable. Each question mark is replaced by a "dollar sign number" in the order
+in which they appear in the query (important when using C<bind_param>).
+
+The second method is to use "dollar sign numbers" directly. This is the method
+that PostgreSQL uses internally and is overall probably the best method to use
+if you do not need compatibility with other database systems. DBD::Pg, like
+PostgreSQL, allows the same number to be used more than once in the query.
+Numbers must start with "1" and increment by one value. If the same number
+appears more than once in a query, it is treated as a single parameter and all
+instances are replaced at once. Examples:
+
+Not legal:
+
+ $SQL = "SELECT count(*) FROM pg_class WHERE relpages > $2";
+
+ $SQL = "SELECT count(*) FROM pg_class WHERE relpages BETWEEN $1 AND $3";
+
+Legal:
+
+ $SQL = "SELECT count(*) FROM pg_class WHERE relpages > $1";
+
+ $SQL = "SELECT count(*) FROM pg_class WHERE relpages BETWEEN $1 AND $2";
+
+ $SQL = "SELECT count(*) FROM pg_class WHERE relpages BETWEEN $1 AND $2 AND reltuples > $1";
+
+ $SQL = "SELECT count(*) FROM pg_class WHERE relpages > $1 AND reltuples > $1";
+
+In the final statement above, DBI thinks there is only one placeholder, so this
+statement will replace both placeholders:
+
+ $sth->bind_param(1, 2045);
+
+While execute requires only a single argument as well:
+
+ $sth->execute(2045);
+
+The final placeholder method is the named parameters in the format ":foo". While this
+syntax is supported by DBD::Pg, its use is highly discouraged.
+
+The different types of placeholders cannot be mixed within a statement, but you may
+use different ones for each statement handle you have. Again, this is not encouraged.
+
+=item B<prepare_cached>
+
+ $sth = $dbh->prepare_cached($statement, \%attr);
+
+Implemented by DBI, no driver-specific impact. This method is most useful
+when using a server that supports server-side prepares, and you have asked
+the prepare to happen immediately via the C<pg_prepare_now> attribute.
+
+=item B<do>
+
+ $rv = $dbh->do($statement, \%attr, @bind_values);
+
+Prepare and execute a single statement. Note that an empty statement
+(string with no length) will not be passed to the server; if you
+want a simple test, use "SELECT 123" or the ping() function. If
+neither attr nor bind_values is given, the query will be sent directly
+to the server without the overhead of creating a statement handle and
+running prepare and execute.
+
+
+=item B<last_insert_id>
+
+ $rv = $dbh->last_insert_id($catalog, $schema, $table, $field);
+ $rv = $dbh->last_insert_id($catalog, $schema, $table, $field, \%attr);
+
+Attempts to return the id of the last value to be inserted into a table.
+You can either provide a sequence name (preferred) or provide a table
+name with optional schema. The $catalog and $field arguments are always ignored.
+The current value of the sequence is returned by a call to the
+C<CURRVAL()> PostgreSQL function. This will fail if the sequence has not yet
+been used in the current database connection.
+
+If you do not know the name of the sequence, you can provide a table name and
+DBD::Pg will attempt to return the correct value. To do this, there must be at
+least one column in the table with a C<NOT NULL> constraint, that has a unique
+constraint, and which uses a sequence as a default value. If more than one column
+meets these conditions, the primary key will be used. This involves some
+looking up of things in the system table, so DBD::Pg will cache the sequence
+name for susequent calls. If you need to disable this caching for some reason,
+you can control it via the C<pg_cache> attribute.
+
+Please keep in mind that this method is far from foolproof, so make your
+script use it properly. Specifically, make sure that it is called
+immediately after the insert, and that the insert does not add a value
+to the column that is using the sequence as a default value.
+
+Some examples:
+
+ $dbh->do("CREATE SEQUENCE lii_seq START 1");
+ $dbh->do("CREATE TABLE lii (
+ foobar INTEGER NOT NULL UNIQUE DEFAULT nextval('lii_seq'),
+ baz VARCHAR)");
+ $SQL = "INSERT INTO lii(baz) VALUES (?)";
+ $sth = $dbh->prepare($SQL);
+ for (qw(uno dos tres cuatro)) {
+ $sth->execute($_);
+ my $newid = $dbh->last_insert_id(C<undef>,undef,undef,undef,{sequence=>'lii_seq'});
+ print "Last insert id was $newid\n";
+ }
+
+If you did not want to worry about the sequence name:
+
+ $dbh->do("CREATE TABLE lii2 (
+ foobar SERIAL UNIQUE,
+ baz VARCHAR)");
+ $SQL = "INSERT INTO lii2(baz) VALUES (?)";
+ $sth = $dbh->prepare($SQL);
+ for (qw(uno dos tres cuatro)) {
+ $sth->execute($_);
+ my $newid = $dbh->last_insert_id(undef,undef,"lii2",undef);
+ print "Last insert id was $newid\n";
+ }
+
+=item B<commit>
+
+ $rc = $dbh->commit;
+
+Supported by this driver as proposed by DBI. See also the notes about
+B<Transactions> elsewhere in this document.
+
+=item B<rollback>
+
+ $rc = $dbh->rollback;
+
+Supported by this driver as proposed by DBI. See also the notes about
+B<Transactions> elsewhere in this document.
+
+=item B<disconnect>
+
+ $rc = $dbh->disconnect;
+
+Supported by this driver as proposed by DBI.
+
+=item B<ping>
+
+ $rc = $dbh->ping;
+
+This driver supports the C<ping> method, which can be used to check the validity
+of a database handle. The value returned is either 0, indicating that the
+connection is no longer valid, or a positive integer, indicating the following:
+
+ Value Meaning
+ --------------------------------------------------
+ 1 Database is idle (not in a transaction)
+ 2 Database is active, there is a command in progress (usually seen after a COPY command)
+ 3 Database is idle within a transaction
+ 4 Database is idle, within a failed transaction
+
+Additional information on why a handle is not valid can be obtained by using the
+C<pg_ping> method.
+
+=item B<pg_ping>
+
+ $rc = $dbh->pg_ping;
+
+This is a Postgres-specific extension to the C<ping> command. This will check the
+validity of a database handle in exactly the same way as C<ping>, but instead of
+returning a 0 for an invalid connection, it will return a negative number. The
+positive numbers are documented at C<ping>, the negative ones indicate:
+
+ Value Meaning
+ --------------------------------------------------
+ -1 There is no connection to the database at all (e.g. after C<disconnect>)
+ -2 An unknown transaction status was returned (e.g. after forking)
+ -3 The handle exists, but no data was returned from a test query.
+
+In practice, you should only ever see -1 and -2.
+
+=item B<column_info>
+
+ $sth = $dbh->column_info( $catalog, $schema, $table, $column );
+
+Supported by this driver as proposed by DBI with the follow exceptions.
+These fields are currently always returned with NULL (C<undef>) values:
+
+ TABLE_CAT
+ BUFFER_LENGTH
+ DECIMAL_DIGITS
+ NUM_PREC_RADIX
+ SQL_DATA_TYPE
+ SQL_DATETIME_SUB
+ CHAR_OCTET_LENGTH
+
+Also, two additional non-standard fields are returned:
+
+ pg_type - data type with additional info i.e. "character varying(20)"
+ pg_constraint - holds column constraint definition
+
+The REMARKS field will be returned as NULL (C<undef> for PostgreSQL versions
+older than 7.2. The TABLE_SCHEM field will be returned as NULL (C<undef>) for
+versions older than 7.4.
+
+=item B<table_info>
+
+ $sth = $dbh->table_info( $catalog, $schema, $table, $type );
+
+Supported by this driver as proposed by DBI. This method returns all tables
+and views visible to the current user. The $catalog argument is currently
+unused. The schema and table arguments will do a C<LIKE> search if a percent
+sign (C<%>) or an underscore (C<_>) is detected in the argument. The $type
+argument accepts a value of either "TABLE" or "VIEW" (using both is the
+default action).
+
+The TABLE_CAT field will always return NULL (C<undef>). The TABLE_SCHEM field
+returns NULL (C<undef>) if the server is older than version 7.4.
+
+If your database supports tablespaces (version 8.0 or greater), two additional
+columns are returned, "pg_tablespace_name" and "pg_tablespace_location",
+that contain the name and location of the tablespace associated with
+this table. Tables that have not been assigned to a particular tablespace
+will return NULL (C<undef>) for both of these columns.
+
+=item B<primary_key_info>
+
+ $sth = $dbh->primary_key_info( $catalog, $schema, $table, \%attr );
+
+Supported by this driver as proposed by DBI. The $catalog argument is
+currently unused, and the $schema argument has no effect against
+servers running version 7.2 or older. There are no search patterns allowed,
+but leaving the $schema argument blank will cause the first table
+found in the schema search path to be used. An additional field, "DATA_TYPE",
+is returned and shows the data type for each of the arguments in the
+"COLUMN_NAME" field.
+
+This method will also return tablespace information for servers that support
+tablespaces. See the C<table_info> entry for more information.
+
+In addition to the standard format of returning one row for each column
+found for the primary key, you can pass the C<pg_onerow> attribute to force
+a single row to be used. If the primary key has multiple columns, the
+"KEY_SEQ", "COLUMN_NAME", and "DATA_TYPE" fields will return a comma-delimited
+string. If the C<pg_onerow> attribute is set to "2", the fields will be
+returned as an arrayref, which can be useful when multiple columns are
+involved:
+
+ $sth = $dbh->primary_key_info('', '', 'dbd_pg_test', {pg_onerow => 2});
+ if (defined $sth) {
+ my $pk = $sth->fetchall_arrayref()->[0];
+ print "Table $pk->[2] has a primary key on these columns:\n";
+ for (my $x=0; defined $pk->[3][$x]; $x++) {
+ print "Column: $pk->[3][$x] (data type: $pk->[6][$x])\n";
+ }
+ }
+
+=item B<primary_key>
+
+Supported by this driver as proposed by DBI.
+
+=item B<foreign_key_info>
+
+ $sth = $dbh->foreign_key_info( $pk_catalog, $pk_schema, $pk_table,
+ $fk_catalog, $fk_schema, $fk_table );
+
+Supported by this driver as proposed by DBI, using the SQL/CLI variant.
+This function returns C<undef> for PostgreSQL servers earlier than version
+7.3. There are no search patterns allowed, but leaving the $schema argument
+blank will cause the first table found in the schema search path to be
+used. Two additional fields, "UK_DATA_TYPE" and "FK_DATA_TYPE", are returned
+to show the data type for the unique and foreign key columns. Foreign
+keys that have no named constraint (where the referenced column only has
+an unique index) will return C<undef> for the "UK_NAME" field.
+
+=item B<tables>
+
+ @names = $dbh->tables( $catalog, $schema, $table, $type, \%attr );
+
+Supported by this driver as proposed by DBI. This method returns all tables
+and/or views which are visible to the current user: see C<table_info()>
+for more information about the arguments. If the database is version 7.3
+or later, the name of the schema appears before the table or view name. This
+can be turned off by adding in the C<pg_noprefix> attribute:
+
+ my @tables = $dbh->tables( '', '', 'dbd_pg_test', '', {pg_noprefix => 1} );
+
+=item B<type_info_all>
+
+ $type_info_all = $dbh->type_info_all;
+
+Supported by this driver as proposed by DBI. Information is only provided for
+SQL datatypes and for frequently used datatypes. The mapping between the
+PostgreSQL typename and the SQL92 datatype (if possible) has been done
+according to the following table:
+
+ +---------------+------------------------------------+
+ | typname | SQL92 |
+ |---------------+------------------------------------|
+ | bool | BOOL |
+ | text | / |
+ | bpchar | CHAR(n) |
+ | varchar | VARCHAR(n) |
+ | int2 | SMALLINT |
+ | int4 | INT |
+ | int8 | / |
+ | money | / |
+ | float4 | FLOAT(p) p<7=float4, p<16=float8 |
+ | float8 | REAL |
+ | abstime | / |
+ | reltime | / |
+ | tinterval | / |
+ | date | / |
+ | time | / |
+ | datetime | / |
+ | timespan | TINTERVAL |
+ | timestamp | TIMESTAMP |
+ +---------------+------------------------------------+
+
+For further details concerning the PostgreSQL specific datatypes please read
+L<pgbuiltin|pgbuiltin>.
+
+=item B<type_info>
+
+ @type_info = $dbh->type_info($data_type);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<quote>
+
+ $sql = $dbh->quote($value, $data_type);
+
+This module implements its own C<quote> method. In addition to the DBI method it
+also doubles the backslash, because PostgreSQL treats a backslash as an escape
+character.
+
+B<NOTE:> The undocumented (and invalid) support for the C<SQL_BINARY> data
+type is officially deprecated. Use C<PG_BYTEA> with C<bind_param()> instead:
+
+ $rv = $sth->bind_param($param_num, $bind_value,
+ { pg_type => DBD::Pg::PG_BYTEA });
+
+
+=item B<pg_server_trace>
+
+ $dbh->pg_server_trace($filehandle);
+
+Writes debugging information from the PostgreSQL backend to a file. This is
+not the same as the trace() method and you should not use this method unless
+you know what you are doing. If you do enable this, be aware that the file
+will grow very large, very quick. To stop logging to the file, use the
+C<pg_server_untrace> function. The first argument must be a file handle, not
+a filename. Example:
+
+ my $pid = $dbh->{pg_pid};
+ my $file = "pgbackend.$pid.debug.log";
+ open(my $fh, ">$file") or die qq{Could not open "$file": $!\n};
+ $dbh->pg_server_trace($fh);
+ ## Run code you want to trace here
+ $dbh->pg_server_untrace;
+ close($fh);
+
+=item B<pg_server_untrace>
+
+ $dbh->pg_server_untrace
+
+Stop server logging to a previously opened file.
+
+=back
+
+=head2 Database Handle Attributes
+
+=over 4
+
+=item B<AutoCommit> (boolean)
+
+Supported by this driver as proposed by DBI. According to the classification of
+DBI, PostgreSQL is a database in which a transaction must be explicitly
+started. Without starting a transaction, every change to the database becomes
+immediately permanent. The default of AutoCommit is on, but this may change
+in the future, so it is highly recommended that you explicitly set it when
+calling C<connect()>. For details see the notes about B<Transactions>
+elsewhere in this document.
+
+=item B<pg_bool_tf> (boolean)
+
+PostgreSQL specific attribute. If true, boolean values will be returned
+as the characters 't' and 'f' instead of '1' and '0'.
+
+=item B<Driver> (handle)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<Name> (string, read-only)
+
+The default DBI method is overridden by a driver specific method that returns
+only the database name. Anything else from the connection string is stripped
+off. Note that, in contrast to the DBI specs, the DBD::Pg implementation fo
+this method is read-only.
+
+=item B<RowCacheSize> (integer)
+
+Implemented by DBI, not used by this driver.
+
+=item B<pg_auto_escape> (boolean)
+
+PostgreSQL specific attribute. If true, then quotes and backslashes in all
+parameters will be escaped in the following way:
+
+ escape quote with a quote (SQL)
+ escape backslash with a backslash
+
+The default is on. Note that PostgreSQL also accepts quotes that are
+escaped by a backslash. Any other ASCII character can be used directly in a
+string constant.
+
+=item B<pg_enable_utf8> (boolean)
+
+PostgreSQL specific attribute. If true, then the C<utf8> flag will be turned
+for returned character data (if the data is valid UTF-8). For details about
+the C<utf8> flag, see L<Encode|Encode>. This attribute only relevant under
+perl 5.8 and later.
+
+B<NB>: This attribute is experimental and may be subject to change.
+
+=item B<pg_INV_READ> (integer, read-only)
+
+Constant to be used for the mode in C<lo_creat> and C<lo_open>.
+
+=item B<pg_INV_WRITE> (integer, read-only)
+
+Constant to be used for the mode in C<lo_creat> and C<lo_open>.
+
+=item B<pg_errorlevel> (integer)
+
+PostgreSQL specific attribute, only works for servers version 7.4 and above.
+Sets the amount of information returned by the server's error messages.
+Valid entries are 0, 1, and 2. Any other number will be forced to the default
+value of 1.
+
+A value of 0 ("TERSE") will show severity, primary text, and position only
+and will usually fit on a single line. A value of 1 ("DEFAULT") will also
+show any detail, hint, or context fields. A value of 2 ("VERBOSE") will
+show all available information.
+
+=item B<pg_protocol> (integer, read-only)
+
+PostgreSQL specific attribute. Returns the version of the PostgreSQL server.
+If DBD::Pg is unable to figure out the version (e.g. it was compiled
+against pre 7.4 libraries), it will return a "0". Otherwise, servers below
+version 7.4 return a "2", and (currently) 7.4 and above return a "3".
+
+=item B<pg_lib_version> (integer, read-only)
+
+PostgreSQL specific attribute. Indicates which version of PostgreSQL that
+DBD::Pg was compiled against. In other words, which libraries were used.
+Returns a number with major, minor, and revision together; version 7.4.2
+would be returned as 70402.
+
+=item B<pg_server_version> (integer, read-only)
+
+PostgreSQL specific attribute. Indicates which version of PostgreSQL that
+the current database handle is connected to. Returns a number with major,
+minor, and revision together; version 8.0.1 would be 80001.
+
+=item B<pg_db> (string, read-only)
+
+PostgreSQL specific attribute. Returns the name of the current database.
+
+=item B<pg_user> (string, read-only)
+
+PostgreSQL specific attribute. Returns the name of the user that
+connected to the server.
+
+=item B<pg_pass> (string, read-only)
+
+PostgreSQL specific attribute. Returns the password used to connect
+to the server.
+
+=item B<pg_host> (string, read-only)
+
+PostgreSQL specific attribute. Returns the host of the current
+server connection. Locally connected hosts will return an empty
+string.
+
+=item B<pg_port> (integer, read-only)
+
+PostgreSQL specific attribute. Returns the port of the connection to
+the server.
+
+=item B<pg_default_port> (integer, read-only)
+
+PostgreSQL specific attribute. Returns the default port used if none is
+specifically givem.
+
+=item B<pg_options> (string, read-only)
+
+PostgreSQL specific attribute. Returns the command-line options passed
+to the server. May be an empty string.
+
+=item B<pg_socket> (number, read-only)
+
+PostgreSQL specific attribute. Returns the file description number of
+the connection socket to the server.
+
+=item B<pg_pid> (number, read-only)
+
+PostgreSQL specific attribute. Returns the process id (PID) of the
+backend server process handling the connection.
+
+=back
+
+=head1 DBI STATEMENT HANDLE OBJECTS
+
+=head2 Statement Handle Methods
+
+=over 4
+
+=item B<bind_param>
+
+ $rv = $sth->bind_param($param_num, $bind_value, \%attr);
+
+Allows the user to bind a value and/or a data type to a placeholder. This is
+especially important when using the new server-side prepare system with
+PostgreSQL 7.4. See the C<prepare()> method for more information.
+
+The value of $param_num is a number if using the '?' or '$1' style
+placeholders. If using ":foo" style placeholders, the complete name
+(e.g. ":foo") must be given. For numeric values, you can either use a
+number or use a literal '$1'. See the examples below.
+
+The $bind_value argument is fairly self-explanatory. A value of C<undef> will
+bind a C<NULL> to the placeholder. Using C<undef> is useful when you want
+to change just the type and will be overwriting the value later.
+(Any value is actually usable, but C<undef> is easy and efficient).
+
+The %attr hash is used to indicate the data type of the placeholder.
+The default value is "varchar". If you need something else, you must
+use one of the values provided by DBI or by DBD::Pg. To use a SQL value,
+modify your "use DBI" statement at the top of your script as follows:
+
+ use DBI qw(:sql_types);
+
+This will import some constants into your script. You can plug those
+directly into the C<bind_param> call. Some common ones that you will
+encounter are:
+
+ SQL_INTEGER
+
+To use PostgreSQL data types, import the list of values like this:
+
+ use DBD::Pg qw(:pg_types);
+
+You can then set the data types by setting the value of the C<pg_type>
+key in the hash passed to C<bind_param>.
+
+Data types are "sticky," in that once a data type is set to a certain placeholder,
+it will remain for that placeholder, unless it is explicitly set to something
+else afterwards. If the statement has already been prepared, and you switch the
+data type to something else, DBD::Pg will re-prepare the statement for you before
+doing the next execute.
+
+Examples:
+
+ use DBI qw(:sql_types);
+ use DBD::Pg qw(:pg_types);
+
+ $SQL = "SELECT id FROM ptable WHERE size > ? AND title = ?";
+ $sth = $dbh->prepare($SQL);
+
+ ## Both arguments below are bound to placeholders as "varchar"
+ $sth->execute(123, "Merk");
+
+ ## Reset the datatype for the first placeholder to an integer
+ $sth->bind_param(1, undef, SQL_INTEGER);
+
+ ## The "undef" bound above is not used, since we supply params to execute
+ $sth->execute(123, "Merk");
+
+ ## Set the first placeholder's value and data type
+ $sth->bind_param(1, 234, { pg_type => PG_TIMESTAMP });
+
+ ## Set the second placeholder's value and data type.
+ ## We don't send a third argument, so the default "varchar" is used
+ $sth->bind_param("$2", "Zool");
+
+ ## We realize that the wrong data type was set above, so we change it:
+ $sth->bind_param("$1", 234, { pg_type => PG_INTEGER });
+
+ ## We also got the wrong value, so we change that as well.
+ ## Because the data type is sticky, we don't need to change it
+ $sth->bind_param(1, 567);
+
+ ## This executes the statement with 567 (integer) and "Zool" (varchar)
+ $sth->execute();
+
+=item B<bind_param_inout>
+
+Currently not supported by this driver.
+
+=item B<execute>
+
+ $rv = $sth->execute(@bind_values);
+
+Executes a previously prepared statement. In addition to C<UPDATE>, C<DELETE>,
+C<INSERT> statements, for which it returns always the number of affected rows,
+the C<execute> method can also be used for C<SELECT ... INTO table> statements.
+
+The "prepare/bind/execute" process has changed significantly for PostgreSQL
+servers 7.4 and later: please see the C<prepare()> and C<bind_param()> 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.
+
+=item B<fetchrow_arrayref>
+
+ $ary_ref = $sth->fetchrow_arrayref;
+
+Supported by this driver as proposed by DBI.
+
+=item B<fetchrow_array>
+
+ @ary = $sth->fetchrow_array;
+
+Supported by this driver as proposed by DBI.
+
+=item B<fetchrow_hashref>
+
+ $hash_ref = $sth->fetchrow_hashref;
+
+Supported by this driver as proposed by DBI.
+
+=item B<fetchall_arrayref>
+
+ $tbl_ary_ref = $sth->fetchall_arrayref;
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<finish>
+
+ $rc = $sth->finish;
+
+Supported by this driver as proposed by DBI.
+
+=item B<rows>
+
+ $rv = $sth->rows;
+
+Supported by this driver as proposed by DBI. In contrast to many other drivers
+the number of rows is available immediately after executing the statement.
+
+=item B<bind_col>
+
+ $rc = $sth->bind_col($column_number, \$var_to_bind, \%attr);
+
+Supported by this driver as proposed by DBI.
+
+=item B<bind_columns>
+
+ $rc = $sth->bind_columns(\%attr, @list_of_refs_to_vars_to_bind);
+
+Supported by this driver as proposed by DBI.
+
+=item B<dump_results>
+
+ $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<blob_read>
+
+ $blob = $sth->blob_read($id, $offset, $len);
+
+Supported by this driver as proposed by DBI. Implemented by DBI but not
+documented, 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<blob_read> 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 driver fetches the whole blob at once.
+
+Starting with PostgreSQL 6.5, every access to a blob has to be put into a
+transaction. This holds even for a read-only access.
+
+See also the PostgreSQL-specific functions concerning blobs, which are
+available via the C<func> interface.
+
+For further information and examples about blobs, please read the chapter
+about Large Objects in the PostgreSQL Programmer's Guide at
+L<http://www.postgresql.org/docs/current/static/largeobjects.html>.
+
+=back
+
+=head2 Statement Handle Attributes
+
+=over 4
+
+=item B<NUM_OF_FIELDS> (integer, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<NUM_OF_PARAMS> (integer, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<NAME> (array-ref, read-only)
+
+Supported by this driver as proposed by DBI.
+
+=item B<NAME_lc> (array-ref, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<NAME_uc> (array-ref, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<NAME_hash> (hash-ref, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<NAME_lc_hash> (hash-ref, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<NAME_uc_hash> (hash-ref, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<TYPE> (array-ref, read-only)
+
+Supported by this driver as proposed by DBI
+
+=item B<PRECISION> (array-ref, read-only)
+
+Supported by this driver. C<NUMERIC> types will return the precision. Types of
+C<CHAR> and C<VARCHAR> will return their size (number of characters). Other
+types will return the number of I<bytes>.
+
+=item B<SCALE> (array-ref, read-only)
+
+Supported by this driver as proposed by DBI. The only type
+that will return a value currently is C<NUMERIC>.
+
+=item B<NULLABLE> (array-ref, read-only)
+
+Supported by this driver as proposed by DBI. This is only available for
+servers version 7.3 and later. Others will return "2" for all columns.
+
+=item B<CursorName> (string, read-only)
+
+Not supported by this driver. See the note about B<Cursors> elsewhere in this
+document.
+
+=item C<Database> (dbh, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item C<ParamValues> (hash ref, read-only)
+
+Supported by this driver as proposed by DBI. If called before C<execute>, the
+literal values passed in are returned. If called after C<execute>, then
+the quoted versions of the values are shown.
+
+=item B<Statement> (string, read-only)
+
+Supported by this driver as proposed by DBI.
+
+=item B<RowCache> (integer, read-only)
+
+Not supported by this driver.
+
+=item B<pg_size> (array-ref, read-only)
+
+PostgreSQL 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.
+
+=item B<pg_type> (array-ref, read-only)
+
+PostgreSQL specific attribute. It returns a reference to an array of strings
+for each column. The string shows the name of the data_type.
+
+=item B<pg_oid_status> (integer, read-only)
+
+PostgreSQL specific attribute. It returns the OID of the last INSERT command.
+
+=item B<pg_cmd_status> (integer, read-only)
+
+PostgreSQL specific attribute. It returns the type of the last
+command. Possible types are: "INSERT", "DELETE", "UPDATE", "SELECT".
+
+=back
+
+=head1 FURTHER INFORMATION
+
+=head2 Transactions
+
+Transaction behavior is controlled via the C<AutoCommit> attribute. For a
+complete definition of C<AutoCommit> please refer to the DBI documentation.
+
+According to the DBI specification the default for C<AutoCommit> is a true
+value. In this mode, any change to the database becomes valid immediately. Any
+C<BEGIN>, C<COMMIT> or C<ROLLBACK> statements will be rejected. DBD::Pg
+implements C<AutoCommit> by issuing a C<BEGIN> statement immediately before
+executing a statement, and a C<COMMIT> afterwards.
+
+=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:
+
+=over 4
+
+=item B<pg_savepoint>
+
+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");
+
+=item B<pg_rollback_to>
+
+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");
+
+=item B<pg_release>
+
+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");
+
+=back
+
+=head2 COPY support
+
+DBD::Pg supports the COPY command through three functions: pg_putline,
+pg_getline, and pg_endcopy. The COPY command allows data to be quickly
+loaded or read from a table. The basic process is to issue a COPY
+command via $dbh->do(), do either $dbh->pg_putline or $dbh->pg_getline,
+and then issue a $dbh->pg_endcopy (for pg_putline only).
+
+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 do() method.
+For example:
+
+ $dbh->do("COPY foobar FROM STDIN");
+
+This would tell the server to enter a COPY IN state. It is now ready to
+receive information via the pg_putline method. The complete syntax of the
+COPY command is more complex and not documented here: the canonical
+PostgreSQL documentation for COPY be found at:
+
+http://www.postgresql.org/docs/current/static/sql-copy.html
+
+Note that 7.2 servers can only accept a small subset of later features in
+the COPY command: most notably they do not accept column specifications.
+
+Once the COPY command has been issued, no other SQL commands are allowed
+until after pg_endcopy has been successfully called. If in a COPY IN state,
+you cannot use pg_getline, and if in COPY OUT state, you cannot use pg_putline.
+
+=over 4
+
+=item B<pg_putline>
+
+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. The default delimiter is a tab character, but this can be changed in
+the COPY statement. Returns a 1 on sucessful input. Examples:
+
+ $dbh->do("COPY mytable FROM STDIN");
+ $dbh->pg_putline("123\tPepperoni\t3\n");
+ $dbh->pg_putline("314\tMushroom\t8\n");
+ $dbh->pg_putline("6\tAnchovies\t100\n");
+ $dbh->pg_endcopy;
+
+ ## This example uses explicit columns and a custom delimiter
+ $dbh->do("COPY mytable(flavor, slices) FROM STDIN WITH DELIMITER '~'");
+ $dbh->pg_putline("Pepperoni~123\n");
+ $dbh->pg_putline("Mushroom~314\n");
+ $dbh->pg_putline("Anchovies~6\n");
+ $dbh->pg_endcopy;
+
+=item B<pg_getline>
+
+Used to retrieve data from a table after the server has been put into COPY OUT
+mode by calling "COPY tablename TO STDOUT". The first argument to pg_getline is
+the variable into which the data will be stored. The second argument is the size
+of the variable: this should be greater than the expected size of the row. Returns
+a 1 on success, and an empty string when the last row has been fetched. Example:
+
+ $dbh->do("COPY mytable TO STDOUT");
+ my @data;
+ my $x=0;
+ 1 while($dbh->pg_getline($data[$x++], 100));
+ pop @data; ## Remove final "\\.\n" line
+
+If DBD::Pg is compiled with pre-7.4 libraries, this function will not work: you
+will have to use the old $dbh->func($data, 100, 'getline') command, and call
+pg_getline manually. Users are highly encouraged to upgrade to a newer version
+of PostgreSQL if this is the case.
+
+=item B<pg_endcopy>
+
+When done with pg_putline, call pg_endcopy to put the server back in
+a normal state. Returns a 1 on success. This method will fail if called when not
+in a COPY IN or COPY OUT state. Note that you no longer need to send "\\.\n" when
+in COPY IN mode: pg_endcopy will do this for you automatically as needed.
+pg_endcopy is only needed after getline if you are using the old-style method,
+$dbh->func($data, 100, 'getline').
+
+
+=back
+
+=head2 Large Objects
+
+This driver supports all largeobject functions provided by libpq via the
+C<func> method. Please note that, starting with PostgreSQL 6.5, any access to
+a large object -- even read-only large objects -- must be put into a
+transaction!
+
+=head2 Cursors
+
+Although PostgreSQL has a cursor concept, it has not been used in the current
+implementation. Cursors in PostgreSQL can 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<SELECT> statements. Hence
+the C<execute> method fetches all data at once into data structures located in
+the front-end application. This approach must to be considered when selecting
+large amounts of data!
+
+=head2 Datatype bool
+
+The current implementation of PostgreSQL returns 't' for true and 'f' for
+false. From the Perl point of view, this is a rather unfortunate
+choice. DBD::Pg therefore translates the result for the C<BOOL> data type in a
+Perlish manner: 'f' -> '0' and 't' -> '1'. This way the application does
+not have to check the database-specific returned values for the data-type
+C<BOOL> because Perl treats '0' as false and '1' as true. You may set the
+C<pg_bool_tf> attribute to a true value to change the values back to 't' and
+'f' if you wish.
+
+Boolean values can be passed to PostgreSQL as TRUE, 't', 'true', 'y', 'yes' or
+'1' for true and FALSE, 'f', 'false', 'n', 'no' or '0' for false.
+
+=head2 Schema support
+
+PostgreSQL version 7.3 introduced schema support. Note that the PostgreSQL
+schema concept may differ from those of other databases. In a nutshell, a schema
+is a named collection of objects within a single database. Please refer to the
+PostgreSQL documentation for more details.
+
+Currently, DBD::Pg does not provide explicit support for PostgreSQL schemas.
+However, schema functionality may be used without any restrictions by
+explicitly addressing schema objects, e.g.
+
+ my $res = $dbh->selectall_arrayref("SELECT * FROM my_schema.my_table");
+
+or by manipulating the schema search path with C<SET search_path>, e.g.
+
+ $dbh->do("SET search_path TO my_schema, public");
+
+=head1 SEE ALSO
+
+L<DBI>
+
+=head1 AUTHORS
+
+DBI and DBD-Oracle by Tim Bunce (Tim.Bunce at ig.co.uk)
+
+DBD-Pg by Edmund Mergl (E.Mergl at bawue.de) and Jeffrey W. Baker
+(jwbaker at acm.org). By David Wheeler <david at justatheory.com>, Jason
+Stewart <jason at openinformatics.com>, Bruce Momjian <pgman at candle.pha.pa.us>,
+Greg Sabino Mullane <greg at turnstep.com>, and others after v1.13.
+
+Parts of this package have been copied from DBI and DBD-Oracle.
+
+B<Mailing List>
+
+The current maintainers may be reached through the 'dbdpg-general' mailing
+list: L<http://gborg.postgresql.org/mailman/listinfo/dbdpg-general/>.
+
+This list is available through Gmane (L<http://www.gmane.org/>) as a newsgroup
+with the name: C<gmane.comp.db.postgresql.dbdpg>
+
+B<Bug Reports>
+
+If you feel certain you have found a bug, you can report it by sending
+an email to <bug-dbd-pg at rt.cpan.org>.
+
+=head1 COPYRIGHT
+
+The DBD::Pg module is free software. You may distribute under the terms of
+either the GNU General Public License or the Artistic License, as specified in
+the Perl README file.
+
+=head1 ACKNOWLEDGMENTS
+
+See also B<DBI/ACKNOWLEDGMENTS>.
+
+=cut
+
Added: packages/libdbd-pg-perl/branches/upstream/current/Pg.xs
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/Pg.xs 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/Pg.xs 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,469 @@
+/*
+ $Id: Pg.xs,v 1.48 2006/01/30 03:12:50 turnstep Exp $
+
+ Copyright (c) 2000-2006 PostgreSQL Global Development Group
+ 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
+
+DBISTATE_DECLARE;
+
+MODULE = DBD::Pg PACKAGE = DBD::Pg
+
+
+I32
+constant(name=Nullch)
+ char *name
+ PROTOTYPE:
+ ALIAS:
+ PG_BOOL = 16
+ PG_BYTEA = 17
+ PG_CHAR = 18
+ PG_INT8 = 20
+ PG_INT2 = 21
+ PG_INT4 = 23
+ PG_TEXT = 25
+ PG_OID = 26
+ PG_FLOAT4 = 700
+ PG_FLOAT8 = 701
+ PG_ABSTIME = 702
+ PG_RELTIME = 703
+ PG_TINTERVAL = 704
+ PG_BPCHAR = 1042
+ PG_VARCHAR = 1043
+ PG_DATE = 1082
+ PG_TIME = 1083
+ PG_DATETIME = 1184
+ PG_TIMESPAN = 1186
+ PG_TIMESTAMP = 1296
+ 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* to_quote_sv
+ SV* type_sv
+
+ CODE:
+ {
+ sql_type_info_t *type_info;
+ char *to_quote;
+ char *quoted;
+ STRLEN len=0;
+ STRLEN retlen=0;
+ SV **svp;
+
+ SvGETMAGIC(to_quote_sv);
+
+ /* Null is always returned as "NULL", so we can ignore any type given */
+ if (!SvOK(to_quote_sv)) {
+ RETVAL = newSVpvn("NULL", 4);
+ }
+ else {
+
+ /* If no valid type is given, we default to varchar */
+ if (!type_sv || !SvOK(type_sv)) {
+ type_info = pg_type_data(VARCHAROID);
+ }
+ else {
+ if SvMAGICAL(type_sv)
+ (void)mg_get(type_sv);
+ if (SvNIOK(type_sv)) {
+ type_info = sql_type_data(SvIV(type_sv));
+ }
+ else {
+ 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 VARCHAR",SvIV(type_sv));
+ type_info = pg_type_data(VARCHAROID);
+ }
+ }
+
+ /* 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);
+ RETVAL = newSVpvn(quoted, retlen);
+ if (SvUTF8(to_quote_sv))
+ 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") ? &sv_no : newSVpv(imp_dbh->sqlstate, 5);
+
+
+void do(dbh, statement, attr=Nullsv, ...)
+ SV * dbh
+ char * statement
+ SV * attr
+ PROTOTYPE: $$;$@
+ CODE:
+ {
+ int retval;
+
+ if (strlen(statement)<1) { /* Corner case */
+ XST_mUNDEF(0);
+ return;
+ }
+
+ if (items < 3) { /* No attribs, no arguments */
+ /* Quick run via PQexec */
+ retval = pg_quickexec(dbh, statement);
+ }
+ else { /* The normal, slower way */
+ imp_sth_t *imp_sth;
+ SV * sth = dbixst_bounce_method("prepare", 3);
+ if (!SvROK(sth))
+ XSRETURN_UNDEF;
+ imp_sth = (imp_sth_t*)(DBIh_COM(sth));
+ if (items > 3)
+ if (!dbdxst_bind_params(sth, imp_sth, items-2, ax+2))
+ XSRETURN_UNDEF;
+ imp_sth->server_prepare = 1;
+ imp_sth->onetime = 1; /* Overrides the above at actual PQexec* decision time */
+ 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 = dbd_db_getfd(dbh, imp_dbh);
+ ST(0) = sv_2mortal( newSViv( ret ) );
+
+
+void
+pg_endcopy(dbh)
+ SV * dbh
+ CODE:
+ ST(0) = (pg_db_endcopy(dbh)!=0) ? &sv_no : &sv_yes;
+
+
+void
+pg_notifies(dbh)
+ SV * dbh
+ CODE:
+ D_imp_dbh(dbh);
+ ST(0) = dbd_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) ? &sv_yes : &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) ? &sv_yes : &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) ? &sv_yes : &sv_no;
+
+
+void
+lo_open(dbh, lobjId, mode)
+ SV * dbh
+ unsigned int lobjId
+ int mode
+ CODE:
+ int ret = pg_db_lo_open(dbh, lobjId, mode);
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_close(dbh, fd)
+ SV * dbh
+ int fd
+ CODE:
+ ST(0) = (-1 != pg_db_lo_close(dbh, fd)) ? &sv_yes : &sv_no;
+
+
+void
+lo_read(dbh, fd, buf, len)
+ SV * dbh
+ int fd
+ char * buf
+ size_t len
+ PREINIT:
+ SV *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) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_write(dbh, fd, buf, len)
+ SV * dbh
+ int fd
+ char * buf
+ size_t len
+ CODE:
+ int ret = pg_db_lo_write(dbh, fd, buf, len);
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_lseek(dbh, fd, offset, whence)
+ SV * dbh
+ int fd
+ int offset
+ int whence
+ CODE:
+ int ret = pg_db_lo_lseek(dbh, fd, offset, whence);
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_creat(dbh, mode)
+ SV * dbh
+ int mode
+ CODE:
+ int ret = pg_db_lo_creat(dbh, mode);
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_tell(dbh, fd)
+ SV * dbh
+ int fd
+ CODE:
+ int ret = pg_db_lo_tell(dbh, fd);
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_unlink(dbh, lobjId)
+ SV * dbh
+ unsigned int lobjId
+ CODE:
+ ST(0) = (-1 != pg_db_lo_unlink(dbh, lobjId)) ? &sv_yes : &sv_no;
+
+
+void
+lo_import(dbh, filename)
+ SV * dbh
+ char * filename
+ CODE:
+ int ret = pg_db_lo_import(dbh, filename);
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv((int)ret)) : &sv_undef;
+
+void
+lo_export(dbh, lobjId, filename)
+ SV * dbh
+ unsigned int lobjId
+ char * filename
+ CODE:
+ ST(0) = (-1 != pg_db_lo_export(dbh, lobjId, filename)) ? &sv_yes : &sv_no;
+
+
+void
+pg_putline(dbh, buf)
+ SV * dbh
+ char * buf
+ CODE:
+ ST(0) = (pg_db_putline(dbh, buf)!=0) ? &sv_no : &sv_yes;
+
+
+void
+putline(dbh, buf)
+ SV * dbh
+ char * buf
+ CODE:
+ ST(0) = (pg_db_putline(dbh, buf)!=0) ? &sv_no : &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, buf, (int)len);
+ sv_setpv((SV*)ST(1), buf);
+ SvSETMAGIC(ST(1));
+ ST(0) = (-1 != ret) ? &sv_yes : &sv_no;
+
+
+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, buf, (int)len);
+ sv_setpv((SV*)ST(1), buf);
+ SvSETMAGIC(ST(1));
+ ST(0) = (-1 != ret) ? &sv_yes : &sv_no;
+
+void
+endcopy(dbh)
+ SV * dbh
+ CODE:
+ ST(0) = (-1 != pg_db_endcopy(dbh)) ? &sv_yes : &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;
+ sql_type_info_t *type_info;
+
+ if (type_sv && SvOK(type_sv)) {
+ 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 ) );
+ }
+
+# -- 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") ? &sv_no : newSVpv(imp_dbh->sqlstate, 5);
+
+# end of Pg.xs
Added: packages/libdbd-pg-perl/branches/upstream/current/README
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/README 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/README 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,276 @@
+
+DBD::Pg -- the DBI PostgreSQL interface for Perl
+
+# $Id: README,v 1.49 2006/02/26 19:04:23 turnstep Exp $
+
+DESCRIPTION:
+------------
+
+This is version 1.45 of DBD-Pg. The web site for this interface is at:
+
+ http://gborg.postgresql.org/project/dbdpg/projdisplay.php
+
+For further information about DBI look at:
+
+ http://dbi.perl.org/
+
+For information about PostgreSQL, visit:
+
+ http://www.postgresql.org/
+
+
+COPYRIGHT:
+----------
+
+ Copyright (c) 2002-2006 PostgreSQL Global Development Group
+ 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.
+
+
+HOW TO GET THE LATEST VERSION:
+------------------------------
+
+Use the following URL to look for new versions of this module:
+
+http://search.cpan.org/~dbdpg/
+
+
+IF YOU HAVE PROBLEMS OR COMMENTS:
+---------------------------------
+
+Please send any problems and comments to
+<dbdpg-general at gborg.postgresql.org>
+
+Please include details about your platform, and your version of
+perl, PostgreSQL, DBI, and DBD-PG in your bug report.
+
+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.
+
+
+REQUIREMENTS:
+-------------
+
+ build, test, and install Perl 5 (at least 5.6.1)
+ build, test, and install the DBI module (at least 1.38)
+ build, test, and install PostgreSQL (at least 7.2)
+ build, test, and install Test::Simple (at least 0.30)
+
+You must also have the pg_config executable installed (to check, type
+"which pg_config" on unix-like systems). If pg_config is not available,
+then you need to install the development package for PostgreSQL. For example
+on Debian: apt-get install postgresql-dev; on RedHat: yum postgresql-devel.
+This development package is needed even if you already have PostgreSQL up
+and running since DBD::Pg uses it for its installation.
+
+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" to it, like this:
+
+ export POSTGRES_LIB="/usr/local/pgsql/lib -lssl"
+
+Now, take 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!
+
+
+TESTING:
+--------
+
+The tests are designed to connect to a live database. The following
+environment variables must be set for the tests to run:
+
+ DBI_DSN=dbi:Pg:dbname=<database>
+ DBI_USER=<username>
+ DBI_PASS=<password>
+
+If you are running on a non-standard port, you must add it
+to the DBI_DSN variable like this:
+
+ DBI_DSN='dbi:Pg:dbname=<database>;port=<port#>'
+
+Put double quotes around the dbname if it has a semicolon
+or a space inside of it:
+
+ DBI_DSN='dbi:Pg:dbname="<data;base>"'
+
+The tests assume that a schema named "public" is available for
+7.3 and greater servers. To override this, set the environment
+variable DBD_SCHEMA to a valid schema before testing.
+
+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, do *not*
+set DBD_TRACE unless requested, and send only the relevant sections.
+
+
+TROUBLESHOOTING:
+----------------
+
+* PostgreSQL library issues:
+
+If you are using the shared library libpq.so check if your dynamic
+loader finds libpq.so. With Linux the command /sbin/ldconfig -v should
+tell you where it finds libpq.so. If ldconfig does not find libpq.so,
+either add an appropriate entry to /etc/ld.so.conf and re-run ldconfig
+or add the path to the environment variable LD_LIBRARY_PATH.
+
+A typical error message resulting from not finding libpq.so is:
+
+ install_driver(Pg) failed: Can't load './blib/arch/auto/DBD/Pg/Pg.so'
+ for module DBD::Pg: File not found at
+
+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? Check the setting of POSTGRES_LIB and
+recompile DBD-Pg.
+
+
+* 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 <peter_e at gmx.net>)
+
+
+* 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" <drnoble at engsci.sandia.gov>)
+
+
+* 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 <danla at dimensional.com>)
+
+
+* 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
+ (eg 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 <rob at cabrion dot com>)
+
+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 <david at landgren dot net>)
+
+
+* 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 <jmore at remote-print.com>)
+
Added: packages/libdbd-pg-perl/branches/upstream/current/README.dev
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/README.dev 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/README.dev 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,820 @@
+
+## $Id: README.dev,v 1.23 2006/02/06 03:06:09 turnstep Exp $
+
+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).
+
+
+===============
+== 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 is one of four files that lists
+ the version number.
+
+README.win32 - the directions on how to install DBD::Pg on a Win32 box.
+
+TODO - Rough list of upcoming tasks.
+
+
+* Build files:
+
+Makefile.PL - The main file that starts everything off. Used by ExtUtils::MakeMaker
+ to create the "Makefile"
+
+Makefile - Generated automatically by Makefile.PL
+
+META.yml - Generated with "make distdir"
+
+* 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 distcheck" command
+
+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 - Helper file for dbdimp.c.
+
+Pg.pm - The main perl file, which contains all the 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 - Helper file for Pg.xs (or Pg.c)
+
+quote.c - Various methods to help quote and dequote variables. Much of this is
+ now done on the backend, but it is still needed to support older versions
+ of PostgreSQL.
+
+quote.h - Helper file for quote.c
+
+types.c - Lists all known data types for PostgreSQL.
+ Run as a perl script to check for new types.
+
+types.h - Helper file for types.c
+
+* Test files:
+
+t/00basic.t - Very basic test to see if DBI and DBD::Pg load properly.
+
+t/01connect.t - Basic connection tests, outputs detailed connection information.
+
+t/01constants.t - Quick test of pg_types.
+
+t/01setup.t - Create the database items needed by the other tests.
+
+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 - Currently only tests the "data_sources" method.
+
+t/05arrays.t - Currently skipped until arrays are enabled.
+
+t/06bytea.t - Tests bytea manipulation.
+
+t/07copy.t - Tests COPY-related methods.
+
+t/12placeholders.t - Tests placeholders.
+
+t/20savepoints.t - Test savepoints. Requires a server version 8.0 or up.
+
+t/99_pod.t - Verifies the POD of Pg.pm. Requires Test::POD version 0.95, and
+ Test::Pod::Coverage 1.04. Neither are mandatory for normal testing, but
+ developers are highly encouraged to install them.
+
+t/99cleanup.t - Removes anything we have created for the tests (e.g. tables)
+
+
+* 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"; ## Not terribly useful
+$comp_opts .= " -Wnested-externs"; ## Does not like Perl__notused (from DBIXS;)
+
+## These options produce a few hits, but are still pretty useful:
+$comp_opts .= " -Wswitch-default"; ## Complains on any Newz declaration
+$comp_opts .= " -Wfloat-equal"; ## Some perl stuff we cannot catch from Pg.h -> DBIXS.h -> perl.h -> math.h -> bits/mathinline.h
+$comp_opts .= " -Wstrict-prototypes"; ## Still hits a couple places in types.h that need fixing (then move to above)
+$comp_opts .= " -Wmissing-noreturn"; ## Raises a few warnings for <=7.4 libraries, as we croak on purpose for some
+
+## These options tend to produce lots of hits outside of our code, but may still be useful:
+$comp_opts .= " -Wsystem-headers"; ## when used with -Wconversion, creates a lot of hits
+$comp_opts .= " -pedantic"; ## Useful, but very verbose
+$comp_opts .= " -Wundef"; ## Filter: grep warning wfile | grep -v unions | grep -v CORE | grep -v Pg.c | grep -v auto
+$comp_opts .= " -Wshadow"; ## lots of bogus hits - not very useful Filter: grep warning wfile | grep -v "/usr"
+$comp_opts .= " -Wwrite-strings";
+$comp_opts .= " -Wpadded"; ## Use when adding/changing our structs
+$comp_opts .= " -Wredundant-decls";
+
+## 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.
+
+
+===================
+== 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 versions. You should generally test each minor 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 dbd727='export DBI_DSN="dbi:Pg:dbname=greg;port=5727"'
+alias dbd727m='export POSTGRES_LIB=/home/greg/pg727/lib POSTGRES_INCLUDE=/home/greg/pg727/include POSTGRES_DATA=/home/greg/pg727'
+
+This allows for quick testing of each combination:
+
+> dbd727m
+> dbd727
+> perl Makefile.PL
+> make test (check output for any errors)
+> dbd739
+> make test
+> dbd747
+> make test
+> dbd747
+> make test
+> dbd802
+> make test
+> dbd739m
+> perl Makefile.PL
+> make test
+> dbd727
+> make test
+> dbd747
+> make test
+> dbd802
+> make test
+
+etc...
+
+It's also a good idea to test the current cvs version of pg in your tests: this can detect
+changes nice and early.
+
+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 dbi138='export PERL5LIB=/home/greg/perl/dbi138/lib/perl5/site_perl/5.8.7/i686-linux'
+alias dbi139='export PERL5LIB=/home/greg/perl/dbi139/lib/perl5/site_perl/5.8.7/i686-linux'
+
+
+* 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.
+It will not work out of the box, as our dependencies tend to be scattered about. Here is a minimal
+file that should work:
+
+splint \
++unixlib \
++single-include \
+-I$DBIDIR \
+-I$POSTGRES_INCLUDE \
+-I$PERLDIR \
+-I/source/bin/DBI-1.48 \
+-I/source/pg801/include \
+-I/usr/lib/perl5/5.8.5/i686-linux-ld/CORE \
+Pg.c
+
+You will need to define the environment variables and put the correct path to the DBI,
+Postgres, and Perl directories (the Perl one should end in "CORE"). Splint can be
+tempermental, so you may need to add more than that, and tweak a few things. It may
+take a few runs to get it to go without errors. Once you do get it running, it is very
+thorough and extremely verbose. Many of the items will be from DBI, so hunt carefully.
+You can start filtering out items you do not need to check. Here are a few common ones:
+
+-nullpass \
+-predboolint \
++charint \
++charintliteral \
+-nullderef \
+-branchstate \
+-mustfreeonly \
+-mustfreefresh \
+-boolops \
+-type \
+-observertrans \
+-globstate \
+-nullstate \
+-compdef \
+-onlytrans \
+-realcompare \
+-nullret \
+-bufferoverflowhigh \
+
+Note that most, if not all, of the above, *should* be checked on the first pass, and then
+gradually added to make the output easier to read.
+
+
+* 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.
+
+
+
+===============
+== 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, 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.
+
+* If someone files a bug report that is not revealed by a test, please add one in,
+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. The only exception is that most of them
+will need 01setup.t to be run first, to create the testing table. However, once this
+has been run, and before 99cleanup.t has been run, each test file should run flawlessly
+multiple times. Tests should remove any objects they create at the end of the script,
+and should be able to silently recreate objects as needed (see 07copy.t for an example).
+Objects should be created as "temporary" whenever possible.
+
+* 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).
+
+
+=====================
+== Version Numbers ==
+=====================
+
+Version numbers are constrained by the Perl CPAN system, in which there is a major
+and a minor number. Generally, we increment the minor version by one for each new
+release. More major releases can bump up to the next "tens" place, e.g. from 1.33
+to 1.40. Very major releases can bump the major number, but this should be an
+extremely rare event. When in doubt, ask on the list. Any bump other than a single
+increment should always be discussed there first anyways.
+
+Beta versions are simply the number *before* the new anticipated number, plus an
+underscore to indicate the beta version. For example, if the current version is
+1.41 and you are making betas for an upcoming 1.42 version, you should name the
+beta version as 1.41_1. A second beta would be 1.41_2, etc.
+
+Version numbers are currently set in four files:
+
+README
+Pg.pm (two places!)
+Changes
+Makefile.PL
+
+In addition, you may want to change META.yml, but this should be done automatically:
+see the ** Making a New Release section.
+
+
+===============
+== 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 cvs via 'cvs add filename' and 'cvs commit filename'
+
+* Added it to the MANIFEST file
+
+* Added to Makefile.PL if needed, to make sure all build dependencies are met
+
+* Updated/created necessary tests for it
+
+
+=================
+== 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)
+
+* Make sure everything is up to date in cvs
+
+* Update the versions (see ** Version Numbers) in README, Pg.pm (2 places!), Makefile.PL, and Changes
+
+* 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 (1.43_2) AND SHOULD BE USED
+FOR TESTING PURPOSED ONLY. PLEASE USE A STABLE
+VERSION (no underscore) BY VISITING:
+
+http://search.cpan.org/~dbdpg/
+===================================================
+
+* If not a beta version, remove the warning from the README.
+
+* Update the Changes file
+
+The best way to do this (other than doing it as you go along) is to check the cvs logs.
+For example, to grab all changes made since revision 1.43 and save it to a file:
+
+cvs log -rRel-1_43: * > all_logs.tmp
+
+* 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. You can do this to test:
+
+prove -v t/99_pod.t
+
+* Run "perl Makefile.PL"
+
+* Run "make distdir" and commit the new META.yml file that is created, if different.
+
+* 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.
+
+* 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. "make realclean"
+
+* Now that everything works, set a symbolic name for this version.
+Remember to use underscores (see the ** Version Numbers section)
+
+For example, to tag all of the current file as the first beta of 1.43, use:
+
+cvs rtag Rel-1_42_1 dbdpg
+
+If you ever need to remove a symbolic tag, you can use:
+
+cvs admin -nRel-1_42_1 filename
+
+To add a symbolic tag to a particular version of a file use:
+
+cvs admin -nRel-1_42_1:1.19 filename
+
+To add a symbolic tag to the latest version of a file use:
+
+cvs admin -nRel-1_42_1: filename
+
+To reposition a symbolic tag to the latest version of a file use:
+
+cvs admin -NRel-1_42_1: filename
+
+* Make checksums
+
+Generate md5 and sha1 checksums of the tarball. Include this in your emails.
+
+* Update the SIGNATURE file with Module::Signature
+
+* Test it out
+
+Download the tarball to a completely different system, unpack and test it.
+
+* Announce to the "internal" lists
+
+dbdpg-general
+pgsql-interfaces
+
+* 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.
+
+* Announce to the "public" lists
+
+dbdpg-general
+pgsql-interfaces
+dbi-users, dbi-dev, dbi-announce
+
+The format for DBI announcements:
+To: dbi-announce at perl.org
+Cc: dbi-users at perl.org
+Reply-to: dbi-users at perl.org
+
+Subject line: Name of module, version
+
+Short note of changes, link to CPAN directory.
+
+Checksums for the file.
+
+* Post to pgsql-announce 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/
+
+* 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.
+
+* Update this file based on your experiences!!
+
+* Wait for the bugs or accolades to pour in.
+
+
+=====================
+== 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.
+
+* To change a cvs comment, use the "cvs admin" command, a dash m, the version number,
+a colon, and the new text, then the file name. Example:
+
+cvs admin -m1.118:"Memory leak patch by hertzog at debian.org" dbdimp.c
+
+* Temporary tables
+
+We do not use temporary tables in most of our test because they are
+not persistent across tests, they mess up the schema testing, and they
+are compatible with the foreign key testing. But do try and use them
+whenever possible.
+
+* "turnstep" in the cvs logs is Greg Sabino Mullane, greg at 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 "cvs up". 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 dbdpg-general mailing list, where the developers live. Other
+resources depend on the subject:
+
+* DBD::Pg
+
+The canonical URL:
+http://search.cpan.org/~dbdpg/DBD-Pg-1.41/
+
+* 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/~timb/DBI/
+
+The source code of other DBDs can be a useful tool as well. In other words, the "competition" :)
+
+* PostgreSQL
+
+A good source for general questions on libpq and similar things is the pgsql-interfaces list. Another
+good source for more generic questions (and perhaps better for all questions, as it tends to be more
+active) is the pgsql-hackers list. Having a copy of the source code is invaluable as well. Using a
+tool like glimpse is handy to find those obscure libpq functions quickly. You also may want to keep
+the libpq documentation handy.
+
+All PG 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.
+
+
+* 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;
+
+
+Othjer important modules:
+
+perldoc Devel::Cover;
+perldoc Module::Signature;
+
+
+This is a guide for DBD authors. It's fairly old and incomplete however, but listed here for
+completeness:
+
+perldoc DBI::DBD
+
+
+A handy module to know about:
+
+perldoc DBI::Profile
+
Added: packages/libdbd-pg-perl/branches/upstream/current/README.win32
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/README.win32 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/README.win32 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,97 @@
+
+How to get a working DBD::Pg on Windows
+
+Start with:
+MS VC++.Net Standard Edition
+MS VC++ Toolkit 2003
+Latest PostgreSQL (e.g. postgresql-8.00.rc2.tar.gz)
+Latest Perl (e.g. perl-5.8.6.tar.gz)
+Latest DBI (e.g. DBI-1.46.tar.gz)
+Latest DBD::Pg (1.40 or higher)
+Custom "win32.mak" file (included with DBD::Pg)
+
+Unpack the .tar.gz files in c:\tmp
+
+Save win32.mak as src\bin\pg_config\win32.mak in postgres tree.
+
+1. In Windows command window, set up to compile:
+
+set PATH=C:\Program Files\Microsoft Visual Studio .NET 2003\Vc7\bin;%PATH%
+set PATH=C:\Program Files\Microsoft Visual C++ Toolkit 2003\bin;%PATH%
+vcvars32
+
+2. Run win32 make for postgresql:
+
+cd \tmp\postgresql-8.0.0rc2\src
+nmake -f win32.mak
+
+3. Make pg_config.exe (not part of standard MSVC build), and copy it out:
+
+cd bin\pg_config
+nmake -f win32.mak
+copy Release\pg_config.exe \tmp\DBD-Pg-1.42
+
+4. Install lib and include to some permanent location like this:
+
+mkdir c:\postgres
+mkdir c:\postgres\lib
+mkdir c:\postgres\include
+cd ..\..\interfaces\libpq\Release
+copy libpq* c:\postgres\lib
+cd ..\..\..
+xcopy /s include c:\postgres\include
+xcopy \tmp\postgresql-8.0.3\src\interfaces\libpq\libpg-fe.h c:\postgres\include
+
+
+5. Make a non-threaded perl, like this:
+
+cd \tmp\perl-5.8.6\win32
+
+in Makefile,
+.. change the install location thus:
+ INST_TOP = $(INST_DRV)\myperl
+.. comment out the following lines
+ USE_MULTI = define
+ USE_ITHREADS = define
+ USE_IMP_SYS = define
+.. change both instances of deprecated '-Gf' flag to '-GF'
+
+then just run:
+
+nmake
+nmake test
+nmake install
+
+5. Add new perl to path:
+
+set PATH=c:\myperl\bin;%PATH%
+
+6. Make and install DBI:
+
+cd \tmp\DBI-1.46
+perl Makefile.PL
+nmake
+nmake test
+nmake install
+
+7. Set up environment for DBD::Pg:
+
+set POSTGRES_LIB=c:\postgres\lib
+set POSTGRES_INCLUDE=c:\postgres\include
+
+8. Build DBD::Pg:
+
+cd \tmp\DBD-Pg1.42
+perl Makefile.PL (when asked for pg_config path, say: .\pg_config.exe )
+nmake
+
+9. Test and install
+
+You should now be able to set things up for normal DBD::Pg testing,
+which you can invoke via "nmake test"
+
+Then install using "nmake install"
+
+If you have any problems or questions, please email the DBD::Pg
+mailing list: dbdpg-general at gborg.postgresql.org
+
Added: packages/libdbd-pg-perl/branches/upstream/current/SIGNATURE
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/SIGNATURE 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/SIGNATURE 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,64 @@
+This file contains message digests of all files listed in MANIFEST,
+signed via the Module::Signature module, version 0.53.
+
+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: SHA1
+
+SHA1 e341e7143287961df6748a5fd6682551debfa55b Changes
+SHA1 5e023a1c4a2d7b100337118b9fc5e8045d9eb477 MANIFEST
+SHA1 b588ff0c18b70f8f6cd6086685e77d43545633da MANIFEST.SKIP
+SHA1 921f9e6aadd4c3eec0dc33b01ef2ead2cbb69768 META.yml
+SHA1 6150bd9068303bce1424c4011c779828d23b6754 Makefile.PL
+SHA1 352d669b229846c15b50d1e4be7eb7ba915fa2e4 Pg.h
+SHA1 36ccdc25110bc5b9062bcc24854530270310dc5a Pg.pm
+SHA1 fe36e0c66238e2227f978cb9f164347863f6ec8e Pg.xs
+SHA1 3cb6ffaa87ddc8ff1b5d13f9d82d040216f20e48 README
+SHA1 b15bd45265ba6355681ad0e90a9bc67e079c3113 README.dev
+SHA1 319ac453fb03926113288618c65b02925ab28e84 README.win32
+SHA1 6ef58e57841c0efb62a9ddd095b059ebaee9ca52 TODO
+SHA1 1c09ae12a16f41ae182736f735cbc5619018ef12 dbdimp.c
+SHA1 8d49f6bf3cf9f6d9fc00dc6b38f2826f119fd9da dbdimp.h
+SHA1 5cedf4fda7bab37016c5085cbaa47e6a844d9435 quote.c
+SHA1 fb61ed49cb34c02d3e493ef0bfc70fb03c11dd2b quote.h
+SHA1 dd64b3890292b7fcec7f80cefa5776bb7e46fd75 t/00-signature.t
+SHA1 e630598e154ac8f6c012a33005b6a6fb6bc67b89 t/00basic.t
+SHA1 ce4ecaaa422805d7e700d91b6277c3d78d549e92 t/01connect.t
+SHA1 0a3ec06ec1c2941d3f049d7cd7b7daaa30456fb6 t/01constants.t
+SHA1 4b1cf31b243b8e09401b74066935cbe77984f432 t/01setup.t
+SHA1 6749bbc221facacc7dda868b22d27953ff2ba56a t/02attribs.t
+SHA1 b3dae9f48a9084754a30fda5e3ae03e0d1828216 t/03dbmethod.t
+SHA1 39a5b1409e7dd8744464be727c5b64d8ac7b2084 t/03smethod.t
+SHA1 3d714e847e5eab6396e427c3977323debabe0739 t/04misc.t
+SHA1 5e1f9b4e09f9557213f851035bacc10797dd11af t/05arrays.t
+SHA1 cc0a4026c40cdb57a2f06c10d34f2d14119835e8 t/06bytea.t
+SHA1 2efd9e58ad68fbe4d9e4e1f330956b0e1ba2a64a t/07copy.t
+SHA1 7e10529bb19427ea683c7b5d819dc5cbfcae8622 t/12placeholders.t
+SHA1 75fc01c22bd6747019a67c0ff510d5d1854e9b1b t/20savepoints.t
+SHA1 317f0b7d60da748dd3f219c4508d20176ae91047 t/99_pod.t
+SHA1 3132e1102b8c7e1045ecdfd930a48fc8025a4259 t/99cleanup.t
+SHA1 acc11ec2204655bf5ab82bd097e7308c8b4316e6 t/lib/App/Info.pm
+SHA1 57051fb793083a9e1ffb2dc5c3faab1b24ebd1e4 t/lib/App/Info/Handler.pm
+SHA1 d22fe99614d452c39ee620a5c99fa2eaad178a1c t/lib/App/Info/Handler/Prompt.pm
+SHA1 18ba6209a9dfaddbe670a2d8e1a356253f744ac7 t/lib/App/Info/RDBMS.pm
+SHA1 d28eaf6f3b27dc1c6c3271e24a397458da02f92d t/lib/App/Info/RDBMS/PostgreSQL.pm
+SHA1 6c9fc325e6c7a8dcef24e87a878d26c0f89904ef t/lib/App/Info/Request.pm
+SHA1 894b31fadcae3b1cc3891b82b73e24cffda75f3f t/lib/App/Info/Util.pm
+SHA1 293c40bcf056ce592cbfd2e05d722499d8a1c3b9 types.c
+SHA1 43f596ce19f6fe22fa96471bfbf2343cda19203c types.h
+SHA1 f07cd5ecaeb854c81ceb9206364979cf607e6546 win32.mak
+-----BEGIN PGP SIGNATURE-----
+
+iD8DBQFEAfrovJuQZxSWSsgRAtjQAKC9Zfekl+IzqBvuQfVdu9LPXvydCACg9MFh
+kTTOyFph6EdN3pr7uhXvCMk=
+=SHYZ
+-----END PGP SIGNATURE-----
Added: packages/libdbd-pg-perl/branches/upstream/current/TODO
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/TODO 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/TODO 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,18 @@
+TODO:
+
+- Start testing with a thread-enabled Perl.
+- Add array OID types
+- Quoting/dequoting of arrays.
+- Suport for bind_param_inout
+- Support for new error protocol
+- Support new DBI trace scheme.
+- Create a .ppm for Windows
+- 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).
+- Implement a clean UTF-8 support.
+- Allow user callbacks to quote user-defined types?
+- Rename functions and add defines to avoid problems with static linking of multi DBDs
+- Move to the Module::Build system
+- Support asynchronous queries
Added: packages/libdbd-pg-perl/branches/upstream/current/dbdimp.c
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/dbdimp.c 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/dbdimp.c 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,3246 @@
+/*
+
+ $Id: dbdimp.c,v 1.171 2006/02/13 03:19:23 turnstep Exp $
+
+ Copyright (c) 2002-2006 PostgreSQL Global Development Group
+ Portions Copyright (c) 2002 Jeffrey W. Baker
+ 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"
+#include <math.h>
+
+
+/* Force preprocessors to use this variable. Default to something valid yet noticeable */
+#ifndef PGLIBVERSION
+#define PGLIBVERSION 80009
+#endif
+
+#ifdef WIN32
+#define snprintf _snprintf
+#define strcasecmp(s1,s2) lstrcmpiA((s1), (s2))
+#endif
+
+#define sword signed int
+#define sb2 signed short
+#define ub2 unsigned short
+
+/* Someday, we can abandon pre-7.4 and life will be much easier... */
+#if PGLIBVERSION < 70400
+#define PG_DIAG_SQLSTATE 'C'
+/* Better we do all this in one place here than put more ifdefs inside dbdimp.c */
+typedef enum
+{
+ PQTRANS_IDLE, /* connection idle */
+ PQTRANS_ACTIVE, /* command in progress */
+ PQTRANS_INTRANS, /* idle, within transaction block */
+ PQTRANS_INERROR, /* idle, within failed transaction */
+ PQTRANS_UNKNOWN /* cannot determine status */
+} PGTransactionStatusType;
+typedef enum
+{
+ PQERRORS_TERSE, /* single-line error messages */
+ PQERRORS_DEFAULT, /* recommended style */
+ PQERRORS_VERBOSE /* all the facts, ma'am */
+} PGVerbosity;
+/* These are actually used to return default values */
+int PQprotocolVersion(const PGconn *a);
+int PQprotocolVersion(const PGconn *a) { return a ? 0 : 0; }
+
+Oid PQftable(PGresult *a, int b);
+Oid PQftable(PGresult *a, int b) { if (a||b) return InvalidOid; return InvalidOid; }
+
+int PQftablecol(PGresult *a, int b);
+int PQftablecol(PGresult *a, int b) { return a||b ? 0 : 0; }
+
+int PQsetErrorVerbosity(PGconn *a, PGVerbosity b);
+int PQsetErrorVerbosity(PGconn *a, PGVerbosity b) { return a||b ? 0 : 0; }
+
+PGTransactionStatusType PQtransactionStatus(const PGconn *a);
+PGTransactionStatusType PQtransactionStatus(const PGconn *a) { return a ? PQTRANS_UNKNOWN : PQTRANS_UNKNOWN; }
+
+/* These should not be called, and will throw errors if they are */
+PGresult *PQexecPrepared(PGconn *a,const char *b,int c,const char *const *d,const int *e,const int *f,int g);
+PGresult *PQexecPrepared(PGconn *a,const char *b,int c,const char *const *d,const int *e,const int *f,int g) {
+ if (a||b||c||d||e||f||g) g=0;
+ croak ("Called wrong PQexecPrepared\n");
+}
+PGresult *PQexecParams(PGconn *a,const char *b,int c,const Oid *d,const char *const *e,const int *f,const int *g,int h);
+PGresult *PQexecParams(PGconn *a,const char *b,int c,const Oid *d,const char *const *e,const int *f,const int *g,int h) {
+ if (a||b||c||d||e||f||g||h) h=0;
+ croak("Called wrong PQexecParams\n");
+}
+
+#endif
+
+#if PGLIBVERSION < 80000
+
+/* Should not be called, throw errors: */
+PGresult *PQprepare(PGconn *a, const char *b, const char *c, int d, const Oid *e);
+PGresult *PQprepare(PGconn *a, const char *b, const char *c, int d, const Oid *e) {
+ if (a||b||c||d||e) d=0;
+ croak ("Called wrong PQprepare");
+}
+
+int PQserverVersion(const PGconn *a);
+int PQserverVersion(const PGconn *a) { if (!a) return 0; croak ("Called wrong PQserverVersion"); }
+
+#endif
+
+#ifndef PGErrorVerbosity
+typedef enum
+{
+ PGERROR_TERSE, /* single-line error messages */
+ PGERROR_DEFAULT, /* recommended style */
+ PGERROR_VERBOSE /* all the facts, ma'am */
+} PGErrorVerbosity;
+#endif
+
+/* XXX DBI should provide a better version of this */
+#define IS_DBI_HANDLE(h) (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV && SvRMAGICAL(SvRV(h)) && (SvMAGIC(SvRV(h)))->mg_type == 'P')
+
+static ExecStatusType _result(imp_dbh_t *imp_dbh, const char *sql);
+static ExecStatusType _sqlstate(imp_dbh_t *imp_dbh, PGresult *result);
+static void pg_error(SV *h, ExecStatusType error_num, char *error_msg);
+static int dbd_db_rollback_commit (SV *dbh, imp_dbh_t *imp_dbh, char * action);
+static void dbd_st_split_statement (imp_sth_t *imp_sth, int version, char *statement);
+static int dbd_st_prepare_statement (SV *sth, imp_sth_t *imp_sth);
+static int is_high_bit_set(char *val);
+static int dbd_st_deallocate_statement(SV *sth, imp_sth_t *imp_sth);
+static PGTransactionStatusType dbd_db_txn_status (imp_dbh_t *imp_dbh);
+static int pg_db_start_txn (SV *dbh, imp_dbh_t *imp_dbh);
+
+DBISTATE_DECLARE;
+
+/* ================================================================== */
+/* Quick command executor used throughout this file */
+static ExecStatusType _result(imp_dbh, sql)
+ imp_dbh_t *imp_dbh;
+ const char *sql;
+{
+ PGresult *result;
+ ExecStatusType status;
+
+ if (dbis->debug >= 4) (void)PerlIO_printf(DBILOGFP, "dbdpg: _result (%s)\n", sql);
+
+ result = PQexec(imp_dbh->conn, sql);
+
+ status = _sqlstate(imp_dbh, result);
+
+ if (dbis->debug >= 4) (void)PerlIO_printf(DBILOGFP, "dbdpg: Set status to (%d)\n", status);
+
+ PQclear(result);
+
+ return status;
+
+} /* end of _result */
+
+
+/* ================================================================== */
+/* Set the SQLSTATE based on a result, returns the status */
+static ExecStatusType _sqlstate(imp_dbh, result)
+ imp_dbh_t *imp_dbh;
+ PGresult *result;
+{
+ ExecStatusType status = PGRES_FATAL_ERROR; /* until proven otherwise */
+ bool stateset = DBDPG_FALSE;
+
+ if (dbis->debug >= 4) (void)PerlIO_printf(DBILOGFP, "dbdpg: _sqlstate\n");
+
+ if (result)
+ status = PQresultStatus(result);
+
+ if (dbis->debug >= 6) (void)PerlIO_printf(DBILOGFP, "dbdpg: Status is (%d)\n", status);
+
+#if PGLIBVERSION >= 70400
+ if (result && imp_dbh->pg_server_version >= 70400) {
+ strncpy(imp_dbh->sqlstate,
+ NULL == PQresultErrorField(result,PG_DIAG_SQLSTATE) ? "00000" :
+ PQresultErrorField(result,PG_DIAG_SQLSTATE),
+ 5);
+ imp_dbh->sqlstate[5] = '\0';
+ stateset = DBDPG_TRUE;
+ }
+#endif
+ if (!stateset) {
+ /* Do our best to map the status result to a sqlstate code */
+ switch (status) {
+ case PGRES_EMPTY_QUERY:
+ case PGRES_COMMAND_OK:
+ case PGRES_TUPLES_OK:
+ case PGRES_COPY_OUT:
+ case PGRES_COPY_IN:
+ strncpy(imp_dbh->sqlstate, "00000\0", 6); /* Successful completion */
+ break;
+ case PGRES_BAD_RESPONSE:
+ case PGRES_NONFATAL_ERROR:
+ strncpy(imp_dbh->sqlstate, "01000\0", 6); /* Warning */
+ break;
+ case PGRES_FATAL_ERROR:
+ default:
+ strncpy(imp_dbh->sqlstate, "S8006\0", 6); /* Connection failure */
+ break;
+ }
+ }
+
+ if (dbis->debug >= 6) (void)PerlIO_printf(DBILOGFP, "dbdpg: Set sqlstate to (%s)\n", imp_dbh->sqlstate);
+
+ return status;
+
+} /* end of _sqlstate */
+
+
+/* ================================================================== */
+/* Turn database notices into perl warnings for proper handling. */
+static void pg_warn (arg, message)
+ void * arg;
+ const char *message;
+{
+ D_imp_dbh( sv_2mortal(newRV((SV*)arg)) );
+
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_warn (%s) DBIc_WARN=%d\n",
+ message, DBIc_WARN(imp_dbh) ? 1 : 0);
+
+ if (DBIc_WARN(imp_dbh) && DBIc_is(imp_dbh, DBIcf_PrintWarn))
+ warn(message);
+}
+
+
+/* ================================================================== */
+/* Database specific error handling. */
+static void pg_error (h, error_num, error_msg)
+ SV *h;
+ ExecStatusType error_num;
+ char *error_msg;
+{
+ D_imp_xxh(h);
+ char *err, *src, *dst;
+ STRLEN len = strlen(error_msg);
+ imp_dbh_t *imp_dbh = (imp_dbh_t *)(DBIc_TYPE(imp_xxh) == DBIt_ST ? DBIc_PARENT_COM(imp_xxh) : imp_xxh);
+
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_error (%s) number=%d\n",
+ error_msg, error_num);
+
+ New(0, err, len+1, char); /* freed below */
+ if (!err)
+ return;
+
+ src = error_msg;
+ dst = err;
+
+ /* copy error message without trailing newlines */
+ while (*src != '\0') {
+ *dst++ = *src++;
+ }
+ *dst = '\0';
+
+ sv_setiv(DBIc_ERR(imp_xxh), (IV)error_num); /* set err early */
+ sv_setpv(DBIc_ERRSTR(imp_xxh), (char*)err);
+ sv_setpvn(DBIc_STATE(imp_xxh), (char*)imp_dbh->sqlstate, 5);
+ if (dbis->debug >= 3) {
+ (void)PerlIO_printf
+ (DBILOGFP, "dbdpg: %s error %d recorded: %s\n",
+ err, error_num, SvPV_nolen(DBIc_ERRSTR(imp_xxh)));
+ }
+ Safefree(err);
+
+} /* end of pg_error */
+
+
+/* ================================================================== */
+void dbd_init (dbistate)
+ dbistate_t *dbistate;
+{
+ DBIS = dbistate;
+}
+
+
+/* ================================================================== */
+int dbd_db_login (dbh, imp_dbh, dbname, uid, pwd)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+ char *dbname;
+ char *uid;
+ char *pwd;
+{
+
+ char *conn_str, *dest;
+ bool inquote = DBDPG_FALSE;
+ STRLEN connect_string_size;
+ int status;
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_db_login\n"); }
+
+ /* DBD::Pg syntax: 'dbname=dbname;host=host;port=port' */
+ /* libpq syntax: 'dbname=dbname host=host port=port user=uid password=pwd' */
+
+ /* Figure out how large our connection string is going to be */
+ connect_string_size = strlen(dbname);
+ if (strlen(uid)>0) {
+ connect_string_size += strlen(" user=''") + 2*strlen(uid);
+ }
+ if (strlen(pwd)>0) {
+ connect_string_size += strlen(" password=''") + 2*strlen(pwd);
+ }
+
+ New(0, conn_str, connect_string_size+1, char); /* freed below */
+
+ /* Change all semi-colons in dbname to a space, unless quoted */
+ dest = conn_str;
+ while (*dbname != '\0') {
+ if (';' == *dbname && !inquote)
+ *dest++ = ' ';
+ else {
+ if ('\'' == *dbname)
+ inquote = !inquote;
+ *dest++ = *dbname;
+ }
+ dbname++;
+ }
+ *dest = '\0';
+
+ /* Add in the user and/or password if they exist, escaping single quotes and backslashes */
+ if (strlen(uid)>0) {
+ strcat(conn_str, " user='");
+ dest = conn_str;
+ while(*dest != '\0')
+ dest++;
+ while(*uid != '\0') {
+ if ('\''==*uid || '\\'==*uid)
+ *(dest++)='\\';
+ *(dest++)=*(uid++);
+ }
+ *dest = '\0';
+ strcat(conn_str, "'");
+ }
+ if (strlen(pwd)>0) {
+ strcat(conn_str, " password='");
+ dest = conn_str;
+ while(*dest != '\0')
+ dest++;
+ while(*pwd != '\0') {
+ if ('\''==*pwd || '\\'==*pwd)
+ *(dest++)='\\';
+ *(dest++)=*(pwd++);
+ }
+ *dest = '\0';
+ strcat(conn_str, "'");
+ }
+
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: login connection string: (%s)\n", conn_str);
+
+ /* Make a connection to the database */
+
+ if (imp_dbh->conn)
+ PQfinish(imp_dbh->conn);
+ imp_dbh->conn = PQconnectdb(conn_str);
+ Safefree(conn_str);
+
+ Renew(imp_dbh->sqlstate, 6, char); /* freed in dbd_db_destroy (and above) */
+ strncpy(imp_dbh->sqlstate, "25P01\0", 6); /* Internal use (No active SQL transaction) */
+
+ /* Check to see that the backend connection was successfully made */
+ status = PQstatus(imp_dbh->conn);
+ if (CONNECTION_OK != status) {
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ strncpy(imp_dbh->sqlstate, "S0001\0", 6);
+ PQfinish(imp_dbh->conn);
+ return 0;
+ }
+
+ /* Enable warnings to go through perl */
+ (void)PQsetNoticeProcessor(imp_dbh->conn, pg_warn, (void *)SvRV(dbh)); /* XXX this causes a problem with nmake */
+
+ /* Figure out what protocol this server is using */
+ imp_dbh->pg_protocol = PQprotocolVersion(imp_dbh->conn); /* Older versions use the one defined above */
+
+ /* Figure out this particular backend's version */
+ imp_dbh->pg_server_version = -1;
+#if PGLIBVERSION >= 80000
+ imp_dbh->pg_server_version = PQserverVersion(imp_dbh->conn);
+#endif
+ if (imp_dbh->pg_server_version <= 0) {
+ PGresult *result;
+ int cnt, vmaj, vmin, vrev;
+
+ result = PQexec(imp_dbh->conn, "SELECT version(), 'DBD::Pg'");
+ status = _sqlstate(imp_dbh, result);
+
+ if (!result || PGRES_TUPLES_OK != status || (0==PQntuples(result))) {
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Could not get version from the server, status was %d\n", status);
+ }
+ else {
+ cnt = sscanf(PQgetvalue(result,0,0), "PostgreSQL %d.%d.%d", &vmaj, &vmin, &vrev);
+ if (cnt >= 2) {
+ if (cnt == 2)
+ vrev = 0;
+ imp_dbh->pg_server_version = (100 * vmaj + vmin) * 100 + vrev;
+ }
+ }
+ if (result)
+ PQclear(result);
+ }
+
+ imp_dbh->done_begin = DBDPG_FALSE; /* We are not inside a transaction */
+ imp_dbh->pg_bool_tf = DBDPG_FALSE;
+ imp_dbh->pg_enable_utf8 = 0;
+ imp_dbh->prepare_number = 1;
+ imp_dbh->prepare_now = DBDPG_FALSE;
+ imp_dbh->pg_errorlevel = 1; /* Matches PG default */
+ if (imp_dbh->savepoints) {
+ av_undef(imp_dbh->savepoints);
+ sv_free((SV *)imp_dbh->savepoints);
+ }
+ imp_dbh->savepoints = newAV();
+ imp_dbh->copystate = 0;
+
+ /* If the server can handle it, we default to "smart", otherwise "off" */
+ imp_dbh->server_prepare = imp_dbh->pg_protocol >= 3 ?
+ /* If using 3.0 protocol but not yet version 8, switch to "smart" */
+ PGLIBVERSION >= 80000 ? 1 : 2 : 0;
+
+ DBIc_IMPSET_on(imp_dbh); /* imp_dbh set up now */
+ DBIc_ACTIVE_on(imp_dbh); /* call disconnect before freeing */
+ return imp_dbh->pg_server_version;
+
+} /* end of dbd_db_login */
+
+
+
+/* ================================================================== */
+int dbd_db_ping (dbh)
+ SV *dbh;
+{
+ D_imp_dbh(dbh);
+ PGTransactionStatusType tstatus;
+ int status;
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_db_ping\n"); }
+
+ if (NULL == imp_dbh->conn) {
+ return -1;
+ }
+
+#if PGLIBVERSION < 70400
+ tstatus = 0;
+#else
+ tstatus = dbd_db_txn_status(imp_dbh);
+#endif
+
+ if (dbis->debug >= 6)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: tstatus: (%d)\n", tstatus);
+
+ if (tstatus >= 4) { /* Unknown, so we err on the side of "bad" */
+ return -2;
+ }
+
+ if (tstatus != 0) { /* 2=active, 3=intrans, 4=inerror */
+ return 1+tstatus ;
+ }
+
+ /* Even though it may be reported as normal, we have to make sure by issuing a command */
+
+ status = _result(imp_dbh, "SELECT 'DBD::Pg ping test'");
+
+ if (PGRES_TUPLES_OK == status) {
+ return 1;
+ }
+
+ return -3;
+
+} /* end of dbd_db_ping */
+
+
+/* ================================================================== */
+static PGTransactionStatusType dbd_db_txn_status (imp_dbh)
+ imp_dbh_t *imp_dbh;
+{
+
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_db_txn_status%s\n",
+ PGLIBVERSION < 70400 ? " (ALWAYS 4)" : "");
+
+ /* Pre 7.3 *compiled* servers (our PG library) always return unknown */
+
+ /* Since 7.3 has a possible autocommit issue, we simply have it return unknown as well */
+#if PGLIBVERSION < 70400
+ return 4;
+#else
+ return PQtransactionStatus(imp_dbh->conn);
+#endif
+
+} /* end of dbd_db_txn_status */
+
+
+/* rollback and commit share so much code they get one function: */
+
+/* ================================================================== */
+static int dbd_db_rollback_commit (dbh, imp_dbh, action)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+ char * action;
+{
+
+ PGTransactionStatusType tstatus;
+ int status;
+
+ if (dbis->debug >= 4) {
+ (void)PerlIO_printf
+ (DBILOGFP, "dbdpg: dbd_db_%s (AutoCommit is %d) (BegunWork is %d)\n", action,
+ DBIc_is(imp_dbh, DBIcf_AutoCommit) ? 1 : 0,
+ DBIc_is(imp_dbh, DBIcf_BegunWork) ? 1 : 0);
+ }
+
+ /* no action if AutoCommit = on or the connection is invalid */
+ if ((NULL == imp_dbh->conn) || (DBIc_has(imp_dbh, DBIcf_AutoCommit)))
+ return 0;
+
+ /* We only perform these actions if we need to. For newer servers, we
+ ask it for the status directly and double-check things */
+
+#if PGLIBVERSION < 70400
+ tstatus = 0;
+#else
+ tstatus = dbd_db_txn_status(imp_dbh);
+ if (PQTRANS_IDLE == tstatus) { /* Not in a transaction */
+ if (imp_dbh->done_begin) {
+ /* We think we ARE in a transaction but we really are not */
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: Warning: invalid done_begin turned off\n"); }
+ imp_dbh->done_begin = DBDPG_FALSE;
+ }
+ }
+ else if (PQTRANS_ACTIVE == tstatus) { /* Still active - probably in a COPY */
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: Command in progress, so no done_begin checking!\n"); }
+ }
+ else if (PQTRANS_INTRANS == tstatus || PQTRANS_INERROR == tstatus) { /* In a (possibly failed) transaction */
+ if (!imp_dbh->done_begin) {
+ /* We think we are NOT in a transaction but we really are */
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: Warning: invalid done_begin turned on\n"); }
+ imp_dbh->done_begin = DBDPG_TRUE;
+ }
+ }
+ else { /* Something is wrong: transaction status unknown */
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: Warning: cannot determine transaction status\n"); }
+ }
+#endif
+
+ /* If begin_work has been called, turn AutoCommit back on and BegunWork off */
+ if (DBIc_has(imp_dbh, DBIcf_BegunWork)!=0) {
+ DBIc_set(imp_dbh, DBIcf_AutoCommit, 1);
+ DBIc_set(imp_dbh, DBIcf_BegunWork, 0);
+ }
+
+ if (!imp_dbh->done_begin)
+ return 1;
+
+ status = _result(imp_dbh, action);
+
+ if (PGRES_COMMAND_OK != status) {
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+
+ av_undef(imp_dbh->savepoints);
+ imp_dbh->done_begin = DBDPG_FALSE;
+
+ /* If we just did a rollback or a commit, we can no longer be in a PGRES_COPY state */
+ imp_dbh->copystate=0;
+
+ return 1;
+
+} /* end of dbd_db_rollback_commit */
+
+/* ================================================================== */
+int dbd_db_commit (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+ return dbd_db_rollback_commit(dbh, imp_dbh, "commit");
+}
+
+/* ================================================================== */
+int dbd_db_rollback (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+ return dbd_db_rollback_commit(dbh, imp_dbh, "rollback");
+}
+
+
+/* ================================================================== */
+int dbd_db_disconnect (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_db_disconnect\n"); }
+
+ /* We assume that disconnect will always work
+ since most errors imply already disconnected. */
+
+ DBIc_ACTIVE_off(imp_dbh);
+
+ if (NULL != imp_dbh->conn) {
+ /* Rollback if needed */
+ if (0!=dbd_db_rollback(dbh, imp_dbh) && dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_db_disconnect: AutoCommit=off -> rollback\n");
+
+ PQfinish(imp_dbh->conn);
+
+ imp_dbh->conn = NULL;
+ }
+
+ /* We don't free imp_dbh since a reference still exists */
+ /* The DESTROY method is the only one to 'free' memory. */
+ /* Note that statement objects may still exists for this dbh! */
+
+ return 1;
+
+} /* end of dbd_db_disconnect */
+
+
+/* ================================================================== */
+void dbd_db_destroy (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_db_destroy\n"); }
+
+ av_undef(imp_dbh->savepoints);
+ sv_free((SV *)imp_dbh->savepoints);
+ Safefree(imp_dbh->sqlstate);
+
+ if (DBIc_ACTIVE(imp_dbh)!=0)
+ (void)dbd_db_disconnect(dbh, imp_dbh);
+
+ DBIc_IMPSET_off(imp_dbh);
+
+} /* end of dbd_db_destroy */
+
+
+/* ================================================================== */
+int dbd_db_STORE_attrib (dbh, imp_dbh, keysv, valuesv)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+ SV *keysv;
+ SV *valuesv;
+{
+ STRLEN kl;
+ char *key = SvPV(keysv,kl);
+ int oldval;
+ int newval = SvTRUE(valuesv);
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_db_STORE (%s) (%d)\n", key, newval); }
+
+ if (10==kl && strEQ(key, "AutoCommit")) {
+ oldval = DBIc_has(imp_dbh, DBIcf_AutoCommit);
+ if (oldval == newval)
+ return 1;
+ if (newval!=0) { /* It was off but is now on, so do a final commit */
+ if (0!=dbd_db_commit(dbh, imp_dbh) && dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Setting AutoCommit on forced a commit\n");
+ }
+ DBIc_set(imp_dbh, DBIcf_AutoCommit, newval);
+ return 1;
+ }
+ else if (10==kl && strEQ(key, "pg_bool_tf")) {
+ imp_dbh->pg_bool_tf = newval!=0 ? DBDPG_TRUE : DBDPG_FALSE;
+ }
+#ifdef is_utf8_string
+ else if (14==kl && strEQ(key, "pg_enable_utf8")) {
+ imp_dbh->pg_enable_utf8 = newval!=0 ? DBDPG_TRUE : DBDPG_FALSE;
+ }
+#endif
+ else if (13==kl && strEQ(key, "pg_errorlevel")) {
+ /* Introduced in 7.4 servers */
+ if (imp_dbh->pg_protocol >= 3) {
+ newval = SvIV(valuesv);
+ /* Default to "1" if an invalid value is passed in */
+ imp_dbh->pg_errorlevel = 0==newval ? 0 : 2==newval ? 2 : 1;
+ (void)PQsetErrorVerbosity(imp_dbh->conn, imp_dbh->pg_errorlevel); /* pre-7.4 does nothing */
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Reset error verbosity to %d\n", imp_dbh->pg_errorlevel);
+ }
+ }
+ else if (17==kl && strEQ(key, "pg_server_prepare")) {
+ /* No point changing this if the server does not support it */
+ if (imp_dbh->pg_protocol >= 3) {
+ newval = SvIV(valuesv);
+ /* Default to "2" if an invalid value is passed in */
+ imp_dbh->server_prepare = 0==newval ? 0 : 1==newval ? 1 : 2;
+ }
+ }
+ else if (14==kl && strEQ(key, "pg_prepare_now")) {
+ if (imp_dbh->pg_protocol >= 3) {
+ imp_dbh->prepare_now = newval ? DBDPG_TRUE : DBDPG_FALSE;
+ }
+ }
+ return 0;
+
+} /* end of dbd_db_STORE_attrib */
+
+
+/* ================================================================== */
+SV * dbd_db_FETCH_attrib (dbh, imp_dbh, keysv)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+ SV *keysv;
+{
+ STRLEN kl;
+ char *key = SvPV(keysv,kl);
+ SV *retsv = Nullsv;
+ char *host = NULL;
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_db_FETCH (%s) dbh=%d\n", key, dbh); }
+
+ if (10==kl && strEQ(key, "AutoCommit")) {
+ retsv = boolSV(DBIc_has(imp_dbh, DBIcf_AutoCommit));
+ } else if (10==kl && strEQ(key, "pg_bool_tf")) {
+ retsv = newSViv((IV)imp_dbh->pg_bool_tf);
+ } else if (13==kl && strEQ(key, "pg_errorlevel")) {
+ retsv = newSViv((IV)imp_dbh->pg_errorlevel);
+#ifdef is_utf8_string
+ } else if (14==kl && strEQ(key, "pg_enable_utf8")) {
+ retsv = newSViv((IV)imp_dbh->pg_enable_utf8);
+#endif
+ } else if (11==kl && strEQ(key, "pg_INV_READ")) {
+ retsv = newSViv((IV)INV_READ);
+ } else if (12==kl && strEQ(key, "pg_INV_WRITE")) {
+ retsv = newSViv((IV)INV_WRITE);
+ } else if (11==kl && strEQ(key, "pg_protocol")) {
+ retsv = newSViv((IV)imp_dbh->pg_protocol);
+ } else if (17==kl && strEQ(key, "pg_server_prepare")) {
+ retsv = newSViv((IV)imp_dbh->server_prepare);
+ } else if (14==kl && strEQ(key, "pg_prepare_now")) {
+ retsv = newSViv((IV)imp_dbh->prepare_now);
+ } else if (14==kl && strEQ(key, "pg_lib_version")) {
+ retsv = newSViv((IV) PGLIBVERSION );
+ } else if (17==kl && strEQ(key, "pg_server_version")) {
+ retsv = newSViv((IV)imp_dbh->pg_server_version);
+ }
+ else if (5==kl && strEQ(key, "pg_db")) {
+ retsv = newSVpv(PQdb(imp_dbh->conn),0);
+ } else if (7==kl && strEQ(key, "pg_user")) {
+ retsv = newSVpv(PQuser(imp_dbh->conn),0);
+ } else if (7==kl && strEQ(key, "pg_pass")) {
+ retsv = newSVpv(PQpass(imp_dbh->conn),0);
+ } else if (7==kl && strEQ(key, "pg_host")) {
+ host = PQhost(imp_dbh->conn); /* May return null */
+ if (NULL==host)
+ return Nullsv;
+ retsv = newSVpv(host,0);
+ } else if (7==kl && strEQ(key, "pg_port")) {
+ retsv = newSVpv(PQport(imp_dbh->conn),0);
+ } else if (15==kl && strEQ(key, "pg_default_port")) {
+ retsv = newSViv((IV) PGDEFPORT );
+ } else if (10==kl && strEQ(key, "pg_options")) {
+ retsv = newSVpv(PQoptions(imp_dbh->conn),0);
+ } else if (9==kl && strEQ(key, "pg_socket")) {
+ retsv = newSViv((IV)PQsocket(imp_dbh->conn));
+ } else if (6==kl && strEQ(key, "pg_pid")) {
+ retsv = newSViv((IV)PQbackendPID(imp_dbh->conn));
+ }
+
+ if (!retsv)
+ return Nullsv;
+
+ if (retsv == &sv_yes || retsv == &sv_no) {
+ return retsv; /* no need to mortalize yes or no */
+ }
+ return sv_2mortal(retsv);
+
+} /* end of dbd_db_FETCH_attrib */
+
+
+/* ================================================================== */
+int dbd_discon_all (drh, imp_drh)
+ SV *drh;
+ imp_drh_t *imp_drh;
+{
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_discon_all drh=%d\n", drh); }
+
+ /* The disconnect_all concept is flawed and needs more work */
+ if (!PL_dirty && !SvTRUE(perl_get_sv("DBI::PERL_ENDING",0))) {
+ sv_setiv(DBIc_ERR(imp_drh), (IV)1);
+ sv_setpv(DBIc_ERRSTR(imp_drh), "disconnect_all not implemented");
+ }
+ return DBDPG_FALSE;
+
+} /* end of dbd_discon_all */
+
+
+/* ================================================================== */
+int dbd_db_getfd (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_db_getfd dbh=%d\n", dbh); }
+
+ return PQsocket(imp_dbh->conn);
+
+} /* end of dbd_db_getfd */
+
+
+/* ================================================================== */
+SV * dbd_db_pg_notifies (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+ PGnotify *notify;
+ AV *ret;
+ SV *retsv;
+ int status;
+
+ if (dbis->debug >= 3) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_db_pg_notifies\n"); }
+
+ status = PQconsumeInput(imp_dbh->conn);
+ if (0 == status) {
+ status = PQstatus(imp_dbh->conn);
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ return &sv_undef;
+ }
+
+ notify = PQnotifies(imp_dbh->conn);
+
+ if (!notify)
+ return &sv_undef;
+
+ ret=newAV();
+
+ av_push(ret, newSVpv(notify->relname,0) );
+ av_push(ret, newSViv(notify->be_pid) );
+
+#if PGLIBVERSION >= 70400
+ PQfreemem(notify);
+#else
+ Safefree(notify);
+#endif
+
+ retsv = newRV(sv_2mortal((SV*)ret));
+
+ return retsv;
+
+} /* end of dbd_db_pg_notifies */
+
+
+/* ================================================================== */
+int dbd_st_prepare (sth, imp_sth, statement, attribs)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ char *statement;
+ SV *attribs; /* hashref of arguments passed to prepare */
+{
+
+ D_imp_dbh_from_sth;
+ STRLEN mypos=0, wordstart, newsize; /* Used to find and set firstword */
+ SV **svp; /* To help parse the arguments */
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_prepare (%s)\n", statement); }
+
+ /* Set default values for this statement handle */
+ imp_sth->is_dml = DBDPG_FALSE; /* Not preparable DML until proved otherwise */
+ imp_sth->prepared_by_us = DBDPG_FALSE; /* Set to 1 when actually done preparing */
+ imp_sth->has_binary = DBDPG_FALSE; /* Are any of the params binary? */
+ imp_sth->has_default = DBDPG_FALSE; /* Are any of the params DEFAULT? */
+ imp_sth->onetime = DBDPG_FALSE; /* Allow internal shortcut */
+ imp_sth->result = NULL;
+ imp_sth->cur_tuple = 0;
+ imp_sth->placeholder_type = 0;
+ imp_sth->rows = -1;
+ imp_sth->totalsize = 0;
+ imp_sth->numsegs = imp_sth->numphs = imp_sth->numbound = 0;
+ imp_sth->direct = DBDPG_FALSE;
+ imp_sth->prepare_name = NULL;
+ imp_sth->seg = NULL;
+ imp_sth->ph = NULL;
+ imp_sth->type_info = NULL;
+
+ /* We inherit our prepare preferences from the database handle */
+ imp_sth->server_prepare = imp_dbh->server_prepare;
+ imp_sth->prepare_now = imp_dbh->prepare_now;
+
+ /* Parse and set any attributes passed in */
+ if (attribs) {
+ if ((svp = hv_fetch((HV*)SvRV(attribs),"pg_server_prepare", 17, 0)) != NULL) {
+ if (imp_dbh->pg_protocol >= 3) {
+ int newval = SvIV(*svp);
+ /* Default to "2" if an invalid value is passed in */
+ imp_sth->server_prepare = 0==newval ? 0 : 1==newval ? 1 : 2;
+ }
+ }
+ if ((svp = hv_fetch((HV*)SvRV(attribs),"pg_direct", 9, 0)) != NULL)
+ imp_sth->direct = 0==SvIV(*svp) ? DBDPG_FALSE : DBDPG_TRUE;
+ else if ((svp = hv_fetch((HV*)SvRV(attribs),"pg_prepare_now", 14, 0)) != NULL) {
+ if (imp_dbh->pg_protocol >= 3) {
+ imp_sth->prepare_now = 0==SvIV(*svp) ? DBDPG_FALSE : DBDPG_TRUE;
+ }
+ }
+ }
+
+ /* Figure out the first word in the statement */
+ while (*statement && isSPACE(*statement)) {
+ mypos++;
+ statement++;
+ }
+ if ((*statement=='\0') || !isALPHA(*statement)) {
+ imp_sth->firstword = NULL;
+ }
+ else {
+ wordstart = mypos;
+ while((*statement!='\0') && isALPHA(*statement)) {
+ mypos++;
+ statement++;
+ }
+ newsize = mypos-wordstart;
+ New(0, imp_sth->firstword, newsize+1, char); /* freed in dbd_st_destroy, and above */
+ Copy(statement-newsize,imp_sth->firstword,newsize,char);
+ imp_sth->firstword[newsize] = '\0';
+ /* Try to prevent transaction commands unless "pg_direct" is set */
+ if (0==strcasecmp(imp_sth->firstword, "END") ||
+ 0==strcasecmp(imp_sth->firstword, "BEGIN") ||
+ 0==strcasecmp(imp_sth->firstword, "ABORT") ||
+ 0==strcasecmp(imp_sth->firstword, "COMMIT") ||
+ 0==strcasecmp(imp_sth->firstword, "ROLLBACK") ||
+ 0==strcasecmp(imp_sth->firstword, "RELEASE") ||
+ 0==strcasecmp(imp_sth->firstword, "SAVEPOINT")
+ ) {
+ if (!imp_sth->direct)
+ croak ("Please use DBI functions for transaction handling");
+ imp_sth->is_dml = DBDPG_TRUE; /* Close enough for our purposes */
+ }
+ /* Note whether this is preparable DML */
+ if (0==strcasecmp(imp_sth->firstword, "SELECT") ||
+ 0==strcasecmp(imp_sth->firstword, "INSERT") ||
+ 0==strcasecmp(imp_sth->firstword, "UPDATE") ||
+ 0==strcasecmp(imp_sth->firstword, "DELETE")
+ ) {
+ imp_sth->is_dml = DBDPG_TRUE;
+ }
+ }
+ statement -= mypos; /* Rewind statement */
+
+ /* Break the statement into segments by placeholder */
+ dbd_st_split_statement(imp_sth, imp_dbh->pg_server_version, statement);
+
+ /*
+ We prepare it right away if:
+ 1. The statement is DML
+ 2. The attribute "direct" is false
+ 3. The backend can handle server-side prepares
+ 4. The attribute "pg_server_prepare" is not 0
+ 5. The attribute "pg_prepare_now" is true
+ 6. We are compiled on a 8 or greater server
+ */
+ if (dbis->debug >= 6)
+ (void)PerlIO_printf
+ (DBILOGFP,
+ "dbdpg: Immediate prepare decision: dml=%d direct=%d protocol=%d server_prepare=%d prepare_now=%d PGLIBVERSION=%d\n",
+ imp_sth->is_dml, imp_sth->direct, imp_dbh->pg_protocol, imp_sth->server_prepare, imp_sth->prepare_now, PGLIBVERSION
+ );
+
+ if (imp_sth->is_dml &&
+ !imp_sth->direct &&
+ imp_dbh->pg_protocol >= 3 &&
+ 0 != imp_sth->server_prepare &&
+ imp_sth->prepare_now &&
+ PGLIBVERSION >= 80000
+ ) {
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Running an immediate prepare\n");
+
+ if (dbd_st_prepare_statement(sth, imp_sth)!=0) {
+ croak (PQerrorMessage(imp_dbh->conn));
+ }
+ }
+
+ DBIc_IMPSET_on(imp_sth);
+
+ return imp_sth->numphs;
+
+} /* end of dbd_st_prepare */
+
+
+/* ================================================================== */
+static void dbd_st_split_statement (imp_sth, version, statement)
+ imp_sth_t *imp_sth;
+ int version;
+ char *statement;
+{
+
+ /* Builds the "segment" and "placeholder" structures for a statement handle */
+
+ STRLEN currpos; /* Where we currently are in the statement string */
+
+ STRLEN sectionstart, sectionstop; /* Borders of current section */
+
+ STRLEN sectionsize; /* Size of an allocated segment */
+
+ STRLEN backslashes; /* Counts backslashes, only used in quote section */
+
+ STRLEN dollarsize; /* Size of dollarstring */
+
+ int topdollar; /* Used to enforce sequential $1 arguments */
+
+ int placeholder_type; /* Which type we are in: one of 0,1,2,3 (none,?,$,:) */
+
+ char ch; /* The current character being checked */
+
+ char quote; /* Current quote or comment character: used only in those two blocks */
+
+ bool found; /* Simple boolean */
+
+ bool inside_dollar; /* Inside a dollar quoted value */
+
+ char * dollarstring = NULL; /* Dynamic string between $$ in dollar quoting */
+
+ STRLEN xlen; /* Because "x" is too hard to search for */
+
+ int xint;
+
+ seg_t *newseg, *currseg = NULL; /* Segment structures to help build linked lists */
+
+ ph_t *newph, *thisph, *currph = NULL; /* Placeholder structures to help build ll */
+
+ if (dbis->debug >= 4) {
+ if (dbis->debug >= 10) {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_split_statement (%s)\n", statement);
+ }
+ else {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_split_statement\n");
+ }
+ }
+
+ /*
+ If the pg_direct flag is set (or the string has no length), we do not split at all,
+ but simply put everything verbatim into a single segment and return.
+ */
+ if (imp_sth->direct || '\0' == *statement) {
+ if (dbis->debug >= 4) {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: not splitting due to %s\n",
+ imp_sth->direct ? "pg_direct" : "empty string");
+ }
+ imp_sth->numsegs = 1;
+ imp_sth->numphs = 0;
+ New(0, imp_sth->seg, 1, seg_t); /* freed in dbd_st_destroy */
+ imp_sth->seg->nextseg = NULL;
+ imp_sth->seg->placeholder = 0;
+ imp_sth->seg->ph = NULL;
+ imp_sth->totalsize = strlen(statement);
+ if (imp_sth->totalsize > 0) {
+ New(0, imp_sth->seg->segment, imp_sth->totalsize+1, char); /* freed in dbd_st_destroy */
+ Copy(statement, imp_sth->seg->segment, imp_sth->totalsize+1, char);
+ }
+ else {
+ imp_sth->seg->segment = NULL;
+ }
+ if (dbis->debug >= 10) {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: direct split = (%s) length=(%d)\n",
+ imp_sth->seg->segment, imp_sth->totalsize);
+ }
+ return;
+ }
+
+ /* Start everyone at the start of the string */
+ currpos = sectionstart = 0;
+
+ ch = 1;
+
+ while (1) {
+
+ /* Are we done processing this string? */
+ if (ch < 1) {
+ break;
+ }
+
+ /* Put the current letter into ch, and advance statement to the next character */
+ ch = *statement++;
+
+ /* Remember: currpos matches *statement, not ch */
+ currpos++;
+
+ /* Quick short-circuit for uninteresting characters */
+ if (
+ (ch < 34 && ch != 0) || (ch > 63 && ch != 91) ||
+ (ch!=34 && ch!=39 && /* simple quoting */
+ ch!=45 && ch!=47 && /* comment */
+ ch!=36 && /* dollar quoting or placeholder */
+ ch!=58 && ch!=63 && /* placeholder */
+ ch!=91 && /* array slice */
+ ch!=0 /* end of the string (create segment) */
+ )
+ ) {
+ continue;
+ }
+
+ /* 1: A traditionally quoted section */
+ if ('\'' == ch || '"' == ch) {
+ quote = ch;
+ backslashes = 0;
+ /* Go until ending quote character (unescaped) or end of string */
+ while (quote && ++currpos && (ch = *statement++)) {
+ /* 1.1 : single quotes have no meaning in double-quoted sections and vice-versa */
+ /* 1.2 : backslashed quotes do not end the section */
+ if (ch == quote && (0==(backslashes&1))) {
+ quote = 0;
+ }
+ else if ('\\' == ch)
+ backslashes++;
+ else
+ backslashes = 0;
+ }
+ /* 1.3 Quote ended normally, not the end of the string */
+ if (ch != 0)
+ continue;
+ /* 1.4 String ended, but the quote did not */
+ if (0 != quote) {
+ /* Let the backend handle this */
+ }
+
+ /* 1.5: End quote was the last character in the string */
+ } /* end quote section */
+
+ /* 2: A comment block: */
+ if (('-' == ch && '-' == *statement) ||
+ ('/' == ch && '/' == *statement) ||
+ ('/' == ch && '*' == *statement)
+ ) {
+ quote = *statement;
+ /* Go until end of comment (may be newline) or end of the string */
+ while (quote && ++currpos && (ch = *statement++)) {
+ /* 2.1: dashdash and slashslash only terminate at newline */
+ if (('-' == quote || '/' == quote) && '\n' == ch) {
+ quote=0;
+ }
+ /* 2.2: slashstar ends with a matching starslash */
+ else if ('*' == quote && '*' == ch && '/' == *statement) {
+ /* Slurp up the slash */
+ ch = *statement++;
+ currpos++;
+ quote=0;
+ }
+ }
+
+ /* 2.3 Comment ended normally, not the end of the string */
+ if (ch != 0)
+ continue;
+
+ /* 2.4 String ended, but the comment did not - do nothing special */
+ /* 2.5: End quote was the last character in the string */
+ } /* end comment section */
+
+ /* 3: advanced dollar quoting - only if the backend is version 8 or higher */
+ if (version >= 80000 && '$' == ch && (*statement == '$' || *statement >= 'A')) {
+ /* Unlike PG, we allow a little more latitude in legal characters - anything >= 65 can be used */
+ sectionsize = 0; /* How far from the first dollar sign are we? */
+ found = 0; /* Have we found the end of the dollarquote? */
+
+ /* Scan forward until we hit the matching dollarsign */
+ while ((ch = *statement++)) {
+
+ sectionsize++;
+ /* If we hit an invalid character, bail out */
+ if (ch <= 32 || (ch >= '0' && ch <= '9')) {
+ break;
+ }
+ if ('$' == ch) {
+ found = DBDPG_TRUE;
+ break;
+ }
+ } /* end first scan */
+
+ /* Not found? Move to the next letter after the dollarsign and move on */
+ if (!found) {
+ statement -= sectionsize;
+ if (!ch) {
+ ch = 1; /* So the top loop still works */
+ statement--;
+ }
+ continue;
+ }
+
+ /* We only need to create a dollarstring if something was between the two dollar signs */
+ if (sectionsize >= 1) {
+ New(0, dollarstring, sectionsize, char); /* note: a true array, not a null-terminated string */
+ strncpy(dollarstring, statement-sectionsize, sectionsize);
+ }
+
+ /* Move on and see if the quote is ever closed */
+
+ inside_dollar=0; /* Are we evaluating the dollar sign for the end? */
+ dollarsize = sectionsize;
+ xlen=0; /* The current character we are tracing */
+ found=0;
+ while ((ch = *statement++)) {
+ sectionsize++;
+ if (inside_dollar) {
+ /* Special case of $$ */
+ if (dollarsize < 1) {
+ found = DBDPG_TRUE;
+ break;
+ }
+ if (ch == dollarstring[xlen++]) {
+ /* Got a total match? */
+ if (xlen >= dollarsize) {
+ found = DBDPG_TRUE;
+ statement++;
+ sectionsize--;
+ break;
+ }
+ }
+ else { /* False dollar string: reset */
+ inside_dollar=0;
+ xlen=0;
+ /* Fall through in case this is a dollar sign */
+ }
+ }
+ if ('$' == ch) {
+ inside_dollar = DBDPG_TRUE;
+ }
+ }
+
+ /* Once here, we are either rewinding, or are done parsing the string */
+
+ /* If end of string, rewind one character */
+ if (0==ch) {
+ sectionsize--;
+ }
+
+ if (dollarstring)
+ Safefree(dollarstring);
+
+ /* Advance our cursor to the current position */
+ currpos += sectionsize+1;
+
+ statement--; /* Rewind statement by one */
+
+ /* If not found, might be end of string, so set ch */
+ if (!found) {
+ ch = 1;
+ }
+
+ /* Regardless if found or not, we send it back */
+ continue;
+
+ } /* end dollar quoting */
+
+ /* All we care about at this point is placeholder characters and end of string */
+ if ('?' != ch && '$' != ch && ':' != ch && 0!=ch) {
+ continue;
+ }
+
+ /* We might slurp in a placeholder, so mark the character before the current one */
+ /* In other words, inside of "ABC?", set sectionstop to point to "C" */
+ sectionstop=currpos-1;
+
+ /* Figure out if we have a placeholder */
+ placeholder_type = 0;
+
+ /* Normal question mark style */
+ if ('?' == ch) {
+ placeholder_type = 1;
+ }
+ /* Dollar sign placeholder style */
+ else if ('$' == ch && isDIGIT(*statement)) {
+ if ('0' == *statement)
+ croak("Invalid placeholder value");
+ while(isDIGIT(*statement)) {
+ ++statement;
+ ++currpos;
+ }
+ placeholder_type = 2;
+ }
+ /* Colon style, but skip two colons in a row (e.g. myval::float) */
+ else if (':' == ch) {
+ if (':' == *statement) {
+ /* Might as well skip _all_ consecutive colons */
+ while(':' == *statement) {
+ ++statement;
+ ++currpos;
+ }
+ continue;
+ }
+ if (isALNUM(*statement)) {
+ while(isALNUM(*statement)) {
+ ++statement;
+ ++currpos;
+ }
+ placeholder_type = 3;
+ }
+ }
+
+ /* Check for conflicting placeholder types */
+ if (placeholder_type!=0) {
+ if (imp_sth->placeholder_type && placeholder_type != imp_sth->placeholder_type)
+ croak("Cannot mix placeholder styles \"%s\" and \"%s\"",
+ 1==imp_sth->placeholder_type ? "?" : 2==imp_sth->placeholder_type ? "$1" : ":foo",
+ 1==placeholder_type ? "?" : 2==placeholder_type ? "$1" : ":foo");
+ }
+
+ /* Move on to the next letter unless we found a placeholder, or we are at the end of the string */
+ if (0==placeholder_type && ch)
+ continue;
+
+ /* If we got here, we have a segment that needs to be saved */
+ New(0, newseg, 1, seg_t); /* freed in dbd_st_destroy */
+ newseg->nextseg = NULL;
+ newseg->placeholder = 0;
+ newseg->ph = NULL;
+
+ if (1==placeholder_type) {
+ newseg->placeholder = ++imp_sth->numphs;
+ }
+ else if (2==placeholder_type) {
+ newseg->placeholder = atoi(statement-(currpos-sectionstop-2));
+ }
+ else if (3==placeholder_type) {
+ sectionsize = currpos-sectionstop;
+ /* Have we seen this placeholder yet? */
+ for (xint=1,thisph=imp_sth->ph; NULL != thisph; thisph=thisph->nextph,xint++) {
+ if (0==strncmp(thisph->fooname, statement-sectionsize, sectionsize)) {
+ newseg->placeholder = xint;
+ newseg->ph = thisph;
+ break;
+ }
+ }
+ if (0==newseg->placeholder) {
+ imp_sth->numphs++;
+ newseg->placeholder = imp_sth->numphs;
+ New(0, newph, 1, ph_t); /* freed in dbd_st_destroy */
+ newseg->ph = newph;
+ newph->nextph = NULL;
+ newph->bind_type = NULL;
+ newph->value = NULL;
+ newph->quoted = NULL;
+ newph->referenced = DBDPG_FALSE;
+ newph->defaultval = DBDPG_TRUE;
+ newph->isdefault = DBDPG_FALSE;
+ New(0, newph->fooname, sectionsize+1, char); /* freed in dbd_st_destroy */
+ Copy(statement-sectionsize, newph->fooname, sectionsize, char);
+ newph->fooname[sectionsize] = '\0';
+ if (NULL==currph) {
+ imp_sth->ph = newph;
+ }
+ else {
+ currph->nextph = newph;
+ }
+ currph = newph;
+ }
+ } /* end if placeholder_type */
+
+ sectionsize = sectionstop-sectionstart; /* 4-0 for "ABCD" */
+ if (sectionsize>0) {
+ New(0, newseg->segment, sectionsize+1, char); /* freed in dbd_st_destroy */
+ Copy(statement-(currpos-sectionstart), newseg->segment, sectionsize, char);
+ newseg->segment[sectionsize] = '\0';
+ imp_sth->totalsize += sectionsize;
+ }
+ else {
+ newseg->segment = NULL;
+ }
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Created segment (%s)\n", newseg->segment);
+
+ /* Tie it in to the previous one */
+ if (NULL==currseg) {
+ imp_sth->seg = newseg;
+ }
+ else {
+ currseg->nextseg = newseg;
+ }
+ currseg = newseg;
+ sectionstart = currpos;
+ imp_sth->numsegs++;
+
+ imp_sth->placeholder_type = placeholder_type;
+
+ /* If this segment also, ended the string, set ch so we bail out early */
+ if ('\0' == *statement)
+ break;
+
+ } /* end large while(1) loop: statement parsing */
+
+ /* For dollar sign placeholders, ensure that the rules are followed */
+ if (2==imp_sth->placeholder_type) {
+ /*
+ We follow the Pg rules: must start with $1, repeats are allowed,
+ numbers must be sequential. We change numphs if repeats found
+ */
+ topdollar=0;
+ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) {
+ if (currseg->placeholder > topdollar)
+ topdollar = currseg->placeholder;
+ }
+
+ /* Make sure every placeholder from 1 to topdollar is used at least once */
+ for (xint=1; xint <= topdollar; xint++) {
+ for (found=0, currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) {
+ if (currseg->placeholder==xint) {
+ found = DBDPG_TRUE;
+ break;
+ }
+ }
+ if (!found)
+ croak("Invalid placeholders: must start at $1 and increment one at a time (expected: $%d)\n", xint);
+ }
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Set number of placeholders to %d\n", topdollar);
+ imp_sth->numphs = topdollar;
+ }
+
+ /* Create sequential placeholders */
+ if (3 != imp_sth->placeholder_type) {
+ currseg = imp_sth->seg;
+ for (xint=1; xint <= imp_sth->numphs; xint++) {
+ New(0, newph, 1, ph_t); /* freed in dbd_st_destroy */
+ newph->nextph = NULL;
+ newph->bind_type = NULL;
+ newph->value = NULL;
+ newph->quoted = NULL;
+ newph->referenced = DBDPG_FALSE;
+ newph->defaultval = DBDPG_TRUE;
+ newph->isdefault = DBDPG_FALSE;
+ newph->fooname = NULL;
+ /* Let the correct segment point to it */
+ while (!currseg->placeholder)
+ currseg = currseg->nextseg;
+ if (!currseg)
+ croak("Invalid segment");
+ currseg->ph = newph;
+ currseg = currseg->nextseg;
+ if (NULL==currph) {
+ imp_sth->ph = newph;
+ }
+ else {
+ currph->nextph = newph;
+ }
+ currph = newph;
+ }
+ }
+
+ if (dbis->debug >= 10) {
+ (void)PerlIO_printf
+ (DBILOGFP, "dbdpg: Placeholder type: %d numsegs: %d numphs: %d\n",
+ imp_sth->placeholder_type, imp_sth->numsegs, imp_sth->numphs);
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Placeholder numbers, ph id, and segments:\n");
+ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: PH: (%d) ID: (%d) SEG: (%s)\n", currseg->placeholder, NULL==currseg->ph ? 0 : currseg->ph, currseg->segment);
+ }
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Placeholder number, fooname, id:\n");
+ for (xlen=1,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,xlen++) {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: #%d FOONAME: (%s) ID: (%d)\n", xlen, currph->fooname, currph);
+ }
+ }
+
+ DBIc_NUM_PARAMS(imp_sth) = imp_sth->numphs;
+
+} /* end dbd_st_split_statement */
+
+
+
+/* ================================================================== */
+static int dbd_st_prepare_statement (sth, imp_sth)
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+
+ D_imp_dbh_from_sth;
+ char *statement;
+ unsigned int x;
+ STRLEN execsize;
+ PGresult *result;
+ int status = -1;
+ seg_t *currseg;
+ bool oldprepare = DBDPG_TRUE;
+ int params = 0;
+ Oid *paramTypes = NULL;
+ ph_t *currph;
+
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_prepare_statement\n");
+
+#if PGLIBVERSION >= 80000
+ oldprepare = DBDPG_FALSE;
+#endif
+
+ Renew(imp_sth->prepare_name, 25, char); /* freed in dbd_st_destroy (and above) */
+
+ /* Name is simply "dbdpg_#" */
+ sprintf(imp_sth->prepare_name,"dbdpg_%d", imp_dbh->prepare_number);
+
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf
+ (DBILOGFP, "dbdpg: New statement name (%s), oldprepare is %d\n",
+ imp_sth->prepare_name, oldprepare);
+
+ /* PQprepare was not added until 8.0 */
+
+ execsize = imp_sth->totalsize;
+ if (oldprepare)
+ execsize += strlen("PREPARE AS ") + strlen(imp_sth->prepare_name); /* Two spaces! */
+
+ if (imp_sth->numphs!=0) {
+ if (oldprepare) {
+ execsize += strlen("()");
+ execsize += imp_sth->numphs-1; /* for the commas */
+ }
+ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) {
+ if (0==currseg->placeholder)
+ continue;
+ /* The parameter itself: dollar sign plus digit(s) */
+ for (x=1; x<7; x++) {
+ if (currseg->placeholder < pow((double)10,(double)x))
+ break;
+ }
+ if (x>=7)
+ croak("Too many placeholders!");
+ execsize += x+1;
+ if (oldprepare) {
+ /* The parameter type, only once per number please */
+ if (!currseg->ph->referenced)
+ execsize += strlen(currseg->ph->bind_type->type_name);
+ currseg->ph->referenced = DBDPG_TRUE;
+ }
+ }
+ }
+
+ New(0, statement, execsize+1, char); /* freed below */
+
+ if (oldprepare) {
+ sprintf(statement, "PREPARE %s", imp_sth->prepare_name);
+ if (imp_sth->numphs!=0) {
+ strcat(statement, "(");
+ for (x=0, currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) {
+ if (currseg->placeholder && currseg->ph->referenced) {
+ if (x!=0)
+ strcat(statement, ",");
+ strcat(statement, currseg->ph->bind_type->type_name);
+ x=1;
+ currseg->ph->referenced = DBDPG_FALSE;
+ }
+ }
+ strcat(statement, ")");
+ }
+ strcat(statement, " AS ");
+ }
+ else {
+ statement[0] = '\0';
+ }
+ /* Construct the statement, with proper placeholders */
+ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) {
+ strcat(statement, currseg->segment);
+ if (currseg->placeholder) {
+ sprintf(strchr(statement, '\0'), "$%d", currseg->placeholder);
+ }
+ }
+
+ statement[execsize] = '\0';
+
+ if (dbis->debug >= 6)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Prepared statement (%s)\n", statement);
+
+ if (oldprepare) {
+ status = _result(imp_dbh, statement);
+ }
+ else {
+ if (imp_sth->numbound!=0) {
+ params = imp_sth->numphs;
+ Newz(0, paramTypes, (unsigned)imp_sth->numphs, Oid);
+ for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph) {
+ paramTypes[x++] = (currph->defaultval) ? 0 : (Oid)currph->bind_type->type_id;
+ }
+ }
+ result = PQprepare(imp_dbh->conn, imp_sth->prepare_name, statement, params, paramTypes);
+ Safefree(paramTypes);
+ if (result)
+ status = PQresultStatus(result);
+ PQclear(result);
+ if (dbis->debug >= 6)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Using PQprepare: %s\n", statement);
+ }
+ Safefree(statement);
+ if (PGRES_COMMAND_OK != status) {
+ pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
+ return -2;
+ }
+
+ imp_sth->prepared_by_us = DBDPG_TRUE; /* Done here so deallocate is not called spuriously */
+ imp_dbh->prepare_number++; /* We do this at the end so we don't increment if we fail above */
+
+ return 0;
+
+} /* end of dbd_st_prepare_statement */
+
+
+
+/* ================================================================== */
+int dbd_bind_ph (sth, imp_sth, ph_name, newvalue, sql_type, attribs, is_inout, maxlen)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ SV *ph_name;
+ SV *newvalue;
+ IV sql_type;
+ SV *attribs;
+ int is_inout;
+ IV maxlen;
+{
+
+ char *name = Nullch;
+ STRLEN name_len;
+ ph_t *currph = NULL;
+ int x, phnum;
+ SV **svp;
+ bool reprepare = DBDPG_FALSE;
+ int pg_type = 0;
+ char *value_string = NULL;
+ maxlen = 0; /* not used */
+
+ if (dbis->debug >= 4) {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_bind_ph ph_name: (%s) newvalue: %s(%lu)\n",
+ neatsvpv(ph_name,0), neatsvpv(newvalue,0), SvOK(newvalue));
+ }
+
+ if (is_inout!=0)
+ croak("bind_inout not supported by this driver");
+
+ if (0==imp_sth->numphs) {
+ croak("Statement has no placeholders to bind");
+ }
+
+ /* Check the placeholder name and transform to a standard form */
+ if (SvGMAGICAL(ph_name)) {
+ (void)mg_get(ph_name);
+ }
+ name = SvPV(ph_name, name_len);
+ if (3==imp_sth->placeholder_type) {
+ if (':' != *name) {
+ croak("Placeholders must begin with ':' when using the \":foo\" style");
+ }
+ }
+ else {
+ for (x=0; *(name+x); x++) {
+ if (!isDIGIT(*(name+x)) && (x!=0 || '$'!=*(name+x))) {
+ croak("Placeholder should be in the format \"$1\"\n");
+ }
+ }
+ }
+
+ /* Find the placeholder in question */
+
+ if (3==imp_sth->placeholder_type) {
+ for (x=0,currph=imp_sth->ph; NULL != currph; currph = currph->nextph) {
+ if (0==strcmp(currph->fooname, name)) {
+ x=1;
+ break;
+ }
+ }
+ if (0==x)
+ croak("Cannot bind unknown placeholder '%s'", name);
+ }
+ else { /* We have a number */
+ if ('$' == *name)
+ *name++;
+ phnum = atoi(name);
+ if (phnum < 1 || phnum > imp_sth->numphs)
+ croak("Cannot bind unknown placeholder %d (%s)", phnum, neatsvpv(ph_name,0));
+ for (x=1,currph=imp_sth->ph; NULL != currph; currph = currph->nextph,x++) {
+ if (x==phnum)
+ break;
+ }
+ }
+
+ /* Check the value */
+ if (SvTYPE(newvalue) > SVt_PVLV) { /* hook for later array logic */
+ croak("Cannot bind a non-scalar value (%s)", neatsvpv(newvalue,0));
+ }
+ /* dbi handle allowed for cursor variables */
+ if ((SvROK(newvalue) &&!IS_DBI_HANDLE(newvalue) &&!SvAMAGIC(newvalue))) {
+ if (strnEQ("DBD::Pg::DefaultValue", neatsvpv(newvalue,0), 16)
+ || strnEQ("DBI::DefaultValue", neatsvpv(newvalue,0), 17)) {
+ /* This is a special type */
+ Safefree(currph->value);
+ currph->value = NULL;
+ currph->valuelen = 0;
+ currph->isdefault = DBDPG_TRUE;
+ imp_sth->has_default = DBDPG_TRUE;
+ }
+ else {
+ croak("Cannot bind a reference (%s) (%s) (%d) type=%d %d %d %d", neatsvpv(newvalue,0), SvAMAGIC(newvalue),
+ SvTYPE(SvRV(newvalue)) == SVt_PVAV ? 1 : 0, SvTYPE(newvalue), SVt_PVAV, SVt_PV, 0);
+ }
+ }
+ if (dbis->debug >= 5) {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Bind (%s) <== (%s) (type=%ld)", name, neatsvpv(newvalue,0), (long)sql_type);
+ if (attribs) {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Bind attribs (%s)", neatsvpv(attribs,0));
+ }
+ }
+
+ /* Check for a pg_type argument (sql_type already handled) */
+ if (attribs) {
+ if((svp = hv_fetch((HV*)SvRV(attribs),"pg_type", 7, 0)) != NULL)
+ pg_type = SvIV(*svp);
+ }
+
+ if (sql_type && pg_type)
+ croak ("Cannot specify both sql_type and pg_type");
+
+ if (NULL == currph->bind_type && (sql_type || pg_type))
+ imp_sth->numbound++;
+
+ if (pg_type) {
+ if ((currph->bind_type = pg_type_data(pg_type))) {
+ if (!currph->bind_type->bind_ok) { /* Re-evaluate with new prepare */
+ croak("Cannot bind %s, sql_type %s not supported by DBD::Pg",
+ name, currph->bind_type->type_name);
+ }
+ }
+ else {
+ croak("Cannot bind %s unknown pg_type %" IVdf, name, pg_type);
+ }
+ }
+ else if (sql_type) {
+ /* always bind as pg_type, because we know we are
+ inserting into a pg database... It would make no
+ sense to quote something to sql semantics and break
+ the insert.
+ */
+ if (!(currph->bind_type = sql_type_data((int)sql_type))) {
+ croak("Cannot bind %s unknown sql_type %" IVdf, name, sql_type);
+ }
+ if (!(currph->bind_type = pg_type_data(currph->bind_type->type.pg))) {
+ croak("Cannot find a pg_type for %" IVdf, sql_type);
+ }
+ }
+ else if (NULL == currph->bind_type) { /* "sticky" data type */
+ /* This is the default type, but we will honor defaultval if we can */
+ currph->bind_type = pg_type_data(UNKNOWNOID);
+ if (!currph->bind_type)
+ croak("Default type is bad!!!!???");
+ }
+
+ if (pg_type || sql_type) {
+ currph->defaultval = DBDPG_FALSE;
+ /* Possible re-prepare, depending on whether the type name also changes */
+ if (imp_sth->prepared_by_us && NULL != imp_sth->prepare_name)
+ reprepare = DBDPG_TRUE;
+ /* Mark this statement as having binary if the type is bytea */
+ if (BYTEAOID==currph->bind_type->type_id)
+ imp_sth->has_binary = DBDPG_TRUE;
+ }
+
+ if (currph->isdefault)
+ return 1;
+
+ /* convert to a string ASAP */
+ if (!SvPOK(newvalue) && SvOK(newvalue)) {
+ (void)sv_2pv(newvalue, &na);
+ }
+
+ /* upgrade to at least string */
+ (void)SvUPGRADE(newvalue, SVt_PV);
+
+ if (SvOK(newvalue)) {
+ value_string = SvPV(newvalue, currph->valuelen);
+ Renew(currph->value, currph->valuelen+1, char); /* freed in dbd_st_destroy (and above) */
+ Copy(value_string, currph->value, currph->valuelen, char);
+ currph->value[currph->valuelen] = '\0';
+ }
+ else {
+ Safefree(currph->value);
+ currph->value = NULL;
+ currph->valuelen = 0;
+ }
+
+ if (reprepare) {
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Binding has forced a re-prepare\n");
+ /* Deallocate sets the prepare_name to NULL */
+ if (dbd_st_deallocate_statement(sth, imp_sth)!=0) {
+ /* Deallocation failed. Let's mark it and move on */
+ Safefree(imp_sth->prepare_name);
+ imp_sth->prepare_name = NULL;
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Failed to deallocate!\n");
+ }
+ }
+
+ if (dbis->debug >= 10)
+ (void)PerlIO_printf
+ (DBILOGFP, "dbdpg: Placeholder (%s) bound as type (%s) (type_id=%d), length %d, value of (%s)\n",
+ name, currph->bind_type->type_name, currph->bind_type->type_id, currph->valuelen,
+ BYTEAOID==currph->bind_type->type_id ? "(binary, not shown)" : value_string);
+
+ return 1;
+
+} /* end of dbd_bind_ph */
+
+
+/* ================================================================== */
+int pg_quickexec (dbh, sql)
+ SV * dbh;
+ const char * sql;
+{
+ D_imp_dbh(dbh);
+ PGresult *result;
+ ExecStatusType status = PGRES_FATAL_ERROR; /* Assume the worst */
+ char *cmdStatus = NULL;
+ int rows = 0;
+
+ if (dbis->debug >= 4) (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_quickexec (%s)\n", sql);
+
+ if (NULL == imp_dbh->conn)
+ croak("execute on disconnected handle");
+
+ /* Abort if we are in the middle of a copy */
+ if (imp_dbh->copystate!=0)
+ croak("Must call pg_endcopy before issuing more commands");
+
+ /* If not autocommit, start a new transaction */
+ if (!imp_dbh->done_begin && !DBIc_has(imp_dbh, DBIcf_AutoCommit)) {
+ status = _result(imp_dbh, "begin");
+ if (PGRES_COMMAND_OK != status) {
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ return -2;
+ }
+ imp_dbh->done_begin = DBDPG_TRUE;
+ }
+
+ result = PQexec(imp_dbh->conn, sql);
+ status = _sqlstate(imp_dbh, result);
+
+ imp_dbh->copystate = 0; /* Assume not in copy mode until told otherwise */
+
+ switch (status) {
+ case PGRES_TUPLES_OK:
+ rows = PQntuples(result);
+ break;
+ case PGRES_COMMAND_OK:
+ /* non-select statement */
+ cmdStatus = PQcmdStatus(result);
+ if ((0==strncmp(cmdStatus, "DELETE", 6)) || (0==strncmp(cmdStatus, "INSERT", 6)) ||
+ (0==strncmp(cmdStatus, "UPDATE", 6))) {
+ rows = atoi(PQcmdTuples(result));
+ }
+ break;
+ case PGRES_COPY_OUT:
+ case PGRES_COPY_IN:
+ /* Copy Out/In data transfer in progress */
+ imp_dbh->copystate = status;
+ rows = -1;
+ break;
+ case PGRES_EMPTY_QUERY:
+ case PGRES_BAD_RESPONSE:
+ case PGRES_NONFATAL_ERROR:
+ rows = -2;
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ break;
+ case PGRES_FATAL_ERROR:
+ default:
+ rows = -2;
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ break;
+ }
+
+ if (result)
+ PQclear(result);
+ else
+ return -2;
+
+ return rows;
+
+} /* end of pg_quickexec */
+
+
+/* ================================================================== */
+int dbd_st_execute (sth, imp_sth) /* <= -2:error, >=0:ok row count, (-1=unknown count) */
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+
+ D_imp_dbh_from_sth;
+ ph_t *currph;
+ int status = -1;
+ STRLEN execsize, x;
+ const char **paramValues = NULL;
+ int *paramLengths = NULL, *paramFormats = NULL;
+ Oid *paramTypes = NULL;
+ seg_t *currseg;
+ char *statement = NULL, *cmdStatus = NULL;
+ int num_fields, ret = -2;
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_execute\n"); }
+
+ if (NULL == imp_dbh->conn)
+ croak("execute on disconnected handle");
+
+ /* Abort if we are in the middle of a copy */
+ if (imp_dbh->copystate!=0)
+ croak("Must call pg_endcopy before issuing more commands");
+
+ /* Ensure that all the placeholders have been bound */
+ if (imp_sth->numphs!=0) {
+ for (currph=imp_sth->ph; NULL != currph; currph=currph->nextph) {
+ if (NULL == currph->bind_type) {
+ pg_error(sth, PGRES_FATAL_ERROR, "execute called with an unbound placeholder");
+ return -2;
+ }
+ }
+ }
+
+ /* If not autocommit, start a new transaction */
+ if (!imp_dbh->done_begin && !DBIc_has(imp_dbh, DBIcf_AutoCommit)) {
+ status = _result(imp_dbh, "begin");
+ if (PGRES_COMMAND_OK != status) {
+ pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
+ return -2;
+ }
+ imp_dbh->done_begin = DBDPG_TRUE;
+ }
+
+ /* clear old result (if any) */
+ if (imp_sth->result != NULL)
+ PQclear(imp_sth->result);
+
+ /*
+ Now, we need to build the statement to send to the backend
+ We are using one of PQexec, PQexecPrepared, or PQexecParams
+ First, we figure out the size of the statement...
+ */
+
+ execsize = imp_sth->totalsize; /* Total of all segments */
+
+ /* If using plain old PQexec, we need to quote each value ourselves */
+ if (imp_dbh->pg_protocol < 3 ||
+ imp_sth->has_default ||
+ (1 != imp_sth->server_prepare &&
+ imp_sth->numbound != imp_sth->numphs)) {
+ for (currph=imp_sth->ph; NULL != currph; currph=currph->nextph) {
+ if (currph->isdefault) {
+ Renew(currph->quoted, 8, char); /* freed in dbd_st_destroy */
+ strncpy(currph->quoted, "DEFAULT\0", 8);
+ currph->quotedlen = 7;
+ }
+ else if (NULL == currph->value) {
+ Renew(currph->quoted, 5, char); /* freed in dbd_st_destroy */
+ strncpy(currph->quoted, "NULL\0", 5);
+ currph->quotedlen = 4;
+ }
+ else {
+ if (currph->quoted)
+ Safefree(currph->quoted);
+ currph->quoted = currph->bind_type->quote
+ (currph->value, currph->valuelen, &currph->quotedlen); /* freed in dbd_st_destroy */
+ }
+ }
+ /* Set the size of each actual in-place placeholder */
+ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) {
+ if (currseg->placeholder!=0)
+ execsize += currseg->ph->quotedlen;
+ }
+ }
+ else { /* We are using a server that can handle PQexecParams/PQexecPrepared */
+ /* Put all values into an array to pass to PQexecPrepared */
+ Newz(0, paramValues, (unsigned)imp_sth->numphs, const char *); /* freed below */
+ for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph) {
+ paramValues[x++] = currph->value;
+ }
+
+ /* Binary or regular? */
+
+ if (imp_sth->has_binary) {
+ Newz(0, paramLengths, (unsigned)imp_sth->numphs, int); /* freed below */
+ Newz(0, paramFormats, (unsigned)imp_sth->numphs, int); /* freed below */
+ for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,x++) {
+ if (BYTEAOID==currph->bind_type->type_id) {
+ paramLengths[x] = (int)currph->valuelen;
+ paramFormats[x] = 1;
+ }
+ else {
+ paramLengths[x] = 0;
+ paramFormats[x] = 0;
+ }
+ }
+ }
+ }
+
+ /* We use the new server_side prepare style if:
+ 1. The statement is DML
+ 2. The attribute "pg_direct" is false
+ 3. We can handle server-side prepares
+ 4. The attribute "pg_server_prepare" is not 0
+ 5. There is one or more placeholders
+ 6. There are no DEFAULT values
+ 7a. The attribute "pg_server_prepare" is 1
+ OR
+ 7b. All placeholders are bound (and "pg_server_prepare" is 2)
+ */
+ if (dbis->debug >= 6) {
+ (void)PerlIO_printf
+ (DBILOGFP, "dbdpg: PQexec* decision: dml=%d direct=%d protocol=%d server_prepare=%d numbound=%d numphs=%d default=%d\n",
+ imp_sth->is_dml, imp_sth->direct, imp_dbh->pg_protocol, imp_sth->server_prepare, imp_sth->numbound, imp_sth->numphs, imp_sth->has_default);
+ }
+ if (imp_sth->is_dml &&
+ !imp_sth->direct &&
+ imp_dbh->pg_protocol >= 3 &&
+ 0 != imp_sth->server_prepare &&
+ !imp_sth->has_default &&
+ (1 <= imp_sth->numphs && !imp_sth->onetime) &&
+ (1 == imp_sth->server_prepare ||
+ (imp_sth->numbound == imp_sth->numphs)
+ )){
+
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: PQexecPrepared\n");
+
+ /* Prepare if it has not already been prepared (or it needs repreparing) */
+ if (NULL == imp_sth->prepare_name) {
+ if (imp_sth->prepared_by_us) {
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Re-preparing statement\n");
+ }
+ if (dbd_st_prepare_statement(sth, imp_sth)!=0) {
+ Safefree(paramValues);
+ Safefree(paramLengths);
+ Safefree(paramFormats);
+ return -2;
+ }
+ }
+ else {
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Using previously prepared statement (%s)\n", imp_sth->prepare_name);
+ }
+
+ if (dbis->debug >= 10) {
+ for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,x++) {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: PQexecPrepared item #%d\n", x);
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: -> Value: (%s)\n", paramValues[x]);
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: -> Length: (%d)\n", paramLengths ? paramLengths[x] : 0);
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: -> Format: (%d)\n", paramFormats ? paramFormats[x] : 0);
+ }
+ }
+
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Running PQexecPrepared with (%s)\n", imp_sth->prepare_name);
+ imp_sth->result = PQexecPrepared
+ (imp_dbh->conn, imp_sth->prepare_name, imp_sth->numphs, paramValues, paramLengths, paramFormats, 0);
+
+ } /* end new-style prepare */
+ else {
+
+ /* prepare via PQexec or PQexecParams */
+
+
+ /* PQexecParams */
+
+ if (imp_dbh->pg_protocol >= 3 &&
+ imp_sth->numphs &&
+ !imp_sth->has_default &&
+ (1 == imp_sth->server_prepare ||
+ imp_sth->numbound == imp_sth->numphs)) {
+
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: PQexecParams\n");
+
+ /* Figure out how big the statement plus placeholders will be */
+ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) {
+ if (0==currseg->placeholder)
+ continue;
+ /* The parameter itself: dollar sign plus digit(s) */
+ for (x=1; x<7; x++) {
+ if (currseg->placeholder < pow((double)10,(double)x))
+ break;
+ }
+ if (x>=7)
+ croak("Too many placeholders!");
+ execsize += x+1;
+ }
+
+ /* Create the statement */
+ New(0, statement, execsize+1, char); /* freed below */
+ statement[0] = '\0';
+ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) {
+ strcat(statement, currseg->segment);
+ if (currseg->placeholder!=0)
+ sprintf(strchr(statement, '\0'), "$%d", currseg->placeholder);
+ }
+ statement[execsize] = '\0';
+
+ /* Populate paramTypes */
+ Newz(0, paramTypes, (unsigned)imp_sth->numphs, Oid);
+ for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph) {
+ paramTypes[x++] = (currph->defaultval) ? 0 : (Oid)currph->bind_type->type_id;
+ }
+
+ if (dbis->debug >= 10) {
+ for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,x++) {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: PQexecParams item #%d\n", x);
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: -> Type: (%d)\n", paramTypes[x]);
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: -> Value: (%s)\n", paramValues[x]);
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: -> Length: (%d)\n", paramLengths ? paramLengths[x] : 0);
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: -> Format: (%d)\n", paramFormats ? paramFormats[x] : 0);
+ }
+ }
+
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Running PQexecParams with (%s)\n", statement);
+ imp_sth->result = PQexecParams
+ (imp_dbh->conn, statement, imp_sth->numphs, paramTypes, paramValues, paramLengths, paramFormats, 0);
+ Safefree(paramTypes);
+ }
+
+ /* PQexec */
+
+ else {
+
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: PQexec\n");
+
+ /* Go through and quote each value, then turn into a giant statement */
+ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) {
+ if (currseg->placeholder!=0)
+ execsize += currseg->ph->quotedlen;
+ }
+ New(0, statement, execsize+1, char); /* freed below */
+ statement[0] = '\0';
+ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) {
+ strcat(statement, currseg->segment);
+ if (currseg->placeholder!=0)
+ strcat(statement, currseg->ph->quoted);
+ }
+ statement[execsize] = '\0';
+
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Running PQexec with (%s)\n", statement);
+
+ imp_sth->result = PQexec(imp_dbh->conn, statement);
+
+ } /* end PQexec */
+
+ Safefree(statement);
+
+ } /* end non-prepared exec */
+
+ /* Some form of PQexec has been run at this point */
+
+ status = _sqlstate(imp_dbh, imp_sth->result);
+
+ Safefree(paramValues);
+ Safefree(paramLengths);
+ Safefree(paramFormats);
+
+ imp_dbh->copystate = 0; /* Assume not in copy mode until told otherwise */
+ if (PGRES_TUPLES_OK == status) {
+ num_fields = PQnfields(imp_sth->result);
+ imp_sth->cur_tuple = 0;
+ DBIc_NUM_FIELDS(imp_sth) = num_fields;
+ DBIc_ACTIVE_on(imp_sth);
+ ret = PQntuples(imp_sth->result);
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf
+ (DBILOGFP, "dbdpg: Status was PGRES_TUPLES_OK, fields=%d, tuples=%d\n",
+ num_fields, ret);
+ }
+ else if (PGRES_COMMAND_OK == status) {
+ /* non-select statement */
+ if (imp_sth->result) {
+ cmdStatus = PQcmdStatus(imp_sth->result);
+ }
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Status was PGRES_COMMAND_OK\n");
+ if ((0==strncmp(cmdStatus, "DELETE", 6)) || (0==strncmp(cmdStatus, "INSERT", 6)) ||
+ (0==strncmp(cmdStatus, "UPDATE", 6))) {
+ ret = atoi(PQcmdTuples(imp_sth->result));
+ }
+ else {
+ /* We assume that no rows are affected for successful commands (e.g. ALTER TABLE) */
+ return 0;
+ }
+ }
+ else if (PGRES_COPY_OUT == status || PGRES_COPY_IN == status) {
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Status was PGRES_COPY_%s\n",
+ PGRES_COPY_OUT == status ? "OUT" : "IN");
+ /* Copy Out/In data transfer in progress */
+ imp_dbh->copystate = status;
+ return -1;
+ }
+ else {
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Invalid status returned (%d)\n", status);
+ pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
+ return -2;
+ }
+
+ /* store the number of affected rows */
+
+ imp_sth->rows = ret;
+
+ return ret;
+
+} /* end of dbd_st_execute */
+
+
+/* ================================================================== */
+static int is_high_bit_set(val)
+ char *val;
+{
+ while (*val)
+ if (*val++ & 0x80) return 1;
+ return 0;
+}
+
+
+/* ================================================================== */
+AV * dbd_st_fetch (sth, imp_sth)
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+ sql_type_info_t *type_info;
+ int num_fields;
+ char *value;
+ char *p;
+ int i, chopblanks;
+ STRLEN value_len = 0;
+ STRLEN len;
+ AV *av;
+ D_imp_dbh_from_sth;
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_fetch\n"); }
+
+ /* Check that execute() was executed successfully */
+ if ( !DBIc_ACTIVE(imp_sth) ) {
+ pg_error(sth, PGRES_NONFATAL_ERROR, "no statement executing\n");
+ return Nullav;
+ }
+
+ if (imp_sth->cur_tuple == PQntuples(imp_sth->result) ) {
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Fetched the last tuple (%d)\n", imp_sth->cur_tuple);
+ imp_sth->cur_tuple = 0;
+ DBIc_ACTIVE_off(imp_sth);
+ return Nullav; /* we reached the last tuple */
+ }
+
+ av = DBIS->get_fbav(imp_sth);
+ num_fields = AvFILL(av)+1;
+
+ chopblanks = DBIc_has(imp_sth, DBIcf_ChopBlanks);
+
+ /* Set up the type_info array if we have not seen it yet */
+ if (NULL == imp_sth->type_info) {
+ Newz(0, imp_sth->type_info, (unsigned)num_fields, sql_type_info_t*); /* freed in dbd_st_destroy */
+ for (i = 0; i < num_fields; ++i) {
+ imp_sth->type_info[i] = pg_type_data((int)PQftype(imp_sth->result, i));
+ }
+ }
+
+ for (i = 0; i < num_fields; ++i) {
+ SV *sv;
+
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Fetching a field\n");
+
+ sv = AvARRAY(av)[i];
+ if (PQgetisnull(imp_sth->result, imp_sth->cur_tuple, i)!=0) {
+ SvROK(sv) ? (void)sv_unref(sv) : (void)SvOK_off(sv);
+ }
+ else {
+ value = (char*)PQgetvalue(imp_sth->result, imp_sth->cur_tuple, i);
+ type_info = imp_sth->type_info[i];
+
+ if (type_info) {
+ type_info->dequote(value, &value_len); /* dequote in place */
+ if (BOOLOID == type_info->type_id && imp_dbh->pg_bool_tf)
+ *value = ('1' == *value) ? 't' : 'f';
+ }
+ else
+ value_len = strlen(value);
+
+ sv_setpvn(sv, value, value_len);
+
+ if (type_info && (BPCHAROID == type_info->type_id) && chopblanks)
+ {
+ p = SvEND(sv);
+ len = SvCUR(sv);
+ while(len && ' ' == *--p)
+ --len;
+ if (len != SvCUR(sv)) {
+ SvCUR_set(sv, len);
+ *SvEND(sv) = '\0';
+ }
+ }
+
+#ifdef is_utf8_string
+ if (imp_dbh->pg_enable_utf8 && type_info) {
+ SvUTF8_off(sv);
+ switch (type_info->type_id) {
+ case CHAROID:
+ case TEXTOID:
+ case BPCHAROID:
+ case VARCHAROID:
+ if (is_high_bit_set(value) && is_utf8_string((unsigned char*)value, value_len)) {
+ SvUTF8_on(sv);
+ }
+ break;
+ default:
+ break;
+ }
+ }
+#endif
+ }
+ }
+
+ imp_sth->cur_tuple += 1;
+
+ return av;
+
+} /* end of dbd_st_fetch */
+
+
+/* ================================================================== */
+int dbd_st_rows (sth, imp_sth)
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_rows sth=%d\n", sth); }
+
+ return imp_sth->rows;
+
+} /* end of dbd_st_rows */
+
+
+/* ================================================================== */
+int dbd_st_finish (sth, imp_sth)
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_finish sth=%d\n", sth); }
+
+ if (DBIc_ACTIVE(imp_sth) && imp_sth->result) {
+ PQclear(imp_sth->result);
+ imp_sth->result = NULL;
+ imp_sth->rows = 0;
+ }
+
+ DBIc_ACTIVE_off(imp_sth);
+ return 1;
+
+} /* end of sbs_st_finish */
+
+
+/* ================================================================== */
+static int dbd_st_deallocate_statement (sth, imp_sth)
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+ char tempsqlstate[6];
+ char *stmt;
+ int status;
+ PGTransactionStatusType tstatus;
+ D_imp_dbh_from_sth;
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_deallocate_statement\n"); }
+
+ if (NULL == imp_dbh->conn || NULL == imp_sth->prepare_name)
+ return 0;
+
+ tempsqlstate[0] = '\0';
+
+ /* What is our status? */
+ tstatus = dbd_db_txn_status(imp_dbh);
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Transaction status is %d\n", tstatus);
+
+ /* If we are in a failed transaction, rollback before deallocating */
+ if (PQTRANS_INERROR == tstatus) {
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Issuing rollback before deallocate\n");
+ {
+ /* If a savepoint has been set, rollback to the last savepoint instead of the entire transaction */
+ I32 alen = av_len(imp_dbh->savepoints);
+ if (alen > -1) {
+ SV *sp = Nullsv;
+ char *cmd;
+ sp = *av_fetch(imp_dbh->savepoints, alen, 0);
+ New(0, cmd, SvLEN(sp) + 13, char); /* Freed below */
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Rolling back to savepoint %s\n", SvPV_nolen(sp));
+ sprintf(cmd,"rollback to %s",SvPV_nolen(sp));
+ strncpy(tempsqlstate, imp_dbh->sqlstate, strlen(imp_dbh->sqlstate)+1);
+ status = _result(imp_dbh, cmd);
+ Safefree(cmd);
+ }
+ else {
+ status = _result(imp_dbh, "ROLLBACK");
+ imp_dbh->done_begin = DBDPG_FALSE;
+ }
+ }
+ if (PGRES_COMMAND_OK != status) {
+ /* This is not fatal, it just means we cannot deallocate */
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Rollback failed, so no deallocate\n");
+ return 1;
+ }
+ }
+
+ New(0, stmt, strlen("DEALLOCATE ") + strlen(imp_sth->prepare_name) + 1, char); /* freed below */
+
+ sprintf(stmt, "DEALLOCATE %s", imp_sth->prepare_name);
+
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Deallocating (%s)\n", imp_sth->prepare_name);
+
+ status = _result(imp_dbh, stmt);
+ Safefree(stmt);
+ if (PGRES_COMMAND_OK != status) {
+ pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
+ return 2;
+ }
+
+ Safefree(imp_sth->prepare_name);
+ imp_sth->prepare_name = NULL;
+ if (tempsqlstate[0]) {
+ strncpy(imp_dbh->sqlstate, tempsqlstate, strlen(tempsqlstate)+1);
+ }
+
+ return 0;
+
+} /* end of dbd_st_deallocate_statement */
+
+
+/* ================================================================== */
+void dbd_st_destroy (sth, imp_sth)
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+
+ seg_t *currseg, *nextseg;
+ ph_t *currph, *nextph;
+ D_imp_dbh_from_sth;
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_destroy\n"); }
+
+ if (NULL == imp_sth->seg) /* Already been destroyed! */
+ croak("dbd_st_destroy called twice!");
+
+ /* If the InactiveDestroy flag has been set, we go no further */
+ if (DBIc_IADESTROY(imp_dbh)) {
+ if (dbis->debug >= 4) {
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: skipping sth destroy due to InactiveDestroy\n");
+ }
+ DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */
+ return;
+ }
+
+ /* Deallocate only if we named this statement ourselves and we still have a good connection */
+ /* On rare occasions, dbd_db_destroy is called first and we can no longer rely on imp_dbh */
+ if (imp_sth->prepared_by_us && DBIc_ACTIVE(imp_dbh)) {
+ if (dbd_st_deallocate_statement(sth, imp_sth)!=0) {
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Could not deallocate\n");
+ }
+ }
+
+ Safefree(imp_sth->prepare_name);
+ Safefree(imp_sth->type_info);
+ Safefree(imp_sth->firstword);
+
+ if (NULL != imp_sth->result) {
+ PQclear(imp_sth->result);
+ imp_sth->result = NULL;
+ }
+
+ /* Free all the segments */
+ currseg = imp_sth->seg;
+ while (NULL != currseg) {
+ Safefree(currseg->segment);
+ currseg->ph = NULL;
+ nextseg = currseg->nextseg;
+ Safefree(currseg);
+ currseg = nextseg;
+ }
+ imp_sth->seg = NULL;
+
+ /* Free all the placeholders */
+ currph = imp_sth->ph;
+ while (NULL != currph) {
+ Safefree(currph->fooname);
+ Safefree(currph->value);
+ Safefree(currph->quoted);
+ currph->bind_type = NULL;
+ nextph = currph->nextph;
+ Safefree(currph);
+ currph = nextph;
+ }
+ imp_sth->ph = NULL;
+
+ DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */
+
+} /* end of dbd_st_destroy */
+
+
+/* ================================================================== */
+int dbd_st_STORE_attrib (sth, imp_sth, keysv, valuesv)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ SV *keysv;
+ SV *valuesv;
+{
+ STRLEN kl;
+ char *key = SvPV(keysv,kl);
+ STRLEN vl;
+ char *value = SvPV(valuesv,vl);
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_STORE (%s) (%s) sth=%d\n", key, value, sth); }
+
+ if (17==kl && strEQ(key, "pg_server_prepare")) {
+ imp_sth->server_prepare = strEQ(value,"0") ? DBDPG_FALSE : DBDPG_TRUE;
+ }
+ else if (14==kl && strEQ(key, "pg_prepare_now")) {
+ imp_sth->prepare_now = strEQ(value,"0") ? DBDPG_FALSE : DBDPG_TRUE;
+ }
+ else if (15==kl && strEQ(key, "pg_prepare_name")) {
+ Safefree(imp_sth->prepare_name);
+ New(0, imp_sth->prepare_name, vl+1, char); /* freed in dbd_st_destroy (and above) */
+ Copy(value, imp_sth->prepare_name, vl, char);
+ imp_sth->prepare_name[vl] = '\0';
+ }
+ return 0;
+
+} /* end of sbs_st_STORE_attrib */
+
+
+/* ================================================================== */
+SV * dbd_st_FETCH_attrib (sth, imp_sth, keysv)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ SV *keysv;
+{
+ STRLEN kl;
+ char *key = SvPV(keysv,kl);
+ int i, x, y, sz;
+ SV *retsv = Nullsv;
+ sql_type_info_t *type_info;
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_FETCH (%s) sth=%d\n", key, sth); }
+
+ /* Some can be done before the execute */
+ if (15==kl && strEQ(key, "pg_prepare_name")) {
+ retsv = newSVpv((char *)imp_sth->prepare_name, 0);
+ return retsv;
+ }
+ else if (17==kl && strEQ(key, "pg_server_prepare")) {
+ retsv = newSViv((IV)imp_sth->server_prepare);
+ return retsv;
+ }
+ else if (14==kl && strEQ(key, "pg_prepare_now")) {
+ retsv = newSViv((IV)imp_sth->prepare_now);
+ return retsv;
+ }
+ else if (11==kl && strEQ(key, "ParamValues")) {
+ HV *pvhv = newHV();
+ ph_t *currph;
+ for (i=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,i++) {
+ if (NULL == currph->value) {
+ (void)hv_store_ent
+ (pvhv, 3==imp_sth->placeholder_type ? newSVpv(currph->fooname,0) :
+ newSViv(i+1), Nullsv, (unsigned)i);
+ }
+ else {
+ (void)hv_store_ent
+ (pvhv, 3==imp_sth->placeholder_type ? newSVpv(currph->fooname,0) :
+ newSViv(i+1), newSVpv(currph->value,0),(unsigned)i);
+ }
+ }
+ retsv = newRV_noinc((SV*)pvhv);
+ return retsv;
+ }
+ else if (11==kl && strEQ(key, "pg_segments")) {
+ AV *arr = newAV();
+ seg_t *currseg;
+ for (i=0,currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg,i++) {
+ av_push(arr, newSVpv(currseg->segment ? currseg->segment : "NULL",0));
+ }
+ retsv = newRV_noinc((SV*)arr);
+ return retsv;
+ }
+
+ if (! imp_sth->result) {
+ return Nullsv;
+ }
+ i = DBIc_NUM_FIELDS(imp_sth);
+
+ if (4==kl && strEQ(key, "NAME")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ (void)av_store(av, i, newSVpv(PQfname(imp_sth->result, i),0));
+ }
+ }
+ else if (4==kl && strEQ(key, "TYPE")) {
+ /* Need to convert the Pg type to ANSI/SQL type. */
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ type_info = pg_type_data((int)PQftype(imp_sth->result, i));
+ (void)av_store(av, i, newSViv( type_info ? type_info->type.sql : 0 ) );
+ }
+ }
+ else if (9==kl && strEQ(key, "PRECISION")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ x = PQftype(imp_sth->result, i);
+ switch (x) {
+ case BPCHAROID:
+ case VARCHAROID:
+ sz = PQfmod(imp_sth->result, i);
+ break;
+ case NUMERICOID:
+ sz = PQfmod(imp_sth->result, i)-4;
+ if (sz > 0)
+ sz = sz >> 16;
+ break;
+ default:
+ sz = PQfsize(imp_sth->result, i);
+ break;
+ }
+ (void)av_store(av, i, sz > 0 ? newSViv(sz) : &sv_undef);
+ }
+ }
+ else if (5==kl && strEQ(key, "SCALE")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ x = PQftype(imp_sth->result, i);
+ if (NUMERICOID==x) {
+ x = PQfmod(imp_sth->result, i)-4;
+ (void)av_store(av, i, newSViv(x % (x>>16)));
+ }
+ else {
+ (void)av_store(av, i, &sv_undef);
+ }
+ }
+ }
+ else if (8==kl && strEQ(key, "NULLABLE")) {
+ AV *av = newAV();
+ PGresult *result;
+ int status = -1;
+ D_imp_dbh_from_sth;
+ char *statement;
+ int nullable; /* 0 = not nullable, 1 = nullable 2 = unknown */
+ retsv = newRV(sv_2mortal((SV*)av));
+
+ New(0, statement, 100, char); /* freed below */
+ statement[0] = '\0';
+ while(--i >= 0) {
+ nullable=2;
+ x = PQftable(imp_sth->result, i);
+ y = PQftablecol(imp_sth->result, i);
+ if (InvalidOid != x && y > 0) { /* We know what table and column this came from */
+ sprintf(statement, "SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid=%d AND attnum=%d", x, y);
+ statement[strlen(statement)]='\0';
+ result = PQexec(imp_dbh->conn, statement);
+ status = PQresultStatus(result);
+ if (PGRES_TUPLES_OK == status && PQntuples(result)!=0) {
+ switch (PQgetvalue(result,0,0)[0]) {
+ case 't':
+ nullable = 0;
+ break;
+ case 'f':
+ default:
+ nullable = 1;
+ break;
+ }
+ }
+ PQclear(result);
+ }
+ (void)av_store(av, i, newSViv(nullable));
+ }
+ Safefree(statement);
+ }
+ else if (10==kl && strEQ(key, "CursorName")) {
+ retsv = &sv_undef;
+ }
+ else if (11==kl && strEQ(key, "RowsInCache")) {
+ retsv = &sv_undef;
+ }
+ else if (7==kl && strEQ(key, "pg_size")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ (void)av_store(av, i, newSViv(PQfsize(imp_sth->result, i)));
+ }
+ }
+ else if (7==kl && strEQ(key, "pg_type")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ type_info = pg_type_data((int)PQftype(imp_sth->result,i));
+ (void)av_store(av, i, newSVpv(type_info ? type_info->type_name : "unkown", 0));
+ }
+ }
+ else if (13==kl && strEQ(key, "pg_oid_status")) {
+ retsv = newSViv((int)PQoidValue(imp_sth->result));
+ }
+ else if (13==kl && strEQ(key, "pg_cmd_status")) {
+ retsv = newSVpv((char *)PQcmdStatus(imp_sth->result), 0);
+ }
+ else {
+ return Nullsv;
+ }
+
+ return sv_2mortal(retsv);
+
+} /* end of dbd_st_FETCH_attrib */
+
+
+/* ================================================================== */
+int
+pg_db_putline (dbh, buffer)
+ SV *dbh;
+ const char *buffer;
+{
+ D_imp_dbh(dbh);
+ int copystatus;
+
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_putline\n");
+
+ /* We must be in COPY IN state */
+ if (PGRES_COPY_IN != imp_dbh->copystate)
+ croak("pg_putline can only be called directly after issuing a COPY IN command\n");
+
+#if PGLIBVERSION < 70400
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Running PQputline\n");
+ copystatus = 0; /* Make compilers happy */
+ return PQputline(imp_dbh->conn, buffer);
+#else
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Running PQputCopyData\n");
+
+ copystatus = PQputCopyData(imp_dbh->conn, buffer, (int)strlen(buffer));
+ if (-1 == copystatus) {
+ pg_error(dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+ else if (1 != copystatus) {
+ croak("PQputCopyData gave a value of %d\n", copystatus);
+ }
+ return 0;
+#endif
+}
+
+
+/* ================================================================== */
+int
+pg_db_getline (dbh, buffer, length)
+ SV * dbh;
+ char * buffer;
+ int length;
+{
+ D_imp_dbh(dbh);
+ int copystatus;
+ char * tempbuf;
+
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_getline\n");
+
+ tempbuf = NULL;
+
+ /* We must be in COPY OUT state */
+ if (PGRES_COPY_OUT != imp_dbh->copystate)
+ croak("pg_getline can only be called directly after issuing a COPY OUT command\n");
+
+#if PGLIBVERSION < 70400
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Running PQgetline (%d)\n", length);
+ copystatus = PQgetline(imp_dbh->conn, buffer, length);
+ if (copystatus < 0 || (*buffer == '\\' && *(buffer+1) == '.')) {
+ imp_dbh->copystate=0;
+ PQendcopy(imp_dbh->conn);
+ return -1;
+ }
+ return copystatus;
+#else
+ length = 0; /* Make compilers happy */
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Running PQgetCopyData\n");
+ copystatus = PQgetCopyData(imp_dbh->conn, &tempbuf, 0);
+
+ if (-1 == copystatus) {
+ *buffer = '\0';
+ imp_dbh->copystate=0;
+ PQendcopy(imp_dbh->conn); /* Can't hurt */
+ return -1;
+ }
+ else if (copystatus < 1) {
+ pg_error(dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn));
+ }
+ else {
+ strncpy(buffer, tempbuf, strlen(tempbuf)+1);
+ buffer[strlen(tempbuf)] = '\0';
+ PQfreemem(tempbuf);
+ }
+ return 0;
+#endif
+
+}
+
+
+/* ================================================================== */
+int
+pg_db_endcopy (dbh)
+ SV *dbh;
+{
+ D_imp_dbh(dbh);
+ int copystatus;
+ PGresult *result;
+ ExecStatusType status;
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_pg_endcopy\n"); }
+
+ if (0==imp_dbh->copystate)
+ croak("pg_endcopy cannot be called until a COPY is issued");
+
+#if PGLIBVERSION < 70400
+ if (PGRES_COPY_IN == imp_dbh->copystate) {
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Running PQputline with (\\\\.\\n)\n");
+ PQputline(imp_dbh->conn, "\\.\n");
+ }
+ result = 0; /* Make compiler happy */
+ copystatus = PQendcopy(imp_dbh->conn);
+#else
+ if (PGRES_COPY_IN == imp_dbh->copystate) {
+ if (dbis->debug >= 5)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: Running PQputCopyEnd\n");
+ copystatus = PQputCopyEnd(imp_dbh->conn, NULL);
+ if (-1 == copystatus) {
+ pg_error(dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn));
+ return 1;
+ }
+ else if (1 != copystatus)
+ croak("PQputCopyEnd returned a value of %d\n", copystatus);
+ /* Get the final result of the copy */
+ result = PQgetResult(imp_dbh->conn);
+ status = _sqlstate(imp_dbh, result);
+ PQclear(result);
+ if (PGRES_COMMAND_OK != status) {
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ return 1;
+ }
+ copystatus = 0;
+ }
+ else {
+ copystatus = PQendcopy(imp_dbh->conn);
+ }
+#endif
+ imp_dbh->copystate = 0;
+ return copystatus;
+}
+
+
+/* ================================================================== */
+void
+pg_db_pg_server_trace (dbh, fh)
+ SV *dbh;
+ FILE *fh;
+{
+ D_imp_dbh(dbh);
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_pg_server_trace\n"); }
+
+ PQtrace(imp_dbh->conn, fh);
+}
+
+
+/* ================================================================== */
+void
+pg_db_pg_server_untrace (dbh)
+ SV *dbh;
+{
+ D_imp_dbh(dbh);
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_pg_server_untrace\n"); }
+
+ PQuntrace(imp_dbh->conn);
+}
+
+
+/* ================================================================== */
+int
+pg_db_savepoint (dbh, imp_dbh, savepoint)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+ char * savepoint;
+{
+ int status;
+ char *action;
+
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_savepoint (%s)\n", savepoint);
+
+ New(0, action, strlen(savepoint) + 11, char); /* freed below */
+
+ if (imp_dbh->pg_server_version < 80000)
+ croak("Savepoints are only supported on server version 8.0 or higher");
+
+ sprintf(action, "savepoint %s", savepoint);
+
+ /* no action if AutoCommit = on or the connection is invalid */
+ if ((NULL == imp_dbh->conn) || (DBIc_has(imp_dbh, DBIcf_AutoCommit)))
+ return 0;
+
+ /* Start a new transaction if this is the first command */
+ if (!imp_dbh->done_begin) {
+ status = _result(imp_dbh, "begin");
+ if (PGRES_COMMAND_OK != status) {
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ return -2;
+ }
+ imp_dbh->done_begin = DBDPG_TRUE;
+ }
+
+ status = _result(imp_dbh, action);
+ Safefree(action);
+
+ if (PGRES_COMMAND_OK != status) {
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+
+ av_push(imp_dbh->savepoints, newSVpv(savepoint,0));
+ return 1;
+}
+
+
+/* ================================================================== */
+int pg_db_rollback_to (dbh, imp_dbh, savepoint)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+ char * savepoint;
+{
+ int status;
+ I32 i;
+ char *action;
+
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_rollback_to (%s)\n", savepoint);
+
+ New(0, action, strlen(savepoint) + 13, char);
+
+ if (imp_dbh->pg_server_version < 80000)
+ croak("Savepoints are only supported on server version 8.0 or higher");
+
+ sprintf(action,"rollback to %s",savepoint);
+
+ /* no action if AutoCommit = on or the connection is invalid */
+ if ((NULL == imp_dbh->conn) || (DBIc_has(imp_dbh, DBIcf_AutoCommit)))
+ return 0;
+
+ status = _result(imp_dbh, action);
+ Safefree(action);
+
+ if (PGRES_COMMAND_OK != status) {
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+
+ for (i = av_len(imp_dbh->savepoints); i >= 0; i--) {
+ SV *elem = *av_fetch(imp_dbh->savepoints, i, 0);
+ if (strEQ(SvPV_nolen(elem), savepoint))
+ break;
+ (void)av_pop(imp_dbh->savepoints);
+ }
+ return 1;
+}
+
+
+/* ================================================================== */
+int pg_db_release (dbh, imp_dbh, savepoint)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+ char * savepoint;
+{
+ int status;
+ I32 i;
+ char *action;
+
+ if (dbis->debug >= 4)
+ (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_release (%s)\n", savepoint);
+
+ New(0, action, strlen(savepoint) + 9, char);
+
+ if (imp_dbh->pg_server_version < 80000)
+ croak("Savepoints are only supported on server version 8.0 or higher");
+
+ sprintf(action,"release %s",savepoint);
+
+ /* no action if AutoCommit = on or the connection is invalid */
+ if ((NULL == imp_dbh->conn) || (DBIc_has(imp_dbh, DBIcf_AutoCommit)))
+ return 0;
+
+ status = _result(imp_dbh, action);
+ Safefree(action);
+
+ if (PGRES_COMMAND_OK != status) {
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+
+ for (i = av_len(imp_dbh->savepoints); i >= 0; i--) {
+ SV *elem = av_pop(imp_dbh->savepoints);
+ if (strEQ(SvPV_nolen(elem), savepoint))
+ break;
+ }
+ return 1;
+}
+
+/* Used to ensure we are in a txn, e.g. the lo_ functions below */
+static int pg_db_start_txn (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+ int status = -1;
+ /* If not autocommit, start a new transaction */
+ if (!imp_dbh->done_begin && !DBIc_has(imp_dbh, DBIcf_AutoCommit)) {
+ status = _result(imp_dbh, "begin");
+ if (PGRES_COMMAND_OK != status) {
+ pg_error(dbh, status, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+ imp_dbh->done_begin = DBDPG_TRUE;
+ }
+ return 1;
+}
+
+
+/* ================================================================== */
+/* Large object functions */
+
+
+unsigned int pg_db_lo_creat (dbh, mode)
+ SV *dbh;
+ int mode;
+{
+ D_imp_dbh(dbh);
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_lo_creat (%d)\n", mode); }
+
+ if (!pg_db_start_txn(dbh,imp_dbh)) {
+ return (unsigned)-1;
+ }
+
+ return lo_creat(imp_dbh->conn, mode);
+}
+
+int pg_db_lo_open (dbh, lobjId, mode)
+ SV *dbh;
+ unsigned int lobjId;
+ int mode;
+{
+ D_imp_dbh(dbh);
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_lo_open (%d) (%d)\n", lobjId, mode); }
+ if (!pg_db_start_txn(dbh,imp_dbh)) {
+ return (unsigned)-1;
+ }
+ return lo_open(imp_dbh->conn, lobjId, mode);
+}
+
+int pg_db_lo_close (dbh, fd)
+ SV *dbh;
+ int fd;
+{
+ D_imp_dbh(dbh);
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_lo_close (%d)\n", fd); }
+ return lo_close(imp_dbh->conn, fd);
+}
+
+int pg_db_lo_read (dbh, fd, buf, len)
+ SV *dbh;
+ int fd;
+ char *buf;
+ size_t len;
+{
+ D_imp_dbh(dbh);
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_lo_read (%d) (%d)\n", fd, len); }
+ return lo_read(imp_dbh->conn, fd, buf, len);
+}
+
+int pg_db_lo_write (dbh, fd, buf, len)
+ SV *dbh;
+ int fd;
+ char *buf;
+ size_t len;
+{
+ D_imp_dbh(dbh);
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_lo_write (%d) (%d)\n", fd, len); }
+ return lo_write(imp_dbh->conn, fd, buf, len);
+}
+
+int pg_db_lo_lseek (dbh, fd, offset, whence)
+ SV *dbh;
+ int fd;
+ int offset;
+ int whence;
+{
+ D_imp_dbh(dbh);
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_lo_lseek (%d) (%d) (%d)\n", fd, offset, whence); }
+ return lo_lseek(imp_dbh->conn, fd, offset, whence);
+}
+
+int pg_db_lo_tell (dbh, fd)
+ SV *dbh;
+ int fd;
+{
+ D_imp_dbh(dbh);
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_lo_tell (%d)\n", fd); }
+ return lo_tell(imp_dbh->conn, fd);
+}
+
+int pg_db_lo_unlink (dbh, lobjId)
+ SV *dbh;
+ unsigned int lobjId;
+{
+ D_imp_dbh(dbh);
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_lo_unlink (%d)\n", lobjId); }
+ if (!pg_db_start_txn(dbh,imp_dbh)) {
+ return (unsigned)-1;
+ }
+ return lo_unlink(imp_dbh->conn, lobjId);
+}
+
+unsigned int pg_db_lo_import (dbh, filename)
+ SV *dbh;
+ char *filename;
+{
+ D_imp_dbh(dbh);
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_lo_import (%s)\n", filename); }
+ if (!pg_db_start_txn(dbh,imp_dbh)) {
+ return (unsigned)-1;
+ }
+ return lo_import(imp_dbh->conn, filename);
+}
+
+int pg_db_lo_export (dbh, lobjId, filename)
+ SV *dbh;
+ unsigned int lobjId;
+ char *filename;
+{
+ D_imp_dbh(dbh);
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: pg_db_lo_export id:(%d) file:(%s)\n", lobjId, filename); }
+ if (!pg_db_start_txn(dbh,imp_dbh)) {
+ return (unsigned)-1;
+ }
+ return lo_export(imp_dbh->conn, lobjId, filename);
+}
+
+
+/* ================================================================== */
+int dbd_st_blob_read (sth, imp_sth, lobjId, offset, len, destrv, destoffset)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ int lobjId;
+ long offset;
+ long len;
+ SV *destrv;
+ long destoffset;
+{
+ D_imp_dbh_from_sth;
+ int ret, lobj_fd, nbytes;
+ STRLEN nread;
+ SV *bufsv;
+ char *tmp;
+
+ if (dbis->debug >= 4) { (void)PerlIO_printf(DBILOGFP, "dbdpg: dbd_st_blob_read (%d) (%d) (%d)\n", lobjId, offset, len); }
+
+ /* safety checks */
+ if (lobjId <= 0) {
+ pg_error(sth, PGRES_FATAL_ERROR, "dbd_st_blob_read: lobjId <= 0");
+ return 0;
+ }
+ if (offset < 0) {
+ pg_error(sth, PGRES_FATAL_ERROR, "dbd_st_blob_read: offset < 0");
+ return 0;
+ }
+ if (len < 0) {
+ pg_error(sth, PGRES_FATAL_ERROR, "dbd_st_blob_read: len < 0");
+ return 0;
+ }
+ if (! SvROK(destrv)) {
+ pg_error(sth, PGRES_FATAL_ERROR, "dbd_st_blob_read: destrv not a reference");
+ return 0;
+ }
+ if (destoffset < 0) {
+ pg_error(sth, PGRES_FATAL_ERROR, "dbd_st_blob_read: destoffset < 0");
+ return 0;
+ }
+
+ /* dereference destination and ensure it's writable string */
+ bufsv = SvRV(destrv);
+ if (0==destoffset) {
+ sv_setpvn(bufsv, "", 0);
+ }
+
+ /* open large object */
+ lobj_fd = lo_open(imp_dbh->conn, (unsigned)lobjId, INV_READ);
+ if (lobj_fd < 0) {
+ pg_error(sth, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+
+ /* seek on large object */
+ if (offset > 0) {
+ ret = lo_lseek(imp_dbh->conn, lobj_fd, (int)offset, SEEK_SET);
+ if (ret < 0) {
+ pg_error(sth, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+ }
+
+ /* read from large object */
+ nread = 0;
+ SvGROW(bufsv, (STRLEN)(destoffset + nread + BUFSIZ + 1));
+ tmp = (SvPVX(bufsv)) + destoffset + nread;
+ while ((nbytes = lo_read(imp_dbh->conn, lobj_fd, tmp, BUFSIZ)) > 0) {
+ nread += nbytes;
+ /* break if user wants only a specified chunk */
+ if (len > 0 && nread > (STRLEN)len) {
+ nread = (STRLEN)len;
+ break;
+ }
+ SvGROW(bufsv, (STRLEN)(destoffset + nread + BUFSIZ + 1));
+ tmp = (SvPVX(bufsv)) + destoffset + nread;
+ }
+
+ /* terminate string */
+ SvCUR_set(bufsv, (STRLEN)(destoffset + nread));
+ *SvEND(bufsv) = '\0';
+
+ /* close large object */
+ ret = lo_close(imp_dbh->conn, lobj_fd);
+ if (ret < 0) {
+ pg_error(sth, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+
+ return (int)nread;
+}
+
+/* end of dbdimp.c */
+
Added: packages/libdbd-pg-perl/branches/upstream/current/dbdimp.h
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/dbdimp.h 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/dbdimp.h 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,123 @@
+/*
+ $Id: dbdimp.h,v 1.49 2006/02/13 03:02:06 turnstep Exp $
+
+ Copyright (c) 2000-2006 PostgreSQL Global Development Group
+ 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 "types.h"
+
+/* 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 */
+
+ 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?) */
+
+ int pg_protocol; /* value of PQprotocolVersion, usually 0, 2, or 3 */
+ int pg_server_version; /* Server version e.g. 80100 */
+ 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 */
+
+ AV *savepoints; /* list of savepoints */
+ PGconn *conn; /* connection structure */
+ char *sqlstate; /* from the last result */
+};
+
+
+/* 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 isdefault; /* Are we passing a literal 'DEFAULT'? */
+ 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 */
+
+ STRLEN totalsize; /* total string length of the statement (with no placeholders)*/
+
+ 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? */
+};
+
+/* Other (non-static) functions we have added to dbdimp.c */
+
+int dbd_db_ping(SV *dbh);
+int dbd_db_getfd (SV *dbh, imp_dbh_t *imp_dbh);
+SV * dbd_db_pg_notifies (SV *dbh, imp_dbh_t *imp_dbh);
+int pg_db_putline (SV *dbh, const char *buffer);
+int pg_db_getline (SV *dbh, char *buffer, int length);
+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, 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);
+int pg_db_lo_export (SV *dbh, unsigned int lobjId, char *filename);
+int pg_quickexec (SV *dbh, const char *sql);
+
+/* end of dbdimp.h */
+
Added: packages/libdbd-pg-perl/branches/upstream/current/quote.c
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/quote.c 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/quote.c 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,296 @@
+/*
+
+ $Id: quote.c,v 1.43 2006/02/26 18:50:05 turnstep Exp $
+
+ Copyright (c) 2003-2006 PostgreSQL Global Development Group
+
+ 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"
+#include "types.h"
+
+char * null_quote(string, len, retlen)
+ char *string;
+ STRLEN len;
+ STRLEN *retlen;
+{
+ char *result;
+ New(0, result, len+1, char);
+ strncpy(result,string,len);
+ result[len]='\0';
+ *retlen = len;
+ return result;
+}
+
+
+char * quote_string(string, len, retlen)
+ char * string;
+ STRLEN len;
+ STRLEN * retlen;
+{
+ char * result;
+ STRLEN oldlen = len;
+
+ result = string;
+ (*retlen) = 2;
+ while (len > 0 && *string != '\0') {
+ if (*string == '\'' || *string == '\\') {
+ (*retlen)++;
+ }
+ (*retlen)++;
+ *string++;
+ len--;
+ }
+ string = result;
+ New(0, result, 1+(*retlen), char);
+ *result++ = '\'';
+ len = oldlen;
+ while (len > 0 && *string != '\0') {
+ if (*string == '\'' || *string == '\\') {
+ *result++ = *string;
+ }
+ *result++ = *string++;
+ len--;
+ }
+ *result++ = '\'';
+ *result = '\0';
+ return result - (*retlen);
+}
+
+char * quote_bytea(string, len, retlen)
+ char * string;
+ STRLEN len;
+ STRLEN * retlen;
+{
+ char * result;
+ STRLEN oldlen = len;
+
+ result = string;
+ (*retlen) = 2;
+ while (len > 0) {
+ if (*string == '\'') {
+ (*retlen) += 2;
+ }
+ else if (*string == '\\') {
+ (*retlen) += 4;
+ }
+ else if (*string < 0x20 || *string > 0x7e) {
+ (*retlen) += 5;
+ }
+ else {
+ (*retlen)++;
+ }
+ *string++;
+ len--;
+ }
+ string = result;
+ New(0, result, 1+(*retlen), char);
+ *result++ = '\'';
+ len = oldlen;
+ while (len > 0) {
+ if (*string == '\'') { // Single quote becomes double quotes
+ *result++ = *string;
+ *result++ = *string++;
+ }
+ else if (*string == '\\') { // Backslash becomes 4 backslashes
+ *result++ = *string;
+ *result++ = *string++;
+ *result++ = '\\';
+ *result++ = '\\';
+ }
+ else if (*string < 0x20 || *string > 0x7e) {
+ (void) snprintf(result, 6, "\\\\%03o", *string++);
+ result += 5;
+ }
+ else {
+ *result++ = *string++;
+ }
+ len--;
+ }
+ *result++ = '\'';
+ *result = '\0';
+
+ return result - (*retlen);
+}
+
+char * quote_sql_binary( string, len, retlen)
+ char *string;
+ STRLEN len;
+ STRLEN *retlen;
+{
+
+ /* We are going to return a quote_bytea() for backwards compat but
+ we warn first */
+ warn("Use of SQL_BINARY invalid in quote()");
+ return quote_bytea(string, len, retlen);
+
+}
+
+
+
+char * quote_bool(value, len, retlen)
+ char *value;
+ STRLEN len;
+ STRLEN *retlen;
+{
+ char *result;
+ long int int_value;
+ STRLEN max_len=6;
+
+ len = 0;
+ if (isDIGIT(*(char*)value)) {
+ /* For now -- will go away when quote* take SVs */
+ int_value = atoi(value);
+ } else {
+ int_value = 42; /* Not true, not false. Just is */
+ }
+ New(0, result, max_len, char);
+
+ if (0 == int_value)
+ strncpy(result,"FALSE\0",6);
+ else if (1 == int_value)
+ strncpy(result,"TRUE\0",5);
+ else
+ croak("Error: Bool must be either 1 or 0");
+
+ *retlen = strlen(result);
+ assert(*retlen+1 <= max_len);
+
+ return result;
+}
+
+
+
+char * quote_integer(value, len, retlen)
+ char *value;
+ STRLEN len;
+ STRLEN *retlen;
+{
+ char *result;
+ STRLEN max_len=6;
+ len = 0;
+
+ New(0, result, max_len, char);
+
+ if (0 == *((int*)value) )
+ strncpy(result,"FALSE\0",6);
+ if (1 == *((int*)value))
+ strncpy(result,"TRUE\0",5);
+
+ *retlen = strlen(result);
+ assert(*retlen+1 <= max_len);
+
+ return result;
+}
+
+
+
+void dequote_char(string, retlen)
+ char *string;
+ STRLEN *retlen;
+{
+ /* TODO: chop_blanks if requested */
+ *retlen = strlen(string);
+}
+
+
+void dequote_string (string, retlen)
+ char *string;
+ STRLEN *retlen;
+{
+ *retlen = strlen(string);
+}
+
+
+
+void dequote_bytea(string, retlen)
+ char *string;
+ STRLEN *retlen;
+{
+ char *result;
+
+ (*retlen) = 0;
+
+ if (NULL == string)
+ return;
+
+ New(0, result, strlen(string)+1, char);
+
+ result = string;
+
+ while (*string != '\0') {
+ (*retlen)++;
+ if ('\\' == *string) {
+ if ('\\' == *(string+1)) {
+ *result++ = '\\';
+ string +=2;
+ }
+ else if (
+ (*(string+1) >= '0' && *(string+1) <= '3') &&
+ (*(string+2) >= '0' && *(string+2) <= '7') &&
+ (*(string+3) >= '0' && *(string+3) <= '7'))
+ {
+ *result++ = (*(string+1)-'0')*64 + (*(string+2)-'0')*8 + (*(string+3)-'0');
+ string += 4;
+ }
+ else { /* Invalid escape sequence - ignore the backslash */
+ (*retlen)--;
+ *string++;
+ }
+ }
+ else {
+ *result++ = *string++;
+ }
+ }
+ result = '\0';
+ Renew(result, (*retlen), char);
+ string = result - (*retlen);
+ return;
+}
+
+
+
+/*
+ This one is not used in PG, but since we have a quote_sql_binary,
+ it might be nice to let people go the other way too. Say when talking
+ to something that uses SQL_BINARY
+ */
+void dequote_sql_binary (string, retlen)
+ char *string;
+ STRLEN *retlen;
+{
+ /* We are going to retun a dequote_bytea(), JIC */
+ warn("Use of SQL_BINARY invalid in dequote()");
+ dequote_bytea(string, retlen);
+ return;
+ /* Put dequote_sql_binary function here at some point */
+}
+
+
+
+void dequote_bool (string, retlen)
+ char *string;
+ STRLEN *retlen;
+{
+ switch(*string){
+ case 'f': *string = '0'; break;
+ case 't': *string = '1'; break;
+ default:
+ croak("I do not know how to deal with %c as a bool", *string);
+ }
+ *retlen = 1;
+}
+
+
+
+void null_dequote (string, retlen)
+ char *string;
+ STRLEN *retlen;
+{
+ *retlen = strlen(string);
+}
+
+/* end of quote.c */
Added: packages/libdbd-pg-perl/branches/upstream/current/quote.h
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/quote.h 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/quote.h 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,16 @@
+
+#ifndef DBDQUOTEH
+#define DBDQUOTEH
+char * null_quote(char *string, STRLEN len, STRLEN *retlen);
+char * quote_string(char *string, STRLEN len, STRLEN *retlen);
+char * quote_bytea(char *string, STRLEN len, STRLEN *retlen);
+char * quote_sql_binary(char *string, STRLEN len, STRLEN *retlen);
+char * quote_bool(char *string, STRLEN len, STRLEN *retlen);
+char * quote_integer(char *string, STRLEN len, STRLEN *retlen);
+void dequote_char(char *string, STRLEN *retlen);
+void dequote_string(char *string, STRLEN *retlen);
+void dequote_bytea(char *string, STRLEN *retlen);
+void dequote_sql_binary(char *string, STRLEN *retlen);
+void dequote_bool(char *string, STRLEN *retlen);
+void null_dequote(char *string, STRLEN *retlen);
+#endif /*DBDQUOTEH*/
Added: packages/libdbd-pg-perl/branches/upstream/current/t/00-signature.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/00-signature.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/00-signature.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,33 @@
+#!perl -w
+
+## Test that our SIGNATURE file is valid
+
+use Test::More;
+use strict;
+$|=1;
+
+if (!eval { require Module::Signature; 1 }) {
+ plan skip_all =>
+ "Please install Module::Signature so that you can verify ".
+ "the integrity of this and other distributions.";
+}
+elsif ( !-e 'SIGNATURE' ) {
+ plan skip_all => "SIGNATURE file was not found";
+}
+elsif ( -s 'SIGNATURE' == 0 ) {
+ plan skip_all => "SIGNATURE file was empty";
+}
+elsif (!eval { require Socket; Socket::inet_aton('pgp.mit.edu') }) {
+ plan skip_all => "Cannot connect to the keyserver to check module signature";
+}
+else {
+ plan tests => 1;
+}
+
+my $ret = Module::Signature::verify();
+SKIP: {
+ skip "Module::Signature cannot verify", 1
+ if $ret eq Module::Signature::CANNOT_VERIFY();
+ cmp_ok $ret, '==', Module::Signature::SIGNATURE_OK(), "Valid signature";
+}
+
Added: packages/libdbd-pg-perl/branches/upstream/current/t/00basic.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/00basic.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/00basic.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,15 @@
+#!perl -w
+
+# Simply test that we can load the DBI and DBD::PG modules,
+# Check that we have a valid version returned from the latter
+
+use Test::More tests => 3;
+use strict;
+
+BEGIN {
+ use_ok('DBI');
+ use_ok('DBD::Pg');
+};
+
+like( $DBD::Pg::VERSION, qr/^[\d\._]+$/, qq{Found DBD::Pg::VERSION as "$DBD::Pg::VERSION"});
+
Added: packages/libdbd-pg-perl/branches/upstream/current/t/01connect.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/01connect.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/01connect.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,84 @@
+#!perl -w
+
+# Make sure we can connect and disconnect cleanly
+# All tests are stopped if we cannot make the first connect
+
+use Test::More;
+use DBI;
+use strict;
+select((select(STDERR),$|=1)[0]);
+$|=1;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 8;
+} else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file.';
+}
+
+## Define this here in case we get to the END block before a connection is made.
+my ($pgversion,$pglibversion,$pgvstring,$pgdefport) = ('?','?','?','?');
+
+# Trapping a connection error can be tricky, but we only have to do it
+# this thoroughly one time. We are trapping two classes of errors:
+# the first is when we truly do not connect, usually a bad DBI_DSN;
+# the second is an invalid login, usually a bad DBI_USER or DBI_PASS
+
+my $dbh;
+eval {
+ $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0});
+};
+if ($@) {
+ if (! $DBI::errstr) {
+ print STDOUT "Bail out! Could not connect: $@\n";
+ }
+ else {
+ print STDOUT "Bail out! Could not connect: $DBI::errstr\n";
+ }
+ exit; # Force a hasty exit
+}
+
+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
+ok( $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0}),
+ 'Connected with first database handle');
+
+my $dbh2;
+ok( $dbh2 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0}),
+ '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');
+
+END {
+ my $pv = sprintf("%vd", $^V);
+ my $schema = exists $ENV{DBD_SCHEMA} ?
+ "\nDBD_SCHEMA $ENV{DBD_SCHEMA}" : '';
+ diag
+ "\nProgram Version\n".
+ "Perl $pv ($^O)\n".
+ "DBD::Pg $DBD::Pg::VERSION\n".
+ "PostgreSQL (compiled) $pglibversion\n".
+ "PostgreSQL (target) $pgversion\n".
+ "PostgreSQL (reported) $pgvstring\n".
+ "Default port $pgdefport\n".
+ "DBI $DBI::VERSION\n".
+ "DBI_DSN $ENV{DBI_DSN}$schema\n";
+}
Added: packages/libdbd-pg-perl/branches/upstream/current/t/01constants.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/01constants.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/01constants.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,25 @@
+use strict;
+use Test::More tests => 20;
+
+use DBD::Pg qw(:pg_types);
+
+ok(PG_BOOL == 16, 'PG_BOOL');
+ok(PG_BYTEA == 17, 'PG_BYTEA');
+ok(PG_CHAR == 18, 'PG_CHAR');
+ok(PG_INT8 == 20, 'PG_INT8');
+ok(PG_INT2 == 21, 'PG_INT2');
+ok(PG_INT4 == 23, 'PG_INT4');
+ok(PG_TEXT == 25, 'PG_TEXT');
+ok(PG_OID == 26, 'PG_OID');
+ok(PG_FLOAT4 == 700, 'PG_FLOAT4');
+ok(PG_FLOAT8 == 701, 'PG_FLOAT8');
+ok(PG_ABSTIME == 702, 'PG_ABSTIME');
+ok(PG_RELTIME == 703, 'PG_RELTIME');
+ok(PG_TINTERVAL == 704, 'PG_TINTERVAL');
+ok(PG_BPCHAR == 1042, 'PG_BPCHAR');
+ok(PG_VARCHAR == 1043, 'PG_VARCHAR');
+ok(PG_DATE == 1082, 'PG_DATE');
+ok(PG_TIME == 1083, 'PG_TIME');
+ok(PG_DATETIME == 1184, 'PG_DATETIME');
+ok(PG_TIMESPAN == 1186, 'PG_TIMESPAN');
+ok(PG_TIMESTAMP == 1296, 'PG_TIMESTAMP');
Added: packages/libdbd-pg-perl/branches/upstream/current/t/01setup.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/01setup.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/01setup.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,86 @@
+#!perl -w
+
+# Create the "dbd_pg_test" table and the "dbd_pg_sequence" sequence.
+# Because the table is used for the other tests, we bail out if we cannot create it.
+
+use Test::More;
+use DBI;
+use strict;
+$|=1;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 4;
+}
+else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file.';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 0, PrintError => 0, AutoCommit => 1});
+ok( defined $dbh, "Connect to database for test table creation");
+
+# Remove the test relations if they exist
+my $schema = DBD::Pg::_pg_use_catalog($dbh);
+my $SQL = "SELECT COUNT(*) FROM pg_class WHERE relname=?";
+if ($schema) {
+ $schema = exists $ENV{DBD_SCHEMA} ? $ENV{DBD_SCHEMA} : 'public';
+ $dbh->do("SET search_path TO " . $dbh->quote_identifier($schema));
+ $SQL = "SELECT COUNT(*) FROM pg_catalog.pg_class c, pg_catalog.pg_namespace n ".
+ "WHERE c.relnamespace=n.oid AND c.relname=? AND n.nspname=".
+ $dbh->quote($schema);
+}
+
+# Implicit tests of prepare, execute, fetchall_arrayref, and do
+my $sth = $dbh->prepare($SQL);
+$sth->execute('dbd_pg_test');
+my $count = $sth->fetchall_arrayref()->[0][0];
+if (1==$count) {
+ $dbh->do(sprintf "DROP TABLE %s%s", $schema ? "$schema." : '', 'dbd_pg_test');
+}
+$sth->execute('dbd_pg_sequence');
+$count = $sth->fetchall_arrayref()->[0][0];
+if (1==$count) {
+ $dbh->do(sprintf "DROP SEQUENCE %s%s", $schema ? "$schema." : '', 'dbd_pg_sequence');
+}
+
+
+$dbh->do("CREATE SEQUENCE dbd_pg_sequence");
+# If you add columns to this, please do not use reserved words!
+$SQL = qq{
+CREATE TABLE dbd_pg_test (
+ id integer not null primary key,
+ lii integer unique not null default nextval('dbd_pg_sequence'),
+ 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[][],
+ "CaseTest" boolean,
+ bytetest bytea
+)
+};
+
+$dbh->{Warn}=0;
+ok( $dbh->do($SQL), qq{Created test table "dbd_pg_test"})
+ or print STDOUT "Bail out! Test table could not be created: $DBI::errstr\n";
+
+$dbh->do("COMMENT ON COLUMN dbd_pg_test.id IS 'Bob is your uncle'");
+
+# Double check that the file is there
+$sth->execute();
+$count = $sth->fetchall_arrayref()->[0][0];
+is( $count, 1, 'Test table was successfully created')
+ or print STDOUT "Bail out! Test table was not created\n";
+
+ok( $dbh->disconnect(), 'Disconnect from database');
+
+
+
+
+
+
+
+
+
+
Added: packages/libdbd-pg-perl/branches/upstream/current/t/02attribs.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/02attribs.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/02attribs.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,887 @@
+#!perl -w
+
+# Test all handle attributes: database, statement, and generic ("any")
+
+use Test::More;
+use DBI qw(:sql_types);
+use strict;
+$|=1;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 130;
+}
+else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 0, PrintError => 0, AutoCommit => 0});
+ok( defined $dbh, "Connect to database for handle attributes testing");
+
+my $version = $dbh->{pg_server_version};
+my $pglibversion = $dbh->{pg_lib_version};
+my $got73 = $version >= 70300 ? 1 : 0;
+if ($got73) {
+ $dbh->do("SET search_path TO " . $dbh->quote_identifier
+ (exists $ENV{DBD_SCHEMA} ? $ENV{DBD_SCHEMA} : 'public'));
+}
+
+my $pgversion = $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_enable_utf8
+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_prepare_now - tested in 03smethod.t
+d pg_server_prepare - tested in 03smethod.t
+d pg_prepare_now - tested in 03smethod.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 RowsInCache
+
+a Warn (inheritance test also)
+a Active
+a Kids
+a ActiveKids
+a CachedKids
+a CompatMode
+a PrintError
+a RaiseError
+a HandleError
+a ShowErrorStatement (unsupported)
+a TraceLevel
+a FetchHashKeyName
+a ChopBlanks
+a LongReadLen
+a LongTruncOk
+a TaintIn
+a TaintOut
+a Taint
+a Profile (not tested)
+
+d InactiveDestroy (must be the last one tested)
+
+};
+
+my ($attrib,$SQL,$sth,$warning,$result);
+
+#
+# Test of the database handle attribute "Statement"
+#
+
+$SQL = "SELECT 123";
+$sth = $dbh->prepare($SQL);
+$sth->finish();
+
+$attrib = $dbh->{Statement};
+is( $attrib, $SQL, 'DB handle attribute "Statement" returns the last prepared query');
+
+#
+# Test of bogus database/statement handle attributes
+#
+
+## DBI switched from error to warnign in 1.43
+$warning="";
+eval {
+ local $SIG{__WARN__} = sub { $warning = shift; };
+ $dbh->{CrazyDiamond}=1;
+};
+ok( (length $warning or $@), 'Error or warning when setting an invalid database handle attribute');
+
+eval {
+ $dbh->{private_dbdpg_CrazyDiamond}=1;
+};
+ok( !$@, 'Setting a private attribute on a database handle does not throw an error');
+
+$sth = $dbh->prepare('SELECT 123');
+
+$warning="";
+eval {
+ local $SIG{__WARN__} = sub { $warning = shift; };
+ $sth->{CrazyDiamond}=1;
+};
+ok( (length $warning or $@), 'Error or warning when setting an invalid statement handle attribute');
+
+eval {
+ $sth->{private_dbdpg_CrazyDiamond}=1;
+};
+ok( !$@, 'Setting a private attribute on a statement handle does not throw an error');
+
+#
+# Test of the database handle attribute "AutoCommit"
+#
+
+$dbh->do('DELETE FROM dbd_pg_test');
+ok( $dbh->commit(), "Commit after deleting all rows from dbd_pg_test");
+
+my $dbh2 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 0, PrintError => 0, AutoCommit => 1});
+if ($got73) {
+ $dbh2->do("SET search_path TO " . $dbh2->quote_identifier
+ (exists $ENV{DBD_SCHEMA} ? $ENV{DBD_SCHEMA} : 'public'));
+}
+
+ok( defined $dbh2, "Connect to database with second database handle, AutoCommit on");
+
+ok( $dbh->do("INSERT INTO dbd_pg_test (id, pname, val) VALUES (1, 'Coconut', 'Mango')"),
+ 'Insert a row into the database with first database handle');
+
+
+my $rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 1}))[0];
+cmp_ok($rows, '==', 0, 'Second database handle cannot see insert from first');
+
+ok( $dbh->do("INSERT INTO dbd_pg_test (id, pname, val) VALUES (2, 'Grapefruit', 'Pomegranate')"),
+ 'Insert a row into the database with second database handle');
+
+$rows = ($dbh->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 2}))[0];
+cmp_ok($rows, '==', 1, 'First database handle can see insert from second');
+
+ok( $dbh->commit, 'Commit transaction with first database handle');
+
+$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 1}))[0];
+cmp_ok($rows, '==', 1, 'Second database handle can see insert from first');
+
+ok( $dbh2->disconnect(), 'Disconnect with second database handle');
+
+
+#
+# Test of the database handle attribute "Driver"
+#
+
+$attrib = $dbh->{Driver}->{Name};
+is( $attrib, 'Pg', '$dbh->{Driver}{Name} returns correct value of "Pg"');
+
+#
+# Test of the database handle attribute "Name"
+#
+
+if ($ENV{DBI_DSN} !~ /(?:dbname|database|db)\s*=\s*\"([^"]+)/o and
+ $ENV{DBI_DSN} !~ /(?:dbname|database|db)\s*=\s*([^;]+)/o) {
+ SKIP: {
+ skip 'Cannot test DB handle attribute "Name": DBI_DSN has no dbname', 1;
+ }
+}
+else {
+ $attrib = $dbh->{Name};
+ is( $attrib, $1, 'DB handle attribute "Name" returns same value as DBI_DSN');
+}
+
+#
+# Test of the database handle attribute "RowCacheSize"
+#
+
+$attrib = $dbh->{RowCacheSize};
+ok( !defined $attrib, 'DB handle attribute "RowCacheSize" returns undef');
+$dbh->{RowCacheSize} = 42;
+$attrib = $dbh->{RowCacheSize};
+ok( !defined $attrib, 'Setting DB handle attribute "RowCacheSize" has no effect');
+
+#
+# Test of the database handle attribute "Username"
+#
+
+if ($DBI::VERSION < 1.36) {
+ SKIP: {
+ skip 'DBI must be at least version 1.36 to test the DB handle attribute "Username"', 1;
+ }
+}
+else {
+ $attrib = $dbh->{Username};
+ is( $attrib, $ENV{DBI_USER}, 'DB handle attribute "Username" returns the same value as DBI_USER');
+}
+
+#
+# Test of the "PrintWarn" database handle attribute
+#
+
+my $value = $dbh->{PrintWarn};
+is ($value, 1, qq{DB handle attribute "PrintWarn" defaults to on});
+
+{
+
+local $SIG{__WARN__} = sub { $warning = shift; };
+
+$warning = q{};
+eval {
+ $dbh->do("CREATE TEMP TABLE dbd_pg_test_temp(id INT PRIMARY KEY)");
+};
+ok (!$@, qq{DB handle attribute "PrintWarn" works when on});
+like($warning, qr{dbd_pg_test_temp}, qq{DB handle attribute "PrintWarn" shows warnings when on});
+
+$dbh->rollback();
+$dbh->{PrintWarn}=0;
+$warning = q{};
+eval {
+ $dbh->do("CREATE TEMP TABLE dbd_pg_test_temp(id INT PRIMARY KEY)");
+};
+ok (!$@, qq{DB handle attribute "PrintWarn" works when on});
+is($warning, q{}, qq{DB handle attribute "PrintWarn" shows warnings when on});
+
+$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)
+#
+
+like( $dbh->{pg_INV_WRITE}, qr/^\d+$/, 'Database handle attribute "pg_INV_WRITE" returns a number');
+like( $dbh->{pg_INV_READ}, qr/^\d+$/, 'Database handle attribute "pg_INV_READ" returns a number');
+
+#
+# Test of the database handle attribute "pg_protocol"
+#
+
+like( $dbh->{pg_protocol}, qr/^\d+$/, 'Database handle attribute "pg_protocol" returns a number');
+
+#
+# Test of the database handle attribute "pg_errorlevel"
+#
+
+cmp_ok( 1, '==', $dbh->{pg_errorlevel}, 'Database handle attribute "pg_errorlevel" returns the default (1)');
+
+if ($pgversion < 70400) {
+ SKIP: {
+ skip 'Cannot test DB handle attribute "pg_errorlevel" on pre-7.4 servers', 1;
+ }
+}
+else {
+ $dbh->{pg_errorlevel} = 3;
+ cmp_ok( 1, '==', $dbh->{pg_errorlevel}, 'Database handle attribute "pg_errorlevel" defaults to 1 if invalid');
+}
+
+#
+# Test of the database handle attribute "pg_bool_tf"
+#
+
+$result = $dbh->{pg_bool_tf}=0;
+is( $result, 0, 'DB handle method "pg_bool_tf" starts as 0');
+
+$sth = $dbh->prepare("SELECT ?::bool");
+$sth->bind_param(1,1,SQL_BOOLEAN);
+$sth->execute();
+$result = $sth->fetchall_arrayref()->[0][0];
+is( $result, "1", qq{DB handle method "pg_bool_tf" returns '1' for true when on});
+$sth->execute(0);
+$result = $sth->fetchall_arrayref()->[0][0];
+is( $result, "0", qq{DB handle method "pg_bool_tf" returns '0' for false when on});
+
+$dbh->{pg_bool_tf}=1;
+$sth->execute(1);
+$result = $sth->fetchall_arrayref()->[0][0];
+is( $result, 't', qq{DB handle method "pg_bool_tf" returns 't' for true when on});
+$sth->execute(0);
+$result = $sth->fetchall_arrayref()->[0][0];
+is( $result, 'f', qq{DB handle method "pg_bool_tf" returns 'f' for true when on});
+
+
+## Test of all the informational pg_* database handle attributes
+
+$result = $dbh->{pg_protocol};
+like( $result, qr/^\d+$/, qq{DB handle attribute "pg_db" returns at least one character});
+
+$result = $dbh->{pg_db};
+ok( length $result, qq{DB handle attribute "pg_db" returns at least one character});
+
+$result = $dbh->{pg_user};
+ok( defined $result, qq{DB handle attribute "pg_user" returns a value});
+
+$result = $dbh->{pg_pass};
+ok( defined $result, qq{DB handle attribute "pg_pass" returns a value});
+
+$result = $dbh->{pg_port};
+like( $result, qr/^\d+$/, qq{DB handle attribute "pg_port" returns a number});
+
+$result = $dbh->{pg_default_port};
+like( $result, qr/^\d+$/, qq{DB handle attribute "pg_default_port" returns a number});
+
+$result = $dbh->{pg_options};
+ok (defined $result, qq{DB handle attribute "pg_options" returns a value});
+
+$result = $dbh->{pg_socket};
+like( $result, qr/^\d+$/, qq{DB handle attribute "pg_socket" returns a value});
+
+$result = $dbh->{pg_pid};
+like( $result, qr/^\d+$/, qq{DB handle attribute "pg_pid" returns a value});
+
+
+# Attempt to test whether or not we can get unicode out of the database
+SKIP: {
+ eval "use Encode;";
+ skip "Encode module is needed for unicode tests", 5 if $@;
+ my $SQL = "SELECT id, pname FROM dbd_pg_test WHERE id = ?";
+ my $sth = $dbh->prepare($SQL);
+ $sth->execute(1);
+ local $dbh->{pg_enable_utf8} = 1;
+ my $utf8_str = chr(0x100).'dam'; # LATIN CAPITAL LETTER A WITH MACRON
+ is( $dbh->quote( $utf8_str ), "'$utf8_str'", 'quote() handles utf8.' );
+ $SQL = "INSERT INTO dbd_pg_test (id, pname, val) VALUES (40, '$utf8_str', 'Orange')";
+ is( $dbh->do($SQL), '1', 'Able to insert unicode character into the database');
+ $sth->execute(40);
+ my ($id, $name) = $sth->fetchrow_array();
+ ok( Encode::is_utf8($name), 'Able to read unicode (utf8) data from the database');
+ is( length($name), 4, 'Unicode (utf8) data returned from database is not corrupted');
+ $sth->finish();
+ $sth->execute(1);
+ my ($id2, $name2) = $sth->fetchrow_array();
+ ok( !Encode::is_utf8($name2), 'ASCII text returned from database does not have utf8 bit set');
+ $sth->finish();
+}
+
+
+#
+# Use the handle attribute "Warn" to check inheritance
+#
+
+undef $sth;
+
+ok( $dbh->{Warn}, 'Attribute "Warn" attribute set on by default');
+
+$SQL = "SELECT 123";
+$sth = $dbh->prepare($SQL);
+$sth->finish();
+ok( $sth->{Warn}, 'Statement handle inherits the "Warn" attribute');
+
+$dbh->{Warn} = 0;
+ok( ! $dbh->{Warn}, 'Turn off the "Warn" attribute in the database handle');
+
+#
+# Test of the the following statement handle attributes:
+# NUM_OF_FIELDS, NUM_OF_PARAMS
+# NAME, NAME_lc, NAME_uc, NAME_hash, NAME_lc_hash, NAME_uc_hash
+# TYPE, PRECISION, SCALE, NULLABLE
+#
+
+$sth = $dbh->prepare('SELECT 123 AS "Sheep", id::float FROM dbd_pg_test WHERE id=?');
+$sth->execute(12);
+$attrib = $sth->{'NUM_OF_FIELDS'};
+is( $attrib, '2', 'Statement handle attribute "NUM_OF_FIELDS" works correctly for SELECT');
+$attrib = $sth->{'NUM_OF_PARAMS'};
+is( $attrib, '1', 'Statement handle attribute "NUM_OF_PARAMS" works correctly with one placeholder');
+$attrib = $sth->{NAME};
+my $colnames = ['Sheep', 'id'];
+is_deeply( $attrib, $colnames, 'Statement handle attribute "NAME" works correctly');
+$attrib = $sth->{NAME_lc};
+$colnames = ['sheep', 'id'];
+is_deeply( $attrib, $colnames, 'Statement handle attribute "NAME_lc" works correctly');
+$attrib = $sth->{NAME_uc};
+$colnames = ['SHEEP', 'ID'];
+is_deeply( $attrib, $colnames, 'Statement handle attribute "NAME_uc" works correctly');
+$attrib = $sth->{'NAME_hash'};
+$colnames = {'Sheep' => 0, id => 1};
+is_deeply( $attrib, $colnames, 'Statement handle attribute "NAME_hash" works correctly');
+$attrib = $sth->{'NAME_lc_hash'};
+$colnames = {sheep => 0, id => 1};
+is_deeply( $attrib, $colnames, 'Statement handle attribute "NAME_lc_hash" works correctly');
+$attrib = $sth->{NAME_uc_hash};
+$colnames = {SHEEP => 0, ID => 1};
+is_deeply( $attrib, $colnames, 'Statement handle attribute "NAME_uc_hash" works correctly');
+
+$attrib = $sth->{TYPE};
+$colnames = [4, 7];
+is_deeply( $attrib, $colnames, 'Statement handle attribute "TYPE" works correctly');
+
+$attrib = $sth->{PRECISION};
+$colnames = [4, 8];
+is_deeply( $attrib, $colnames, 'Statement handle attribute "PRECISION" works correctly');
+
+$attrib = $sth->{SCALE};
+$colnames = [undef,undef];
+is_deeply( $attrib, $colnames, 'Statement handle attribute "SCALE" works correctly');
+
+$attrib = $sth->{NULLABLE};
+$colnames = [2,2];
+is_deeply( $attrib, $colnames, 'Statement handle attribute "NULLABLE" works correctly');
+
+$sth->finish();
+
+$sth = $dbh->prepare("DELETE FROM dbd_pg_test WHERE id=0");
+$sth->execute();
+$attrib = $sth->{'NUM_OF_FIELDS'};
+my $expected = $DBI::VERSION >=1.42 ? undef : 0;
+is( $attrib, $expected, 'Statement handle attribute "NUM_OF_FIELDS" works correctly for DELETE');
+$attrib = $sth->{'NUM_OF_PARAMS'};
+is( $attrib, '0', 'Statement handle attribute "NUM_OF_PARAMS" works correctly with no placeholder');
+$attrib = $sth->{NAME};
+$colnames = [];
+is_deeply( $attrib, $colnames, 'Statement handle attribute "NAME" works correctly for DELETE');
+
+$sth->finish();
+
+#
+# Test of the statement handle attribute "CursorName"
+#
+
+$attrib = $sth->{CursorName};
+is( $attrib, undef, 'Statement handle attribute "CursorName" returns undef');
+
+#
+# Test of the statement handle attribute "Database"
+#
+
+$attrib = $sth->{Database};
+is( $attrib, $dbh, 'Statement handle attribute "Database" matches the database handle');
+
+#
+# Test of the statement handle attribute "ParamValues"
+#
+
+$sth = $dbh->prepare("SELECT id FROM dbd_pg_test WHERE id=?");
+$sth->bind_param(1, 1);
+$attrib = $sth->{ParamValues};
+is_deeply( $attrib, {1 => "1"}, qq{Statement handle attribute "ParamValues" works before execute});
+$sth->execute();
+$attrib = $sth->{ParamValues};
+is_deeply( $attrib, {1 => "1"}, qq{Statement handle attribute "ParamValues" works after execute});
+
+#
+# Test of the statement handle attribute "RowsInCache"
+#
+
+$attrib = $sth->{RowsInCache};
+is( $attrib, undef, 'Statement handle attribute "RowsInCache" returns undef');
+
+
+#
+# Test of the statement handle attribute "pg_size"
+#
+
+$SQL = '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, 'Statement handle attribute "pg_size" works');
+
+#
+# Test of the statement handle attribute "pg_size"
+#
+
+$sth->execute();
+$result = $sth->{pg_type};
+$expected = [qw(int4 varchar text float8 bpchar timestamp bool)];
+# Hack for old servers
+$expected->[5] = 'datetime' unless $got73;
+is_deeply( $result, $expected, 'Statement handle attribute "pg_type" works');
+$sth->finish();
+
+#
+# Test of the statement handle attribute "pg_oid_status"
+#
+
+$SQL = "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+$/, 'Statement handle attribute "pg_oid_status" returned a numeric value after insert');
+
+#
+# Test of the statement handle attribute "pg_cmd_status"
+#
+
+## INSERT DELETE UPDATE SELECT
+for ("INSERT INTO dbd_pg_test (id,val) VALUES (400, 'lime')",
+ "DELETE FROM dbd_pg_test WHERE id=1",
+ "UPDATE dbd_pg_test SET id=2 WHERE id=2",
+ "SELECT * FROM dbd_pg_test"
+ ) {
+ my $expected = substr($_,0,6);
+ $sth = $dbh->prepare($_);
+ $sth->execute();
+ $result = $sth->{pg_cmd_status};
+ $sth->finish();
+ like ( $result, qr/^$expected/, qq{Statement handle attribute "pg_cmd_status" works for '$expected'});
+}
+
+#
+# Test of the handle attribute "Active"
+#
+
+$attrib = $dbh->{Active};
+is( $attrib, 1, 'Database handle attribute "Active" is true while connected');
+
+$sth = $dbh->prepare("SELECT 123 UNION SELECT 456");
+$attrib = $sth->{Active};
+is($attrib, '', 'Statement handle attribute "Active" is false before SELECT');
+$sth->execute();
+$attrib = $sth->{Active};
+is($attrib, 1, 'Statement handle attribute "Active" is true after SELECT');
+my $row = $sth->fetchrow_arrayref();
+$attrib = $sth->{Active};
+is($attrib, 1, 'Statement handle attribute "Active" is true when rows remaining');
+$sth->finish();
+$attrib = $sth->{Active};
+is($attrib, '', 'Statement handle attribute "Active" is false after finish called');
+
+#
+# Test of the handle attribute "Kids"
+#
+
+$attrib = $dbh->{Kids};
+is( $attrib, 1, 'Database handle attribute "Kids" is set properly');
+my $sth2 = $dbh->prepare("SELECT 234");
+$attrib = $dbh->{Kids};
+is( $attrib, 2, 'Database handle attribute "Kids" works');
+$attrib = $sth2->{Kids};
+is( $attrib, 0, 'Statement handle attribute "Kids" is zero');
+
+#
+# Test of the handle attribute "ActiveKids"
+#
+
+$attrib = $dbh->{ActiveKids};
+is( $attrib, 0, 'Database handle attribute "ActiveKids" is set properly');
+$sth2 = $dbh->prepare("SELECT 234");
+$sth2->execute();
+$attrib = $dbh->{ActiveKids};
+is( $attrib, 1, 'Database handle attribute "ActiveKids" works');
+$attrib = $sth2->{ActiveKids};
+is( $attrib, 0, 'Statement handle attribute "ActiveKids" is zero');
+
+#
+# Test of the handle attribute "CachedKids"
+#
+
+$attrib = $dbh->{CachedKids};
+ok( !$attrib, 'Database handle attribute "CachedKids" is set properly');
+
+#
+# Test of the handle attribute "CompatMode"
+#
+
+$attrib = $dbh->{CompatMode};
+ok( !$attrib, 'Database handle attribute "CompatMode" is set properly');
+
+#
+# Test of the handle attribute PrintError
+#
+
+$attrib = $dbh->{PrintError};
+is( $attrib, '', 'Database handle attribute "PrintError" is set properly');
+
+
+# Make sure that warnings are sent back to the client
+# We assume that older servers are okay
+my $client_level = '';
+if ($pgversion >= 70300) {
+ $sth = $dbh->prepare("SHOW client_min_messages");
+ $sth->execute();
+ $client_level = $sth->fetchall_arrayref()->[0][0];
+}
+
+if ($client_level eq "error") {
+ SKIP: {
+ skip qq{Cannot test "PrintError" attribute because client_min_messages is set to 'error'}, 2;
+ }
+ SKIP: {
+ skip qq{Cannot test "RaiseError" attribute because client_min_messages is set to 'error'}, 2;
+ }
+ SKIP: {
+ skip qq{Cannot test "HandleError" attribute because client_min_messages is set to 'error'}, 2;
+ }
+}
+else {
+ $SQL = "Testing the DBD::Pg modules error handling -?-";
+ {
+ $warning = '';
+ local $SIG{__WARN__} = sub { $warning = shift; };
+ $dbh->{RaiseError} = 0;
+
+ $dbh->{PrintError} = 1;
+ $sth = $dbh->prepare($SQL);
+ $sth->execute();
+ ok( $warning, 'Warning thrown when database handle attribute "PrintError" is on');
+
+ undef $warning;
+ $dbh->{PrintError} = 0;
+ $sth = $dbh->prepare($SQL);
+ $sth->execute();
+ ok( !$warning, 'No warning thrown when database handle attribute "PrintError" is off');
+ }
+}
+
+#
+# Test of the handle attribute RaiseError
+#
+
+if ($client_level ne "error") {
+ $dbh->{RaiseError} = 0;
+ eval {
+ $sth = $dbh->prepare($SQL);
+ $sth->execute();
+ };
+ ok (!$@, 'No error produced when database handle attribute "RaiseError" is off');
+
+ $dbh->{RaiseError} = 1;
+ eval {
+ $sth = $dbh->prepare($SQL);
+ $sth->execute();
+ };
+ ok ($@, 'Error produced when database handle attribute "RaiseError" is off');
+}
+
+
+#
+# Test of the handle attribute HandleError
+#
+
+$attrib = $dbh->{HandleError};
+ok( !$attrib, 'Database handle attribute "HandleError" is set properly');
+
+if ($client_level ne "error") {
+
+ undef $warning;
+ $dbh->{HandleError} = sub { $warning = shift; };
+ $sth = $dbh->prepare($SQL);
+ $sth->execute();
+ ok( $warning, 'Database handle attribute "HandleError" works');
+ # Test changing values
+ undef $warning;
+ $dbh->{HandleError} = sub { $_[0] = "Slonik $_[0]"; 0; };
+ eval {
+ $sth = $dbh->prepare($SQL);
+ $sth->execute();
+ };
+ like($@, qr/^Slonik/, 'Database handle attribute "HandleError" modifies error messages');
+ $dbh->{HandleError}= undef;
+ $dbh->rollback();
+}
+
+
+#
+# Not supported yet: ShowErrorStatement
+#
+
+#
+# Test of the handle attribute TraceLevel
+#
+
+$attrib = $dbh->{TraceLevel};
+like($attrib, qr/^\d$/, qq{Database handle attribute "TraceLevel" returns a number ($attrib)});
+
+#
+# Test of the handle attribute FetchHashKeyName
+#
+
+# The default is mixed case ("NAME");
+$attrib = $dbh->{FetchHashKeyName};
+is( $attrib, 'NAME', 'Database handle attribute "FetchHashKeyName" is set properly');
+
+$SQL = qq{SELECT "CaseTest" FROM dbd_pg_test};
+$sth = $dbh->prepare($SQL);
+$sth->execute();
+my ($colname) = keys %{$sth->fetchrow_hashref()};
+is( $colname, 'CaseTest', 'Database handle attribute "FetchHashKeyName" works with the default value of NAME');
+$sth->finish();
+
+$dbh->{FetchHashKeyName} = "NAME_lc";
+$attrib = $dbh->{FetchHashKeyName};
+is( $attrib, 'NAME_lc', 'Database handle attribute "FetchHashKeyName" can be changed');
+
+$sth = $dbh->prepare($SQL);
+$sth->execute();
+($colname) = keys %{$sth->fetchrow_hashref()};
+is( $colname, 'casetest', 'Database handle attribute "FetchHashKeyName" works with a value of NAME_lc');
+$sth->finish();
+
+$dbh->{FetchHashKeyName} = "NAME_uc";
+$sth = $dbh->prepare($SQL);
+$sth->execute();
+($colname) = keys %{$sth->fetchrow_hashref()};
+is( $colname, 'CASETEST', 'Database handle attribute "FetchHashKeyName" works with a value of NAME_uc');
+$sth->finish();
+$dbh->{FetchHashKeyName} = "NAME";
+
+#
+# Test of the handle attribute ChopBlanks
+#
+
+
+$attrib = $dbh->{ChopBlanks};
+ok( !$attrib, 'Database handle attribute "ChopBlanks" is set properly');
+
+$dbh->do("DELETE FROM dbd_pg_test");
+$dbh->do(q{INSERT INTO dbd_pg_test (id, fixed, val) VALUES (3, ' Fig', ' Raspberry ')});
+
+$dbh->{ChopBlanks} = 0;
+my ($val) = $dbh->selectall_arrayref(q{SELECT fixed FROM dbd_pg_test WHERE id = 3})->[0][0];
+is( $val, ' Fig ', 'Database handle attribute "ChopBlanks" = 0 returns correct value for fixed-length column');
+($val) = $dbh->selectrow_array(q{SELECT val FROM dbd_pg_test WHERE id = 3});
+is( $val, ' Raspberry ', 'Database handle attribute "ChopBlanks" = 0 returns correct value for variable-length column');
+
+$dbh->{ChopBlanks}=1;
+
+($val) = $dbh->selectall_arrayref(q{SELECT fixed FROM dbd_pg_test WHERE id = 3})->[0][0];
+is( $val, ' Fig', 'Database handle attribute "ChopBlanks" = 1 returns correct value for fixed-length column');
+
+($val) = $dbh->selectrow_array(q{SELECT val FROM dbd_pg_test WHERE id = 3});
+is( $val, ' Raspberry ', 'Database handle attribute "ChopBlanks" = 1 returns correct value for variable-length column');
+$dbh->do("DELETE from dbd_pg_test");
+
+#
+# Test of the handle attribute LongReadLen
+#
+
+$attrib = $dbh->{LongReadLen};
+ok( $attrib, 'Handle attribute "LongReadLen" has been set properly');
+
+#
+# Test of the handle attribute LongTruncOk
+#
+
+$attrib = $dbh->{LongTruncOk};
+ok( !$attrib, 'Handle attribute "LongTruncOk" has been set properly');
+
+#
+# Test of the handle attribute TaintIn
+#
+
+$attrib = $dbh->{TaintIn};
+is( $attrib, '', 'Handle attribute "TaintIn" has been set properly');
+
+#
+# Test of the handle attribute TaintOut
+#
+
+$attrib = $dbh->{TaintOut};
+is( $attrib, '', 'Handle attribute "TaintOut" has been set properly');
+
+#
+# Test of the handle attribute Taint
+#
+$attrib = $dbh->{Taint};
+is( $attrib, '', 'Handle attribute "Taint" has been set properly');
+
+$dbh->{Taint}=1;
+
+$attrib = $dbh->{Taint};
+is( $attrib, 1, 'The value of handle attribute "Taint" can be changed');
+$attrib = $dbh->{TaintIn};
+is( $attrib, 1, 'Changing handle attribute "Taint" changes "TaintIn"');
+$attrib = $dbh->{TaintOut};
+is( $attrib, 1, 'Changing handle attribute "Taint" changes "TaintOut"');
+
+#
+# Not tested: handle attribute Profile
+#
+
+#
+# Test of the database handle attribute InactiveDestroy
+# This one must be the last test performed!
+#
+
+$attrib = $dbh->{InactiveDestroy};
+ok( !$attrib, 'Database handle attribute "InactiveDestroy" is set properly');
+
+# Disconnect in preparation for the fork tests
+ok( $dbh->disconnect(), 'Disconnect from database');
+$attrib = $dbh->{Active};
+is( $attrib, '', 'Database handle attribute "Active" is false after disconnect');
+
+if ($^O =~ /MSWin/) {
+ SKIP: {
+ skip 'Cannot test database handle "InactiveDestroy" on a non-forking system', 4;
+ }
+}
+else {
+ require Test::Simple;
+ if ($Test::Simple::VERSION < 0.47) {
+ SKIP: {
+ skip 'Test::Simple version 0.47 or better required for testing of attribute "InactiveDestroy"', 4;
+ }
+ }
+ else {
+
+ # 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 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 0, PrintError => 0, AutoCommit => 1});
+
+ $sth = $dbh->prepare($SQL);
+ $sth->execute(1);
+ $sth->finish();
+
+ # Desired flow: parent test, child test, child kill, parent test
+
+ if (fork) {
+ $sth->execute(1);
+ my $val = $sth->fetchall_arrayref()->[0][0];
+ is( $val, $answer, qq{Parent in fork test is working properly ("InactiveDestroy" = $destroy)});
+ # Let the child exit
+ 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) {
+ # The database handle should still be active
+ ok ( $dbh->ping(), qq{Ping works after the child has exited ("InactiveDestroy" = $destroy)});
+ my $state = $dbh->state();
+ is( $state, '', qq{Successful ping returns a SQLSTATE code of 00000 (empty string)});
+ ## The statement handle should still be usable
+ $sth->execute(1);
+ my $val = $sth->fetchall_arrayref()->[0][0];
+ is ($val, $answer, qq{Statement handle works after forking});
+ }
+ else {
+ # The database handle should be dead
+ ok ( !$dbh->ping(), qq{Ping fails after the child has exited ("InactiveDestroy" = $destroy)});
+ my $state = $dbh->state();
+ is( $state, 'S8006', qq{Failed ping returns a SQLSTATE code of S8006});
+ if ($pglibversion < 70400) {
+ SKIP: {
+ skip "Can't determine advanced ping with old 7.2 server libraries", 1;
+ }
+ }
+ else {
+ ok ( -2==$dbh->pg_ping(), qq{pg_ping gives an error code of -2 after the child has exited ("InactiveDestroy" = $destroy)});
+ }
+ }
+ }
+ }
+}
Added: packages/libdbd-pg-perl/branches/upstream/current/t/03dbmethod.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/03dbmethod.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/03dbmethod.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,975 @@
+#!perl -w
+
+# Test of the database handle methods
+# The following methods are *not* (explicitly) tested here:
+# "clone"
+# "data_sources"
+# "disconnect"
+# "take_imp_data"
+# "lo_import"
+# "lo_export"
+# "pg_savepoint", "pg_release", "pg_rollback_to"
+# "pg_putline", "pg_getline", "pg_endcopy"
+
+use Test::More;
+use DBI qw(:sql_types);
+use strict;
+$|=1;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 160;
+}
+else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0});
+ok( defined $dbh, "Connect to database for database handle method testing");
+
+my $schema = '';
+my $got73 = DBD::Pg::_pg_use_catalog($dbh);
+if ($got73) {
+ $schema = exists $ENV{DBD_SCHEMA} ? $ENV{DBD_SCHEMA} : 'public';
+ $dbh->do("SET search_path TO " . $dbh->quote_identifier($schema));
+}
+
+my ($SQL, $sth, $result, @result, $expected, $warning, $rows);
+
+# Quick simple "tests"
+
+$dbh->do(""); ## This used to break, so we keep it as a test...
+$SQL = "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
+
+$dbh->do("DELETE FROM dbd_pg_test");
+$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
+#
+
+if ($DBI::VERSION <= 1.42) {
+ SKIP: {
+ skip 'DBI must be at least version 1.43 to completely test database handle method "last_insert_id"', 5;
+ }
+}
+else {
+ $dbh->commit();
+ eval {
+ $result = $dbh->last_insert_id(undef,undef,undef,undef);
+ };
+ ok( $@, 'DB handle method "last_insert_id" given an error when no arguments are given');
+
+ eval {
+ $result = $dbh->last_insert_id(undef,undef,undef,undef,{sequence=>'dbd_pg_nonexistentsequence_test'});
+ };
+ ok( $@, 'DB handle method "last_insert_id" fails when given a non-existent sequence');
+ $dbh->rollback();
+
+ eval {
+ $result = $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef);
+ };
+ ok( $@, 'DB handle method "last_insert_id" fails when given a non-existent table');
+ $dbh->rollback();
+
+ eval {
+ $result = $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef,{sequence=>'dbd_pg_sequence'});
+ };
+ ok( ! $@, 'DB handle method "last_insert_id" works when given a valid sequence and an invalid table');
+ like( $result, qr{^\d+$}, 'DB handle method "last_insert_id" returns a numeric value');
+}
+
+eval {
+ $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef);
+};
+ok( ! $@, 'DB handle method "last_insert_id" works when given a valid table');
+
+eval {
+ $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef,'');
+};
+ok( ! $@, 'DB handle method "last_insert_id" works when given an empty attrib');
+
+eval {
+ $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef);
+};
+ok( ! $@, 'DB handle method "last_insert_id" works when called twice (cached) given a valid table');
+
+#
+# Test of the "selectrow_array" database handle method
+#
+
+$SQL = "SELECT id FROM dbd_pg_test ORDER BY id";
+ at result = $dbh->selectrow_array($SQL);
+$expected = [10];
+is_deeply(\@result, $expected, 'DB handle method "selectrow_array" works');
+
+#
+# Test of the "selectrow_arrayref" database handle method
+#
+
+$result = $dbh->selectrow_arrayref($SQL);
+is_deeply($result, $expected, 'DB handle method "selectrow_arrayref" works');
+
+$sth = $dbh->prepare($SQL);
+$result = $dbh->selectrow_arrayref($sth);
+is_deeply($result, $expected, 'DB handle method "selectrow_arrayref" works with a prepared statement handle');
+
+#
+# Test of the "selectrow_hashref" database handle method
+#
+
+$result = $dbh->selectrow_hashref($SQL);
+$expected = {id => 10};
+is_deeply($result, $expected, 'DB handle method "selectrow_hashref" works');
+
+$sth = $dbh->prepare($SQL);
+$result = $dbh->selectrow_hashref($sth);
+is_deeply($result, $expected, 'DB handle method "selectrow_hashref" works with a prepared statement handle');
+
+#
+# Test of the "selectall_arrayref" database handle method
+#
+
+$result = $dbh->selectall_arrayref($SQL);
+$expected = [[10],[11],[12]];
+is_deeply($result, $expected, 'DB handle method "selectall_arrayref" works');
+
+$sth = $dbh->prepare($SQL);
+$result = $dbh->selectall_arrayref($sth);
+is_deeply($result, $expected, 'DB handle method "selectall_arrayref" works with a prepared statement handle');
+
+$result = $dbh->selectall_arrayref($SQL, {MaxRows => 2});
+$expected = [[10],[11]];
+is_deeply($result, $expected, 'DB handle method "selectall_arrayref" works with the MaxRows 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, 'DB handle method "selectall_arrayref" works with the Slice attribute');
+
+#
+# Test of the "selectall_hashref" database handle method
+#
+
+$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, 'DB handle method "selectall_hashref" works');
+
+$sth = $dbh->prepare($SQL);
+$result = $dbh->selectall_hashref($sth,'id');
+is_deeply($result, $expected, 'DB handle method "selectall_hashref" works with a prepared statement handle');
+
+#
+# Test of the "selectcol_arrayref" database handle method
+#
+
+$result = $dbh->selectcol_arrayref($SQL);
+$expected = [10,11,12];
+is_deeply($result, $expected, 'DB handle method "selectcol_arrayref" works');
+
+$result = $dbh->selectcol_arrayref($sth);
+is_deeply($result, $expected, 'DB handle method "selectcol_arrayref" works with a prepared statement handle');
+
+$result = $dbh->selectcol_arrayref($SQL, {Columns=>[2,1]});
+$expected = ['Roseapple',10,'Pineapple',11,'Kiwi',12];
+is_deeply($result, $expected, 'DB handle method "selectcol_arrayref" works with the Columns attribute');
+
+if ($DBI::VERSION < 1.36) {
+ SKIP: {
+ skip 'DBI must be at least version 1.36 to test "selectcol_arrayref" with "MaxRows"', 1;
+ }
+}
+else {
+ $result = $dbh->selectcol_arrayref($SQL, {Columns=>[2], MaxRows => 1});
+ $expected = ['Roseapple'];
+ is_deeply($result, $expected, 'DB handle method "selectcol_arrayref" works with the MaxRows attribute');
+}
+
+#
+# Test of the "commit" and "rollback" database handle methods
+#
+
+{
+ local $SIG{__WARN__} = sub { $warning = shift; };
+ $dbh->{AutoCommit}=0;
+
+ $warning="";
+ $dbh->commit();
+ ok( ! length $warning, 'DB handle method "commit" gives no warning when AutoCommit is off');
+ $warning="";
+ $dbh->rollback();
+ ok( ! length $warning, 'DB handle method "rollback" gives no warning when AutoCommit is off');
+
+ ok( $dbh->commit, 'DB handle method "commit" returns true');
+ ok( $dbh->rollback, 'DB handle method "rollback" returns true');
+
+ $dbh->{AutoCommit}=1;
+ $warning="";
+ $dbh->commit();
+ ok( length $warning, 'DB handle method "commit" gives a warning when AutoCommit is on');
+ $warning="";
+ $dbh->rollback();
+ ok( length $warning, 'DB handle method "rollback" gives a warning when AutoCommit is on');
+
+
+}
+
+#
+# Test of the "begin_work" database handle method
+#
+
+$dbh->{AutoCommit}=0;
+eval {
+ $dbh->begin_work();
+};
+ok( $@, 'DB handle method "begin_work" gives a warning when AutoCommit is on');
+
+$dbh->{AutoCommit}=1;
+eval {
+ $dbh->begin_work();
+};
+ok( !$@, 'DB handle method "begin_work" gives no warning when AutoCommit is off');
+ok( !$dbh->{AutoCommit}, 'DB handle method "begin_work" sets AutoCommit to off');
+$dbh->commit();
+ok( $dbh->{AutoCommit}, 'DB handle method "commit" after "begin_work" sets AutoCommit to on');
+$dbh->{AutoCommit}=0;
+
+#
+# Test of the "get_info" database handle method
+#
+
+eval {
+ $dbh->get_info();
+};
+ok ($@, 'DB handle method "get_info" with no arguments gives an error');
+
+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) {
+ my $back = $dbh->get_info($_);
+ ok( defined $back, qq{DB handle method "get_info" works with a value of "$_"});
+ my $forth = $dbh->get_info($get_info{$_});
+ ok( defined $forth, qq{DB handle method "get_info" works with a value of "$get_info{$_}"});
+ is( $back, $forth, qq{DB handle method "get_info" returned matching values});
+}
+
+# Make sure odbcversion looks normal
+my $odbcversion = $dbh->get_info(18);
+like( $odbcversion, qr{^([1-9]\d|\d[1-9])\.\d\d\.\d\d00$}, qq{DB handle method "get_info" returns a valid looking ODBCVERSION string});
+
+# Testing max connections is good as this info is dynamic
+my $maxcon = $dbh->get_info(0);
+like( $maxcon, qr{^\d+$}, qq{DB handle method "get_info" returns a number for SQL_MAX_DRIVER_CONNECTIONS});
+
+#
+# Test of the "table_info" database handle method
+#
+
+$sth = $dbh->table_info('', '', 'dbd_pg_test', '');
+my $number = $sth->rows();
+ok( $number, 'DB handle method "table_info" works when called with undef arguments');
+
+# Check required minimum fields
+$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, {}, 'DB handle method "table_info" returns fields required by DBI');
+
+## 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');
+
+$sth = $dbh->table_info(undef,undef,undef,"TABLE,VIEW");
+$number = $sth->rows();
+cmp_ok( $number, '>', 1, qq{DB handle method "table_info" returns correct number of rows when given a 'TABLE,VIEW' type argument});
+
+$sth = $dbh->table_info(undef,undef,undef,"DUMMY");
+$rows = $sth->rows();
+is( $rows, $number, 'DB handle method "table_info" returns correct number of rows when given an invalid type argument');
+
+$sth = $dbh->table_info(undef,undef,undef,"VIEW");
+$rows = $sth->rows();
+cmp_ok( $rows, '<', $number, qq{DB handle method "table_info" returns correct number of rows when given a 'VIEW' type argument});
+
+$sth = $dbh->table_info(undef,undef,undef,"TABLE");
+$rows = $sth->rows();
+cmp_ok( $rows, '<', $number, qq{DB handle method "table_info" returns correct number of rows when given a 'TABLE' type argument});
+
+# Test listing catalog names
+$sth = $dbh->table_info('%', '', '');
+ok( $sth, 'DB handle method "table_info" works when called with a catalog of %');
+
+# Test listing schema names
+$sth = $dbh->table_info('', '%', '');
+ok( $sth, 'DB handle method "table_info" works when called with a schema of %');
+
+# Test listing table types
+$sth = $dbh->table_info('', '', '', '%');
+ok( $sth, 'DB handle method "table_info" works when called with a type of %');
+
+#
+# Test of the "column_info" database handle method
+#
+
+# Check required minimum fields
+$sth = $dbh->column_info('','','dbd_pg_test','score');
+$result = $sth->fetchall_arrayref({});
+ at 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, {}, 'DB handle method "column_info" returns fields required by DBI');
+
+# Check that pg_constraint was populated
+$result = $result->[0];
+like( $result->{pg_constraint}, qr/score/, qq{DB handle method "column info" 'pg_constraint' returns a value for constrained columns});
+
+# Check that it is not populated for non-constrained columns
+$sth = $dbh->column_info('','','dbd_pg_test','id');
+$result = $sth->fetchall_arrayref({})->[0];
+is( $result->{pg_constraint}, undef, qq{DB handle method "column info" 'pg_constraint' returns undef for non-constrained columns});
+
+# Check the rest of the custom "pg" columns
+is( $result->{pg_type}, 'integer', qq{DB handle method "column_info" returns good value for 'pg_type'});
+
+## Check some of the returned fields:
+is( $result->{TABLE_CAT}, undef, 'DB handle method "column_info" returns proper TABLE_CAT');
+is( $result->{TABLE_NAME}, 'dbd_pg_test', 'DB handle method "column_info returns proper TABLE_NAME');
+is( $result->{COLUMN_NAME}, 'id', 'DB handle method "column_info" returns proper COLUMN_NAME');
+is( $result->{DATA_TYPE}, 4, 'DB handle method "column_info" returns proper DATA_TYPE');
+is( $result->{COLUMN_SIZE}, 4, 'DB handle method "column_info" returns proper COLUMN_SIZE');
+is( $result->{NULLABLE}, '0', 'DB handle method "column_info" returns proper NULLABLE');
+is( $result->{REMARKS}, 'Bob is your uncle', 'DB handle method "column_info" returns proper REMARKS');
+is( $result->{COLUMN_DEF}, undef, 'DB handle method "column_info" returns proper COLUMN_DEF');
+is( $result->{ORDINAL_POSITION}, 1, 'DB handle method "column_info" returns proper ORDINAL_POSITION');
+is( $result->{IS_NULLABLE}, 'NO', 'DB handle method "column_info" returns proper IS_NULLABLE');
+is( $result->{pg_type}, 'integer', 'DB handle method "column_info" returns proper pg_type');
+
+#
+# Test of the "primary_key_info" database handle method
+#
+
+# Check required minimum fields
+$sth = $dbh->primary_key_info('','','dbd_pg_test');
+$result = $sth->fetchall_arrayref({});
+ at 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, {}, 'DB handle method "primary_key_info" returns required fields');
+
+## Check some of the returned fields:
+$result = $result->[0];
+is( $result->{TABLE_CAT}, undef, 'DB handle method "primary_key_info" returns proper TABLE_CAT');
+is( $result->{TABLE_NAME}, 'dbd_pg_test', 'DB handle method "primary_key_info" returns proper TABLE_NAME');
+is( $result->{COLUMN_NAME}, 'id', 'DB handle method "primary_key_info" returns proper COLUMN_NAME');
+cmp_ok( $result->{KEY_SEQ}, '>=', 1, 'DB handle method "primary_key_info" returns proper KEY_SEQ');
+
+#
+# Test of the "primary_key" database handle method
+#
+
+ at result = $dbh->primary_key('', '', 'dbd_pg_test');
+$expected = ['id'];
+is_deeply( \@result, $expected, 'DB handle method "primary_key" works');
+
+ at result = $dbh->primary_key('', '', 'dbd_pg_test_do_not_create_this_table');
+$expected = [];
+is_deeply( \@result, $expected, 'DB handle method "primary_key" returns empty list for invalid table');
+
+#
+# Test of the "foreign_key_info" database handle method
+#
+
+## Neither pktable nor fktable specified
+$sth = $dbh->foreign_key_info(undef,undef,undef,undef,undef,undef);
+is ($sth, undef, 'DB handle method "foreign_key_info" returns undef: no pk / no fk');
+
+## All foreign_key_info tests are meaningless for old servers
+if (! $got73) {
+ SKIP: {
+ skip qq{Cannot test DB handle method "foreign_key_info" on pre-7.3 servers.}, 16;
+ }
+}
+else {
+
+# 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
+$sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,undef);
+is ($sth, undef, 'DB handle method "foreign_key_info" returns undef: bad pk / no fk');
+
+## Invalid foreign table
+$sth = $dbh->foreign_key_info(undef,undef,undef,undef,undef,'dbd_pg_test9');
+is ($sth, undef, 'DB handle method "foreign_key_info" returns undef: no pk / bad fk');
+
+## Both primary and foreign are invalid
+$sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,'dbd_pg_test9');
+is ($sth, undef, 'DB handle method "foreign_key_info" returns undef: bad fk / bad fk');
+
+## 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
+$sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test1',undef,undef,undef);
+is ($sth, undef, 'DB handle method "foreign_key_info" returns undef: good pk (but unreferenced)');
+
+## 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
+$sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,'dbd_pg_test2');
+is ($sth, undef, 'DB handle method "foreign_key_info" returns undef: bad pk / good fk');
+
+## Good primary, good foreign, bad schemas
+my $testschema = "dbd_pg_test_badschema11";
+$sth = $dbh->foreign_key_info(undef,$testschema,'dbd_pg_test1',undef,undef,'dbd_pg_test2');
+is ($sth, undef, 'DB handle method "foreign_key_info" returns undef: good pk / good fk / bad pk schema');
+$sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test1',undef,$testschema,'dbd_pg_test2');
+is ($sth, undef, 'DB handle method "foreign_key_info" returns undef: good pk / good fk / bad fk schema');
+
+## Good primary
+$sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test1',undef,undef,undef);
+$result = $sth->fetchall_arrayref({});
+
+# Check required minimum fields
+$result = $sth->fetchall_arrayref({});
+ at 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, {}, 'DB handle method "foreign_key_info" returns fields required by DBI');
+
+## Good primary
+$sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test1',undef,undef,undef);
+$result = $sth->fetchall_arrayref();
+my $fk1 = [
+ undef,
+ $schema,
+ 'dbd_pg_test1',
+ 'a',
+ undef,
+ $schema,
+ 'dbd_pg_test2',
+ 'f2',
+ 2,
+ 3,
+ 3,
+ 'dbd_pg_test2_fk1',
+ 'dbd_pg_test1_pk',
+ '7',
+ 'PRIMARY',
+ 'int4',
+ 'int4'
+ ];
+$expected = [$fk1];
+is_deeply ($result, $expected, 'DB handle method "foreign_key_info" works for good pk');
+
+## Same with explicit table
+$sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test1',undef,undef,'dbd_pg_test2');
+$result = $sth->fetchall_arrayref();
+is_deeply ($result, $expected, 'DB handle method "foreign_key_info" works for good pk / good fk');
+
+## Foreign table only
+$sth = $dbh->foreign_key_info(undef,undef,undef,undef,undef,'dbd_pg_test2');
+$result = $sth->fetchall_arrayref();
+is_deeply ($result, $expected, 'DB handle method "foreign_key_info" works for good fk');
+
+## Add a foreign key to an explicit unique constraint
+{
+ 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,'dbd_pg_test1',undef,undef,undef);
+$result = $sth->fetchall_arrayref();
+my $fk2 = [
+ undef,
+ $schema,
+ 'dbd_pg_test1',
+ 'b',
+ undef,
+ $schema,
+ 'dbd_pg_test2',
+ '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, 'DB handle method "foreign_key_info" works for good pk / explicit fk');
+
+## Add a foreign key to an implicit unique constraint (a unique index on a column)
+{
+ 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,'dbd_pg_test1',undef,undef,undef);
+$result = $sth->fetchall_arrayref();
+my $fk3 = [
+ undef,
+ $schema,
+ 'dbd_pg_test1',
+ 'c',
+ undef,
+ $schema,
+ 'dbd_pg_test2',
+ '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, 'DB handle method "foreign_key_info" works for good pk / implicit fk');
+
+## Create another foreign key table to point to the first (primary) table
+{
+ 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,'dbd_pg_test1',undef,undef,undef);
+$result = $sth->fetchall_arrayref();
+my $fk4 = [
+ undef,
+ $schema,
+ 'dbd_pg_test1',
+ 'a',
+ undef,
+ $schema,
+ 'dbd_pg_test3',
+ '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, 'DB handle method "foreign_key_info" works for multiple fks');
+
+## Test that explicit naming two tables brings back only those tables
+$sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test1',undef,undef,'dbd_pg_test3');
+$result = $sth->fetchall_arrayref();
+$expected = [$fk4];
+is_deeply ($result, $expected, 'DB handle method "foreign_key_info" works for good pk / good fk (only)');
+
+## Multi-column madness
+{
+ 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,'dbd_pg_test1',undef,undef,'dbd_pg_test2');
+$result = $sth->fetchall_arrayref();
+## "dbd_pg_test2_fk4" FOREIGN KEY (f1, f3, f2) REFERENCES dbd_pg_test1(c, a, b)
+my $fk5 = [
+ undef,
+ $schema,
+ 'dbd_pg_test1',
+ 'c',
+ undef,
+ $schema,
+ 'dbd_pg_test2',
+ '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, 'DB handle method "foreign_key_info" works for multi-column keys');
+
+# Clean everything up
+{
+ $dbh->do("DROP TABLE dbd_pg_test3");
+ $dbh->do("DROP TABLE dbd_pg_test2");
+ $dbh->do("DROP TABLE dbd_pg_test1");
+}
+
+} # end giant foreign_key_info bypass
+
+#
+# Test of the "tables" database handle method
+#
+
+ at result = $dbh->tables('', '', 'dbd_pg_test', '');
+like( $result[0], qr/dbd_pg_test/, 'DB handle method "tables" works');
+
+ at result = $dbh->tables('', '', 'dbd_pg_test', '', {pg_noprefix => 1});
+is( $result[0], 'dbd_pg_test', 'DB handle method "tables" works with a "pg_noprefix" attribute');
+
+#
+# Test of the "type_info_all" database handle method
+#
+
+$result = $dbh->type_info_all();
+
+# Quick check that the structure looks correct
+my $badresult="";
+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, 'DB handle method "type_info_all" returns a valid structure');
+
+#
+# Test of the "type_info" database handle method
+#
+
+# Check required minimum fields
+$result = $dbh->type_info(4);
+ at 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, {}, 'DB handle method "type_info" returns fields required by DBI');
+
+#
+# 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{''},
+ );
+
+for (keys %quotetests) {
+ $result = $dbh->quote($_);
+ is( $result, $quotetests{$_}, qq{DB handle method "quote" works with a value of "$_"});
+}
+
+## Test timestamp - should quote as a string
+my $tstype = 93;
+my $testtime = "2006-01-28 11:12:13";
+is( $dbh->quote( $testtime, $tstype ), qq{'$testtime'}, qq{DB handle method "quote" work on timestamp});
+
+my $foo;
+{
+ no warnings; ## Perl does not like undef args
+ is( $dbh->quote($foo), q{NULL}, 'DB handle method "quote" works with an undefined value');
+}
+is( $dbh->quote(1, 4), 1, 'DB handle method "quote" works with a supplied data type argument');
+
+
+#
+# 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{""},
+ );
+for (keys %quotetests) {
+ $result = $dbh->quote_identifier($_);
+ is( $result, $quotetests{$_}, qq{DB handle method "quote_identifier" works with a value of "$_"});
+}
+is( $dbh->quote_identifier(undef), q{}, 'DB handle method "quote_identifier" works with an undefined value');
+
+is ($dbh->quote_identifier( undef, 'Her schema', 'My table' ), q{"Her schema"."My table"},
+ 'DB handle method "quote_identifier" works with schemas');
+
+
+#
+# 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.
+$result = $dbh->func('dbd_pg_test', 'table_attributes');
+$result = $result->[0];
+ at required =
+ (qw(NAME TYPE SIZE NULLABLE DEFAULT CONSTRAINT PRIMARY_KEY REMARKS));
+undef %missing;
+for (@required) {
+ $missing{$_}++ if ! exists $result->{$_};
+}
+is_deeply( \%missing, {}, 'DB handle method "table_attributes" returns the expected fields');
+
+#
+# Test of the "lo_*" database handle methods
+#
+
+$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 = $dbh->func($R, 'lo_creat');
+like($object, qr/^\d+$/o, 'DB handle method "lo_creat" returns a valid descriptor for reading');
+$object = $dbh->func($W, 'lo_creat');
+like($object, qr/^\d+$/o, 'DB handle method "lo_creat" returns a valid descriptor for writing');
+
+my $handle = $dbh->func($object, $W, 'lo_open');
+like($handle, qr/^\d+$/o, 'DB handle method "lo_open" returns a valid descriptor for writing');
+
+$result = $dbh->func($handle, 0, 0, 'lo_lseek');
+cmp_ok($result, '==', 0, 'DB handle method "lo_lseek" works when writing');
+
+my $buf = 'tangelo mulberry passionfruit raspberry plantain' x 500;
+$result = $dbh->func($handle, $buf, length($buf), 'lo_write');
+is( $result, length($buf), 'DB handle method "lo_write" works');
+
+$result = $dbh->func($handle, 'lo_close');
+ok( $result, 'DB handle method "lo_close" works after write');
+
+# Reopen for reading
+$handle = $dbh->func($object, $R, 'lo_open');
+like($handle, qr/^\d+$/o, 'DB handle method "lo_open" returns a valid descriptor for reading');
+
+$result = $dbh->func($handle, 11, 0, 'lo_lseek');
+cmp_ok($result, '==', 11, 'DB handle method "lo_lseek" works when reading');
+
+$result = $dbh->func($handle, 'lo_tell');
+is( $result, 11, 'DB handle method "lo_tell" works');
+
+$dbh->func($handle, 0, 0, 'lo_lseek');
+
+my ($buf2,$data) = ('','');
+while ($dbh->func($handle, $data, 513, 'lo_read')) {
+ $buf2 .= $data;
+}
+is (length($buf), length($buf2), 'DB handle method "lo_read" read back the same data that was written');
+
+$result = $dbh->func($handle, 'lo_close');
+ok( $result, 'DB handle method "lo_close" works after read');
+
+$result = $dbh->func($object, 'lo_unlink');
+ok( $result, 'DB handle method "lo_unlink" works');
+
+#
+# Test of the "pg_notifies" database handle method
+#
+
+# $ret = $dbh->func('pg_notifies');
+# Returns either undef or a reference to two-element array [ $table,
+# $backend_pid ] of asynchronous notifications received.
+
+eval {
+ $dbh->func('pg_notifies');
+};
+ok( !$@, 'DB handle method "pg_notifies" does not throw an error');
+
+#
+# Test of the "getfd" database handle method
+#
+
+$result = $dbh->func('getfd');
+like( $result, qr/^\d+$/, 'DB handle method "getfd" returns a number');
+
+#
+# Test of the "state" database handle method
+#
+
+my ($pglibversion,$pgversion) = ($dbh->{pg_lib_version},$dbh->{pg_server_version});
+$result = $dbh->state();
+is( $result, "", qq{DB handle method "state" returns an empty string on success});
+
+eval {
+ $dbh->do("SELECT dbdpg_throws_an_error");
+};
+$result = $dbh->state();
+like( $result, qr/^[A-Z0-9]{5}$/, qq{DB handle method "state" returns a five-character code on error});
+$dbh->rollback();
+
+#
+# Test of the "ping" database handle method
+#
+
+ok( 1==$dbh->ping(), 'DB handle method "ping" returns 1 on an idle connection');
+
+$dbh->do("SELECT 123");
+
+$result = $pglibversion < 70400 ? 1 : 3;
+ok( $result==$dbh->ping(), 'DB handle method "ping" returns 3 for a good connection inside a transaction');
+
+$dbh->commit();
+
+ok( 1==$dbh->ping(), 'DB handle method "ping" returns 1 on an idle connection');
+
+my $mtvar; ## This is an implicit test of getline: please leave this var undefined
+
+if ($pglibversion < 70400 or $pgversion < 70300) {
+ SKIP: {
+ skip "Can't run advanced ping tests with older versions of Postgres", 14;
+ }
+}
+else {
+ $dbh->do("COPY dbd_pg_test(id,pname) TO STDOUT");
+ {
+ local $SIG{__WARN__} = sub {};
+ $dbh->pg_getline($mtvar,100);
+ ok( 2==$dbh->ping(), 'DB handle method "ping" returns 2 when in COPY IN state');
+ 1 while $dbh->pg_getline($mtvar,1000);
+ ok( 2==$dbh->ping(), 'DB handle method "ping" returns 2 immediately after COPY IN state');
+ }
+
+ $dbh->do("SELECT 123");
+
+ ok( 3==$dbh->ping(), 'DB handle method "ping" returns 3 for a good connection inside a transaction');
+
+ eval {
+ $dbh->do("DBD::Pg creating an invalid command for testing");
+ };
+ ok( 4==$dbh->ping(), 'DB handle method "ping" returns a 4 when inside a failed transaction');
+
+ $dbh->disconnect();
+ ok( 0==$dbh->ping(), 'DB handle method "ping" fails (returns 0) on a disconnected handle');
+
+ $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0});
+
+ ok( defined $dbh, "Reconnect to the database after disconnect");
+
+ #
+ # Test of the "pg_ping" database handle method
+ #
+
+ ok( 1==$dbh->pg_ping(), 'DB handle method "pg_ping" returns 1 on an idle connection');
+
+ $dbh->do("SELECT 123");
+
+ ok( 3==$dbh->pg_ping(), 'DB handle method "pg_ping" returns 3 for a good connection inside a transaction');
+
+ $dbh->commit();
+
+ ok( 1==$dbh->pg_ping(), 'DB handle method "pg_ping" returns 1 on an idle connection');
+
+ $dbh->do("COPY dbd_pg_test(id,pname) TO STDOUT");
+ $dbh->pg_getline($mtvar,100);
+ ok( 2==$dbh->pg_ping(), 'DB handle method "pg_ping" returns 2 when in COPY IN state');
+ 1 while $dbh->pg_getline($mtvar,1000);
+ ok( 2==$dbh->pg_ping(), 'DB handle method "pg_ping" returns 2 immediately after COPY IN state');
+
+ $dbh->do("SELECT 123");
+
+ ok( 3==$dbh->pg_ping(), 'DB handle method "pg_ping" returns 3 for a good connection inside a transaction');
+
+ eval {
+ $dbh->do("DBD::Pg creating an invalid command for testing");
+ };
+ ok( 4==$dbh->pg_ping(), 'DB handle method "pg_ping" returns a 4 when inside a failed transaction');
+
+ $dbh->disconnect();
+ ok( -1==$dbh->pg_ping(), 'DB handle method "pg_ping" fails (returns 0) on a disconnected handle');
+
+}
+
Added: packages/libdbd-pg-perl/branches/upstream/current/t/03smethod.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/03smethod.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/03smethod.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,385 @@
+#!perl -w
+
+# Test of the statement handle methods
+# The following methods are *not* currently tested here:
+# "bind_param_inout"
+# "execute"
+# "finish"
+# "dump_results"
+
+use Test::More;
+use DBI qw(:sql_types);
+use strict;
+$|=1;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 55;
+}
+else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0});
+ok( defined $dbh, "Connect to database for statement handle method testing");
+
+my $pglibversion = $dbh->{pg_lib_version};
+my $got73 = DBD::Pg::_pg_use_catalog($dbh);
+if ($got73) {
+ $dbh->do("SET search_path TO " . $dbh->quote_identifier
+ (exists $ENV{DBD_SCHEMA} ? $ENV{DBD_SCHEMA} : 'public'));
+}
+
+$dbh->do("DELETE FROM dbd_pg_test");
+my ($SQL, $sth, $sth2, $result, @result, $expected, $warning, $rows);
+
+#
+# Test of the prepare flags
+#
+
+$SQL = "SELECT id FROM dbd_pg_test WHERE id = ?";
+$sth = $dbh->prepare($SQL);
+$sth->execute(1);
+ok( $sth->execute, 'Prepare/execute with no flags works');
+$dbh->{pg_server_prepare} = 0;
+$sth = $dbh->prepare($SQL);
+$sth->execute(1);
+ok( $sth->execute, 'Prepare/execute with pg_server_prepare off at database handle works');
+## 7.4 does not have a full SSP implementation, so we simply skip these tests.
+if ($pglibversion >= 70400 and $pglibversion < 80000) {
+ SKIP: {
+ skip 'Not testing pg_server_prepare on 7.4-compiled servers', 2;
+ }
+}
+else {
+ $dbh->{pg_server_prepare} = 1;
+ $sth = $dbh->prepare($SQL);
+ $sth->execute(1);
+ ok( $sth->execute, 'Prepare/execute with pg_server_prepare on at database handle works');
+}
+
+## We must send a hashref as the final arg
+eval {
+ $sth = $dbh->prepare('SELECT 123', ['I am not a hashref!']);
+};
+like ($@, qr{not a hash}, qq{Prepare failes when sent a non-hashref});
+
+
+# Make sure that undefs are converted to NULL.
+$sth = $dbh->prepare('INSERT INTO dbd_pg_test (id, pdate) VALUES (?,?)');
+ok( $sth->execute(401, undef), "Prepare/execute with undef converted to NULL");
+$sth = $dbh->prepare($SQL, {pg_server_prepare => 0});
+$sth->execute(1);
+ok( $sth->execute, 'Prepare/execute with pg_server_prepare off at statement handle works');
+if ($pglibversion < 70400 or $pglibversion >= 80000) {
+ $sth = $dbh->prepare($SQL, {pg_server_prepare => 1});
+ $sth->execute(1);
+ ok( $sth->execute, 'Prepare/execute with pg_server_prepare on at statement handle works');
+}
+$dbh->{pg_prepare_now} = 1;
+$sth = $dbh->prepare($SQL);
+$sth->execute(1);
+ok( $sth->execute, 'Prepare/execute with pg_prepare_now on at database handle works');
+$dbh->{pg_prepare_now} = 0;
+$sth = $dbh->prepare($SQL);
+$sth->execute(1);
+ok( $sth->execute, 'Prepare/execute with pg_prepare_now off at database handle works');
+$sth = $dbh->prepare($SQL, {pg_prepare_now => 0});
+$sth->execute(1);
+ok( $sth->execute, 'Prepare/execute with pg_prepare_now off at statement handle works');
+$sth = $dbh->prepare($SQL, {pg_prepare_now => 1});
+$sth->execute(1);
+ok( $sth->execute, 'Prepare/execute with pg_prepare_now on at statement handle works');
+
+# Test using our own prepared statements
+my $pgversion = $dbh->{pg_server_version};
+if ($pgversion >= 70400) {
+ 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), 'Prepare/execute works with pg_prepare_name');
+ $dbh->do("DEALLOCATE $myname");
+}
+else {
+ pass("Skipping prepare statement tests for old servers");
+}
+
+
+#
+# Test of the "bind_param" statement handle method
+#
+
+$SQL = "SELECT id FROM dbd_pg_test WHERE id = ?";
+$sth = $dbh->prepare($SQL);
+ok( $sth->bind_param(1, 1), 'Statement handle method "bind_param" works when binding an int column with an int');
+ok( $sth->bind_param(1, 'foo'), 'Statement handle method "bind_param" works when rebinding an int column with a string');
+
+# Check if the server is sending us warning messages
+# We assume that older servers are okay
+my $client_level = '';
+if ($got73) {
+ $sth2 = $dbh->prepare("SHOW client_min_messages");
+ $sth2->execute();
+ $client_level = $sth2->fetchall_arrayref()->[0][0];
+}
+
+#
+# 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
+
+eval {
+ $sth->bind_param_array(1, [ 30, 31, 32 ], SQL_INTEGER);
+};
+ok( !$@, 'Statement handle method "bind_param_array" works binding three values to the first placeholder');
+
+eval {
+ $sth->bind_param_array(2, 'Mulberry');
+};
+ok( !$@, 'Statement handle method "bind_param_array" works binding one scalar value to the second placeholder');
+
+eval {
+ $sth->bind_param_array(2, [ 'Mango', 'Strawberry', 'Gooseberry' ]);
+};
+ok( !$@, 'Statement handle method "bind_param_array" works binding three values to the second placeholder');
+
+eval {
+ $sth->bind_param_array(1, [ 30 ]);
+};
+ok( $@, 'Statement handle method "bind_param_array" fails when binding one value to the first placeholder');
+
+eval {
+ $sth->bind_param_array(2, [ 'Plantain', 'Apple' ]);
+};
+ok( $@, 'Statement handle method "bind_param_array" fails when binding two values to the second placeholder');
+
+#
+# Test of the "execute_array" statement handle method
+#
+
+$dbh->{RaiseError}=1;
+my @tuple_status;
+$rows = $sth->execute_array( { ArrayTupleStatus => \@tuple_status });
+is_deeply( \@tuple_status, [1,1,1], 'Statement method handle "execute_array" works');
+is( $rows, 3, 'Statement method handle "execute_array" returns correct number of rows');
+
+# 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++];
+}
+
+undef @tuple_status;
+$rows = $sth->execute_array( { ArrayTupleStatus => \@tuple_status, ArrayTupleFetch => \&getval });
+is_deeply( \@tuple_status, [1,1,1,1], 'Statement method handle "execute_array" works with ArrayTupleFetch');
+
+is( $rows, 4, 'Statement method handle "execute_array" returns correct number of rows with ArrayTupleFetch');
+
+#
+# Test of the "execute_for_fetch" statement handle method
+#
+
+if ($DBI::VERSION < 1.38) {
+ SKIP: {
+ skip 'DBI must be at least version 1.38 to test statement handle method "execute_for_fetch"', 2;
+ }
+}
+else {
+ $sth = $dbh->prepare("SELECT id+200, val FROM dbd_pg_test");
+ my $goodrows = $sth->execute();
+ my $sth2 = $dbh->prepare("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);
+
+ is_deeply( \@tuple_status, [map{1}(1..$goodrows)], 'Statement handle method "execute_for_fetch" works');
+
+
+
+ is( $rows, $goodrows, 'Statement handle method "execute_for_fetch" returns correct number of rows');
+}
+
+#
+# Test of the "fetchrow_arrayref" statement handle method
+#
+
+$sth = $dbh->prepare("SELECT id, val FROM dbd_pg_test WHERE id = 34");
+$sth->execute();
+$result = $sth->fetchrow_arrayref();
+is_deeply( $result, [34, 'Huckleberry'], 'Statement handle method "fetchrow_arrayref" returns first row correctly');
+$result = $sth->fetchrow_arrayref();
+is_deeply( $result, undef, 'Statement handle method "fetchrow_arrayref" returns undef when done');
+
+# Test of the "fetch" alias
+$sth->execute();
+$result = $sth->fetch();
+$expected = [34, 'Huckleberry'];
+is_deeply( $result, $expected, 'Statement handle method alias "fetch" returns first row correctly');
+$result = $sth->fetch();
+is_deeply( $result, undef, 'Statement handle method alias "fetch" returns undef when done');
+
+#
+# Test of the "fetchrow_array" statement handle method
+#
+
+$sth->execute();
+ at result = $sth->fetchrow_array();
+is_deeply( \@result, $expected, 'Statement handle method "fetchrow_array" returns first row correctly');
+ at result = $sth->fetchrow_array();
+is_deeply( \@result, [], 'Statement handle method "fetchrow_array" returns an empty list when done');
+
+#
+# Test of the "fetchrow_hashref" statement handle method
+#
+
+$sth->execute();
+$result = $sth->fetchrow_hashref();
+$expected = {id => 34, val => 'Huckleberry'};
+is_deeply( $result, $expected, 'Statement handle method "fetchrow_hashref" works with a slice argument');
+$result = $sth->fetchrow_hashref();
+is_deeply( $result, undef, 'Statement handle method "fetchrow_hashref" returns undef when done');
+
+#
+# Test of the "fetchall_arrayref" statement handle method
+#
+
+$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, 'Statement handle method "fetchall_arrayref" returns first row correctly');
+
+# Test of the 'slice' argument
+
+$sth->execute();
+$result = $sth->fetchall_arrayref([1]);
+$expected = [['Guava'],['Lemon']];
+is_deeply( $result, $expected, 'Statement handle method "fetchall_arrayref" works with an arrayref slice');
+
+$sth->execute();
+$result = $sth->fetchall_arrayref({id => 1});
+$expected = [{id => 35},{id => 36}];
+is_deeply( $result, $expected, 'Statement handle method "fetchall_arrayref" works with a hashref slice');
+
+# My personal favorite way of grabbing data
+$sth->execute();
+$result = $sth->fetchall_arrayref({});
+$expected = [{id => 35, val => 'Guava'},{id => 36, val => 'Lemon'}];
+is_deeply( $result, $expected, 'Statement handle method "fetchall_arrayref" works with an empty hashref slice');
+
+# Test of the '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, qq{Statement handle method "fetchall_arrayref" works with a 'maxrows' argument});
+$result = $sth->fetchall_arrayref([1],2);
+$expected = [['Guava'],['Lemon']];
+is_deeply( $result, $expected, qq{Statement handle method "fetchall_arrayref" works with an arrayref slice and a 'maxrows' argument});
+$sth->finish();
+
+#
+# Test of the "fetchall_hashref" statement handle method
+#
+
+$sth = $dbh->prepare("SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)");
+$sth->execute();
+eval {
+ $sth->fetchall_hashref();
+};
+ok( $@, '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();
+$result = $sth->fetchall_hashref('id');
+$expected = {33=>{id => 33, val => 'Peach'},34=>{id => 34, val => 'Huckleberry'}};
+is_deeply( $result, $expected, qq{Statement handle method "fetchall_hashref" works with a named key field});
+$sth->execute();
+$result = $sth->fetchall_hashref(1);
+is_deeply( $result, $expected, qq{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, {}, qq{Statement handle method "fetchall_hashref" returns an empty hash when no rows returned});
+
+#
+# Test of the "rows" statement handle method
+#
+
+$sth = $dbh->prepare("SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)");
+$rows = $sth->rows();
+is( $rows, -1, 'Statement handle method "rows" returns -1 before an execute');
+$sth->execute();
+$rows = $sth->rows();
+is( $rows, 2, 'Statement handle method "rows" returns correct number of rows');
+$sth->finish();
+
+#
+# Test of the "bind_col" statement handle method
+#
+
+$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, 'Statement handle method "bind_col" returns the correct value');
+$sth->fetch();
+is( $bindme, 'Peach', 'Statement handle method "bind_col" correctly binds parameters');
+
+#
+# Test of the "bind_columns" statement handle method
+#
+
+$sth->execute();
+my $bindme2;
+eval {
+ $sth->bind_columns(1);
+};
+ok( $@, 'Statement handle method "bind_columns" fails when called with wrong number of arguments');
+$result = $sth->bind_columns(\$bindme, \$bindme2);
+is($result, 1, 'Statement handle method "bind_columns" returns the correct value');
+$sth->fetch();
+$expected = [33, 'Peach'];
+is_deeply( [$bindme, $bindme2], $expected, 'Statement handle method "bind_columns" correctly binds parameters');
+$sth->finish();
+
+#
+# Test of the statement handle method "state"
+#
+
+$result = $sth->state();
+is( $result, "", qq{Statement handle method "state" returns an empty string on success});
+
+eval {
+ $sth = $dbh->prepare("SELECT dbdpg_throws_an_error");
+ $sth->execute();
+};
+$result = $sth->state();
+like( $result, qr/^[A-Z0-9]{5}$/, qq{Statement handle method "state" returns a five-character code on error});
+my $result2 = $dbh->state();
+is ($result, $result2, qq{Statement and database handle method "state" return same code});
+if ($pglibversion >= 70400 and $pgversion >= 70400) {
+ is ($result, "42703", qq{Statement handle method "state" returns expected code});
+}
+else {
+ is ($result, "S8006", qq{Statement handle method "state" returns expected code (old servers)});
+}
+$dbh->rollback();
+
+$dbh->disconnect();
Added: packages/libdbd-pg-perl/branches/upstream/current/t/04misc.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/04misc.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/04misc.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,52 @@
+#!perl -w
+
+# Various stuff that does not go elsewhere
+# Uses ids of 600-650
+
+use Test::More;
+use DBI;
+use DBD::Pg;
+use strict;
+$|=1;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 3;
+} else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0});
+ok( defined $dbh, "Connect to database for miscellaneous tests");
+
+if (DBD::Pg::_pg_use_catalog($dbh)) {
+ $dbh->do("SET search_path TO " . $dbh->quote_identifier
+ (exists $ENV{DBD_SCHEMA} ? $ENV{DBD_SCHEMA} : 'public'));
+}
+
+
+#
+# Test of the "data_sources" method
+#
+
+my @result = DBI->data_sources('Pg');
+# This may fail due to the wrong port, etc.
+if (defined $result[0]) {
+ is (grep (/^dbi:Pg:dbname=template1$/, @result), '1', 'The data_sources() method returns a template1 listing');
+}
+else {
+ pass("The data_sources() method returned undef");
+}
+
+#
+# Test the use of $DBDPG_DEFAULT
+#
+
+my $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id, pname) VALUES (?,?)});
+eval {
+$sth->execute(600,$DBDPG_DEFAULT);
+};
+$sth->execute(602,123);
+ok (!$@, qq{Using \$DBDPG_DEFAULT ($DBDPG_DEFAULT) works});
+
+$dbh->disconnect();
Added: packages/libdbd-pg-perl/branches/upstream/current/t/05arrays.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/05arrays.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/05arrays.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,67 @@
+#!perl -w
+
+# Test array stuff - currently not working!
+
+use Test::More;
+use DBI;
+use strict;
+$|=1;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 17;
+} else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0});
+ok( defined $dbh, "Connect to database for array testing");
+
+if (DBD::Pg::_pg_use_catalog($dbh)) {
+ $dbh->do("SET search_path TO " . $dbh->quote_identifier
+ (exists $ENV{DBD_SCHEMA} ? $ENV{DBD_SCHEMA} : 'public'));
+}
+
+SKIP: {
+ # XXX Until all the array stuff is working, skip all tests.
+ # Should really be a TODO, but these tests will die.
+ skip 'Array support not implemented', 15;
+
+ # Insert into array
+ my $values = [["a,b", 'c","d', "e'", '\\"'], ['f', 'g', 'h']];
+
+ ok($dbh->do(q{INSERT INTO dbd_pg_test (id, name, testarray) VALUES (?, ?, ?)},
+ {}, 1, 'array1', $values),
+ 'insert statement with references');
+
+ my $sql = <<" SQL";
+ SELECT testarray[1][1],testarray[1][2],testarray[1][3],
+ testarray[2][1],testarray[2][2],testarray[2][3]
+ FROM dbd_pg_test
+ WHERE id = ?
+ AND name = ?
+ SQL
+
+ my $sth = $dbh->prepare($sql);
+ ok(defined $sth, "prepare: $sql" );
+
+ ok($sth->bind_param(1, '1'), 'bind parameter 1', );
+ ok($sth->bind_param(2, 'array1'), 'bind parameter 2' );
+ ok($sth->execute, 'execute statement with references' );
+
+ my @result = $sth->fetchrow_array;
+
+ ok(scalar(@result) == 6, 'fetch 6 columns' );
+ ok($result[0] eq 'a,b', 'values are equal' );
+ ok($result[1] eq 'c","d', 'values are equal' );
+ ok($result[2] eq "e'", 'values are equal' );
+ ok($result[2] eq q{\\\\\"}, 'values are equal' );
+ ok($result[3] eq 'f', 'values are equal' );
+ ok($result[4] eq 'g', 'values are equal' );
+ ok($result[5] eq 'h', 'values are equal' );
+
+ ok($sth->finish, 'finish' );
+
+}; # XXX End SKIP.
+
+ok ($dbh->disconnect, "Disconnect from database");
Added: packages/libdbd-pg-perl/branches/upstream/current/t/06bytea.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/06bytea.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/06bytea.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,48 @@
+#!perl -w
+
+## Test bytea handling
+
+use Test::More;
+use DBI qw(:sql_types);
+use DBD::Pg qw(:pg_types);
+use strict;
+$|=1;
+
+if (defined $ENV{DBI_DSN}){
+ plan tests => 8;
+} else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0});
+ok( defined $dbh, "Connect to database for bytea testing");
+
+my $sth;
+
+$sth = $dbh->prepare(qq{INSERT INTO dbd_pg_test (id,bytetest) VALUES (?,?)});
+
+$sth->bind_param(2, undef, { pg_type => DBD::Pg::PG_BYTEA });
+ok($sth->execute(400, 'aa\\bb\\cc\\\0dd\\'), 'bytea insert test with string containing null and backslashes');
+ok($sth->execute(401, '\''), 'bytea insert test with string containing a single quote');
+ok($sth->execute(402, '\''), 'bytea (second) insert test with string containing a single quote');
+
+$sth = $dbh->prepare(qq{SELECT bytetest FROM dbd_pg_test WHERE id=?});
+
+$sth->execute(400);
+my $byte = $sth->fetchall_arrayref()->[0][0];
+is($byte, 'aa\bb\cc\\\0dd\\', 'Received correct text from BYTEA column with backslashes');
+
+$sth->execute(402);
+$byte = $sth->fetchall_arrayref()->[0][0];
+is($byte, '\'', 'Received correct text from BYTEA column with quote');
+
+my $string = "abc\123\\def\0ghi";
+my $result = $dbh->quote($string, { pg_type => DBD::Pg::PG_BYTEA });
+my $expected = qq{'abc\123\\\\\\\\def\\\\000ghi'};
+is ($result, $expected, 'quote properly handles bytea strings.');
+
+$sth->finish();
+
+$dbh->rollback();
+ok( $dbh->disconnect(), 'Disconnect from database');
Added: packages/libdbd-pg-perl/branches/upstream/current/t/07copy.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/07copy.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/07copy.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,202 @@
+#!perl -w
+
+# Test the COPY functionality
+
+use Test::More;
+use DBI;
+use strict;
+$|=1;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 26;
+} else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0});
+ok( defined $dbh, "Connect to database for bytea testing");
+
+my ($sth,$count,$result,$expected, at data);
+my $pglibversion = $dbh->{pg_lib_version};
+my $pgversion = $dbh->{pg_server_version};
+my $table = 'dbd_pg_test4';
+
+## (Re)create a second test table with few columns to test a "bare" COPY
+## (7.2 does not allow column names in the COPY statement)
+my $schema = DBD::Pg::_pg_use_catalog($dbh);
+my $SQL = "SELECT COUNT(*) FROM pg_class WHERE relname=?";
+if ($schema) {
+ $schema = exists $ENV{DBD_SCHEMA} ? $ENV{DBD_SCHEMA} : 'public';
+ $dbh->do("SET search_path TO " . $dbh->quote_identifier($schema));
+ $SQL = "SELECT COUNT(*) FROM pg_catalog.pg_class c, pg_catalog.pg_namespace n ".
+ "WHERE c.relnamespace=n.oid AND c.relname=? AND n.nspname=".
+ $dbh->quote($schema);
+}
+$sth = $dbh->prepare($SQL);
+$sth->execute($table);
+$count = $sth->fetchall_arrayref()->[0][0];
+if (1==$count) {
+ $dbh->do(sprintf "DROP TABLE %s$table", $schema ? "$schema." : '');
+}
+$dbh->do(qq{CREATE TABLE $table(id2 integer, val2 text)});
+$dbh->commit();
+
+#
+# Test of the pg_putline and pg_endcopy methods
+#
+
+## pg_putline should fail unless we are in a COPY IN state
+eval {
+ $dbh->pg_putline("12\tMulberry");
+};
+ok($@, 'pg_putline fails when issued without a preceding COPY command');
+
+$dbh->do("COPY $table FROM STDIN");
+$result = $dbh->pg_putline("12\tMulberry\n");
+is($result,1,'putline returned a value of 1 for success');
+$result = $dbh->pg_putline("13\tStrawberry\n");
+is($result,1,'putline returned a value of 1 for success');
+$result = $dbh->pg_putline("14\tBlueberry\n");
+is($result,1,'putline returned a value of 1 for success');
+
+## Commands are not allowed while in a COPY IN state
+eval {
+ $dbh->do("SELECT 'dbdpg_copytest'");
+};
+ok($@, 'do() fails while in a COPY IN state');
+
+## pg_getline is not allowed as we are in a COPY_IN state
+$data[0] = '';
+eval {
+ $dbh->pg_getline($data[0], 100);
+};
+ok($@, 'pg_getline fails while in a COPY IN state');
+
+$result = $dbh->pg_endcopy();
+is($result,1,'pg_endcopy returned a 1');
+
+## Make sure we can issue normal commands again
+$dbh->do("SELECT 'dbdpg_copytest'");
+
+## Make sure we are out of the COPY IN state and pg_putline no longer works
+eval {
+ $dbh->pg_putline("16\tBlackberry");
+};
+ok($@, 'pg_putline fails when issued after pg_endcopy called');
+
+## Check that our lines were inserted properly
+$expected = [[12 => 'Mulberry'],[13 => 'Strawberry'],[14 => 'Blueberry']];
+$result = $dbh->selectall_arrayref("SELECT id2,val2 FROM $table ORDER BY id2");
+is_deeply( $result, $expected, 'putline inserted values correctly');
+
+# pg_endcopy should not work because we are no longer in a COPY state
+eval {
+ $dbh->pg_endcopy;
+};
+ok($@, 'pg_endcopy fails when called twice after COPY IN');
+
+$dbh->commit();
+
+#
+# Test of the pg_getline method
+#
+
+SKIP: {
+ skip "Cannot test pg_getline with DBD::Pg compiled with pre-7.4 libraries", 12 if $pglibversion < 70400;
+
+ ## pg_getline should fail unless we are in a COPY OUT state
+ eval {
+ $dbh->pg_getline($data[0], 100);
+ };
+ ok($@, 'pg_getline fails when issued without a preceding COPY command');
+
+ $dbh->do("COPY $table TO STDOUT");
+ my ($buffer,$badret,$badval) = ('',0,0);
+ $result = $dbh->pg_getline($data[0], 100);
+ is ($result, 1, 'pg_getline returned a 1');
+
+ ## Commands are not allowed while in a COPY OUT state
+ eval {
+ $dbh->do("SELECT 'dbdpg_copytest'");
+ };
+ ok($@, 'do() fails while in a COPY OUT state');
+
+ ## pg_putline is not allowed as we are in a COPY OUT state
+ eval {
+ $dbh->pg_putline("99\tBogusberry");
+ };
+ ok($@, 'pg_putline fails while in a COPY OUT state');
+
+ $data[1]=$data[2]=$data[3]='';
+ $result = $dbh->pg_getline($data[1], 100);
+ is ($result, 1, 'pg_getline returned a 1');
+ $result = $dbh->pg_getline($data[2], 100);
+ is ($result, 1, 'pg_getline returned a 1');
+
+ $result = $dbh->pg_getline($data[3], 100);
+ is ($result, '', 'pg_getline returns empty on final call');
+
+ $result = \@data;
+ $expected = ["12\tMulberry\n","13\tStrawberry\n","14\tBlueberry\n",""];
+ is_deeply( $result, $expected, 'getline returned all rows successfuly');
+
+ ## Make sure we can issue normal commands again
+ $dbh->do("SELECT 'dbdpg_copytest'");
+
+ ## Make sure we are out of the COPY OUT state and pg_getline no longer works
+ eval {
+ $data[5]='';
+ $dbh->pg_getline($data[5], 100);
+ };
+ ok($@, 'pg_getline fails when issued after pg_endcopy called');
+
+ ## pg_endcopy should fail because we are no longer in a COPY state
+ eval {
+ $dbh->pg_endcopy;
+ };
+ ok($@, 'pg_endcopy fails when called twice after COPY OUT');
+
+ SKIP2: {
+ skip "Cannot test commit copy reset with pre-7.4 servers", 2 if $pgversion < 70400 or $pglibversion < 70400;
+
+ #
+ # Make sure rollback and commit reset our internal copystate tracking
+ #
+
+ $dbh->do("COPY $table TO STDOUT");
+ $dbh->commit();
+ eval {
+ $dbh->do("SELECT 'dbdpg_copytest'");
+ };
+ ok(!$@, 'commit resets COPY state');
+
+ $dbh->do("COPY $table TO STDOUT");
+ $dbh->rollback();
+ eval {
+ $dbh->do("SELECT 'dbdpg_copytest'");
+ };
+ ok(!$@, 'rollback resets COPY state');
+
+ } ## end SKIP2
+} ## end SKIP
+
+
+
+#
+# Keep oldstyle calls around for backwards compatibility
+#
+
+$dbh->do("COPY $table FROM STDIN");
+$result = $dbh->func("13\tOlive\n", 'putline');
+is ($result, 1, "old-style dbh->func('text', 'putline') still works");
+$dbh->pg_endcopy;
+
+$dbh->do("COPY $table TO STDOUT");
+$result = $dbh->func($data[0], 100, 'getline');
+is ($result, 1, "old-style dbh->func(var, length, 'getline') still works");
+1 while ($result = $dbh->func($data[0], 100, 'getline'));
+
+$dbh->do("DROP TABLE $table");
+$dbh->commit();
+ok( $dbh->disconnect(), 'Disconnect from database');
Added: packages/libdbd-pg-perl/branches/upstream/current/t/12placeholders.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/12placeholders.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/12placeholders.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,121 @@
+#!perl -w
+
+# Test of placeholders
+
+use Test::More;
+use DBI;
+use strict;
+$|=1;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 16;
+} else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0});
+ok( defined $dbh, 'Connect to database for placeholder testing');
+
+if (DBD::Pg::_pg_use_catalog($dbh)) {
+ $dbh->do("SET search_path TO " . $dbh->quote_identifier
+ (exists $ENV{DBD_SCHEMA} ? $ENV{DBD_SCHEMA} : 'public'));
+}
+
+# Make sure that quoting works properly.
+my $quo = $dbh->quote("\\'?:");
+is( $quo, "'\\\\''?:'", "Properly quoted");
+
+# 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;
+ is( $dbh->quote(substr($str, 0, 10)), "'$str'", "First function quote");
+}
+
+checkquote('one');
+checkquote('two');
+checkquote('three');
+checkquote('four');
+
+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();
+ok( (defined($retr) && $retr eq "\\'?:"), "fetch");
+
+eval {
+ $sth = $dbh->prepare($sql);
+ $sth->execute('foo');
+};
+ok( $@, 'execute with one bind param where none expected');
+
+$sql = "SELECT pname FROM dbd_pg_test WHERE pname = ?";
+$sth = $dbh->prepare($sql);
+$sth->execute("\\'?:");
+
+($retr) = $sth->fetchrow_array();
+ok( (defined($retr) && $retr eq "\\'?:"), 'execute with ? placeholder');
+
+$sql = "SELECT pname FROM dbd_pg_test WHERE pname = :1";
+$sth = $dbh->prepare($sql);
+$sth->bind_param(":1", "\\'?:");
+$sth->execute();
+
+($retr) = $sth->fetchrow_array();
+ok( (defined($retr) && $retr eq "\\'?:"), 'execute with :1 placeholder');
+
+$sql = "SELECT pname FROM dbd_pg_test WHERE pname = '?'";
+
+eval {
+ $sth = $dbh->prepare($sql);
+ $sth->execute('foo');
+};
+ok( $@, 'execute with quoted ?');
+
+$sql = "SELECT pname FROM dbd_pg_test WHERE pname = ':1'";
+
+eval {
+ $sth = $dbh->prepare($sql);
+ $sth->execute('foo');
+};
+ok( $@, 'execute with quoted :1');
+
+$sql = "SELECT pname FROM dbd_pg_test WHERE pname = '\\\\' AND pname = '?'";
+$sth = $dbh->prepare($sql);
+
+eval {
+## XX ???
+ local $dbh->{PrintError} = 0;
+ local $sth->{PrintError} = 0;
+ $sth->execute('foo');
+};
+ok( $@, 'execute with quoted ?');
+
+## 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();
+ok( $count >= 1, 'prepare with large number of parameters works');
+
+$sth->finish();
+
+## Test our parsing of backslashes
+$sth = $dbh->prepare("SELECT '\\'?'");
+eval {
+ $sth->execute();
+};
+ok(!$@, 'prepare with backslashes inside quotes works');
+$sth->finish();
+
+$dbh->rollback();
+
+ok( $dbh->disconnect(), 'Disconnect from database');
+
Added: packages/libdbd-pg-perl/branches/upstream/current/t/20savepoints.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/20savepoints.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/20savepoints.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,65 @@
+#!perl -w
+
+# Test savepoint functionality
+# Uses ids of 500-550
+
+use Test::More;
+use DBI qw(:sql_types);
+use strict;
+$|=1;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 4;
+} else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 0, PrintError => 0, AutoCommit => 0});
+ok( defined $dbh, "Connect to database for savepoint testing");
+
+my $pgversion = $dbh->{pg_server_version};
+ use Data::Dumper;
+
+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;
+
+ my $ids = $dbh->selectcol_arrayref('SELECT id FROM dbd_pg_test WHERE pname = ?',undef,$str);
+ ok (eq_set($ids, [500, 502]), 'Only row 500 and 502 should be committed');
+
+ ## 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;
+
+ $ids = $dbh->selectcol_arrayref('SELECT id FROM dbd_pg_test WHERE pname = ?',undef,$str);
+ ok (eq_set($ids, [500, 502, 503, 504]), "Implicit rollback on deallocate should rollback to last savepoint");
+}
+
+$dbh->do("DELETE FROM dbd_pg_test");
+$dbh->commit();
+
+ok( $dbh->disconnect(), 'Disconnect from database');
+
Added: packages/libdbd-pg-perl/branches/upstream/current/t/99_pod.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/99_pod.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/99_pod.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,40 @@
+#!perl -w
+
+use Test::More;
+use strict;
+
+# Check our Pod
+
+plan tests => 2;
+
+my $PODVERSION = '0.95';
+eval {
+ require Test::Pod;
+ Test::Pod->import;
+};
+if ($@ or $Test::Pod::VERSION < $PODVERSION) {
+ pass("Skipping Test::Pod testing");
+}
+else {
+ pod_file_ok("Pg.pm");
+}
+
+## We won't require everyone to have this, so silently move on if not found
+my $PODCOVERVERSION = '1.04';
+eval {
+ require Test::Pod::Coverage;
+ Test::Pod::Coverage->import;
+};
+if ($@ or $Test::Pod::Coverage::VERSION < $PODCOVERVERSION) {
+ pass ("Skipping Test::Pod::Coverage testing");
+}
+else {
+ my $trusted_names =
+ [
+ qr{^PG_[A-Z]+\d?$},
+ qr{^CLONE$},
+ qr{^driver$},
+ qr{^constant$},
+ ];
+ pod_coverage_ok("DBD::Pg", {trustme => $trusted_names}, "DBD::Pg pod coverage okay");
+}
Added: packages/libdbd-pg-perl/branches/upstream/current/t/99cleanup.t
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/99cleanup.t 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/99cleanup.t 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,50 @@
+#!perl -w
+
+# Cleanup by removing the test table
+
+use Test::More;
+use DBI;
+use strict;
+$|=1;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 3;
+} else {
+ plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 1});
+ok( defined $dbh, 'Connect to database for cleanup');
+
+# Remove the test relations if they exist
+my $schema = DBD::Pg::_pg_use_catalog($dbh);
+my $SQL = "SELECT COUNT(*) FROM pg_class WHERE relname=?";
+if ($schema) {
+ $schema = exists $ENV{DBD_SCHEMA} ? $ENV{DBD_SCHEMA} : 'public';
+ $dbh->do("SET search_path TO " . $dbh->quote_identifier($schema));
+ $SQL = "SELECT COUNT(*) FROM pg_catalog.pg_class c, pg_catalog.pg_namespace n ".
+ "WHERE c.relnamespace=n.oid AND c.relname=? AND n.nspname=".
+ $dbh->quote($schema);
+}
+my $sth = $dbh->prepare($SQL);
+
+for (3,2,1,'') {
+ my $table = "dbd_pg_test$_";
+ $sth->execute($table);
+ if (1==$sth->fetchall_arrayref()->[0][0]) {
+ $dbh->do(sprintf "DROP TABLE %s$table", $schema ? "$schema." : '');
+ }
+}
+
+$sth->execute('dbd_pg_sequence');
+if (1==$sth->fetchall_arrayref()->[0][0]) {
+ $dbh->do(sprintf "DROP SEQUENCE %s%s", $schema ? "$schema." : '', 'dbd_pg_sequence');
+}
+
+pass('All testing tables (e.g. "dbd_pg_test*") have been dropped');
+pass('The testing sequence "dbd_pg_sequence" has been dropped');
+
+
+$dbh->disconnect();
+
Added: packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Handler/Prompt.pm
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Handler/Prompt.pm 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Handler/Prompt.pm 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,170 @@
+package App::Info::Handler::Prompt;
+
+# $Id: Prompt.pm,v 1.3 2005/01/08 07:18:58 theory Exp $
+
+=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<STDOUT> and then accepting a new value from C<STDIN>. 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<STDOUT> and print error event messages
+to C<STDERR>. For more interesting info and error event handling, see
+L<App::Info::Handler::Print|App::Info::Handler::Print> and
+L<App::Info::Handler::Carp|App::Info::Handler::Carp>.
+
+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';
+ at 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 = <STDIN>;
+ 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 <bug-app-info at rt.cpan.org> or file them at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <david at justatheory.com>
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info> documents the event handling interface.
+
+L<App::Info::Handler::Carp|App::Info::Handler::Carp> handles events by
+passing their messages Carp module functions.
+
+L<App::Info::Handler::Print|App::Info::Handler::Print> handles events by
+printing their messages to a file handle.
+
+L<App::Info::Handler|App::Info::Handler> 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
Added: packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Handler.pm
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Handler.pm 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Handler.pm 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,305 @@
+package App::Info::Handler;
+
+# $Id: Handler.pm,v 1.3 2005/01/08 07:18:58 theory Exp $
+
+=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<using> 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<App::Info::Handler
+subclasses|"SEE ALSO"> 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<register_handler()> 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<register_handler()> 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<new()> 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<handler()>. 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<handler()> 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<new()> constructor and the
+C<handler()> method. The C<new()> 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<new()> 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<register_handler()> 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<register_handler()> usage.
+
+The final step in creating a new App::Info event handler is to implement the
+C<handler()> 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<App::Info::Request|App::Info::Request> 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-E<gt>value>) as a default.
+
+=item *
+
+For unknown and confirm events, you are expected to call C<$req-E<gt>callback>
+and pass in the new value. If C<$req-E<gt>callback> returns a false value, you
+are expected to display the error message in C<$req-E<gt>error> and prompt the
+user again. Note that C<$req-E<gt>value> calls C<$req-E<gt>callback>
+internally, and thus assigns the value and returns true if
+C<$req-E<gt>callback> returns true, and does not assign the value and returns
+false if C<$req-E<gt>callback> returns false.
+
+=item *
+
+For unknown and confirm events, if you've collected a new value and
+C<$req-E<gt>callback> returns true for that value, you are expected to assign
+the value by passing it to C<$req-E<gt>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<event
+methods|App::Info/"Events"> for details on how App::Info constructs the
+App::Info::Request object for each event type.
+
+=head1 BUGS
+
+Please send bug reports to <bug-app-info at rt.cpan.org> or file them at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <david at justatheory.com>
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info> thoroughly documents the client interface for setting
+event handlers, as well as the event triggering interface for App::Info
+concrete subclasses.
+
+L<App::Info::Request|App::Info::Request> documents the interface for the
+request objects passed to App::Info::Handler C<handler()> 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<App::Info::Handler::Carp|App::Info::Handler::Carp>
+
+=item L<App::Info::Handler::Print|App::Info::Handler::Print>
+
+=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt>
+
+=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
Added: packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/RDBMS/PostgreSQL.pm
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/RDBMS/PostgreSQL.pm 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/RDBMS/PostgreSQL.pm 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,1065 @@
+package App::Info::RDBMS::PostgreSQL;
+
+# $Id: PostgreSQL.pm,v 1.10 2005/01/08 07:18:58 theory Exp $
+
+=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<App::Info|App::Info> 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<name()>, C<version()>, C<major_version()>,
+C<minor_version()>, and C<patch_version()>, 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);
+ at 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<App::Info|App::Info> for
+a complete description of argument parameters.
+
+When it called, C<new()> searches the file system for an executable named for
+the list returned by C<search_exe_names()>, usually F<pg_config>, in the list
+of directories returned by C<search_bin_dirs()>. If found, F<pg_config> will
+be called by the object methods below to gather the data necessary for
+each. If F<pg_config> cannot be found, then PostgreSQL is assumed not to be
+installed, and each of the object methods will return C<undef>.
+
+C<new()> 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<pg_config>, which you specify
+via the C<search_exe_names> 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<Events:>
+
+=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)) {
+ # 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<pg_config> application on the file system
+as found when C<new()> 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<Events:>
+
+=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<Events:>
+
+=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<version()> returns "7.1.2", then this method returns "7".
+
+B<Events:>
+
+=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<version()> returns "7.1.2", then this method returns "2".
+
+B<Events:>
+
+=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<version()> returns "7.1.2", then this method returns "1".
+
+B<Events:>
+
+=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<postgres>. This method does not use the executable names returned by
+C<search_exe_names()>; those executable names are used to search for
+F<pg_config> only (in C<new()>).
+
+When it called, C<executable()> checks for an executable named F<postgres> in
+the directory returned by C<bin_dir()>.
+
+Note that C<executable()> is simply an alias for C<postgres()>.
+
+B<Events:>
+
+=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<Events:>
+
+=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<Events:>
+
+=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<Events:>
+
+=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<Events:>
+
+=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<Events:>
+
+=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<pg_config> executable. By default, only
+F<pg_config> is returned (or F<pg_config.exe> on Win32).
+
+Note that this method is not used to search for the PostgreSQL server
+executable, only F<pg_config>.
+
+=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<new()> constructor to find an executable to execute and collect
+application info. The found directory will also be returned by the C<bin_dir>
+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<executable()> 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<bin_dir()>.
+The name of the executable must be one of the names returned by the
+corresponding C<search_*_names> 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<Events:>
+
+=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 <bug-app-info at rt.cpan.org> or file them at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <david at justatheory.com> based on code by Sam Tregar
+<sam at tregar.com>.
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info> documents the event handling interface.
+
+L<App::Info::RDBMS|App::Info::RDBMS> is the App::Info::RDBMS::PostgreSQL
+parent class.
+
+L<DBD::Pg|DBD::Pg> is the L<DBI|DBI> driver for connecting to PostgreSQL
+databases.
+
+L<http://www.postgresql.org/> 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
Added: packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/RDBMS.pm
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/RDBMS.pm 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/RDBMS.pm 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,55 @@
+package App::Info::RDBMS;
+
+# $Id: RDBMS.pm,v 1.2 2004/11/08 17:51:03 theory Exp $
+
+use strict;
+use App::Info;
+use vars qw(@ISA $VERSION);
+ at 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<App::Info|App::Info> for a complete description
+and L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL> 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<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <L<david at wheeler.net|"david at wheeler.net">>
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info>,
+L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL>
+
+=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
+
+
+
Added: packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Request.pm
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Request.pm 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Request.pm 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,287 @@
+package App::Info::Request;
+
+# $Id: Request.pm,v 1.3 2005/01/08 07:18:58 theory Exp $
+
+=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<handler()> method of App::Info event
+handlers. Generally, this class will be of most interest to App::Info::Handler
+subclass implementers.
+
+The L<event triggering methods|App::Info/"Events"> 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<handler()>
+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<App::Info::Handler|App::Info::Handler> 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<event triggering methods|App::Info/"Events"> 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<type()> 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<new()> 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<callback()>
+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<value()> method.
+
+Note that the C<value()> method itself calls C<callback()> 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<value()> 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<value()> attempts to store the the argument as a
+new value. However, C<value()> calls C<callback()> on the new value, and if
+C<callback()> returns false, then C<value()> returns false and does not store
+the new value. If C<callback()> returns true, on the other hand, then
+C<value()> 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 <bug-app-info at rt.cpan.org> or file them at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <david at justatheory.com>
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info> documents the event triggering methods and how they
+construct App::Info::Request objects to pass to event handlers.
+
+L<App::Info::Handler:|App::Info::Handler> documents how to create custom event
+handlers, which must make use of the App::Info::Request object passed to their
+C<handler()> 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<App::Info::Handler::Carp|App::Info::Handler::Carp>
+
+=item L<App::Info::Handler::Print|App::Info::Handler::Print>
+
+=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt>
+
+=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
Added: packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Util.pm
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Util.pm 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info/Util.pm 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,477 @@
+package App::Info::Util;
+
+# $Id: Util.pm,v 1.3 2005/01/08 07:18:58 theory Exp $
+
+=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<File::Spec|File::Spec> and adds its own methods in
+order to offer utility methods to L<App::Info|App::Info> 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);
+ at 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<File::Spec|File::Spec>, 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<first_dir()> 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<first_cat_path()> 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<httpd>
+or F<apache>, and it could be in any of the following paths:
+F</usr/local/bin>, F</usr/bin/>, F</bin>. 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<first_cat_path()> 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<first_cat_path()>, 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</usr/bin/httpd>, while C<first_cat_path()> would return that value,
+C<first_cat_dir()> would return F</usr/bin> 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<first_cat_path()>, 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<foo.txt> 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<foo.txt> 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<search_file()> 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<multi_search_file()>, 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 (<F>) {
+ # 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<search_file()>, 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<search_file()> for each
+of them would be wasteful, as each call to C<search_file()> opens the file and
+parses it. With C<multi_search_file()>, 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<multi_file_search()> 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<search_file()>, C<multi_search_file()> 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 = <F>) {
+ 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<libsdirs> and C<loclibpth> Config settings. These are
+useful for passing to C<first_cat_dir()> 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 <bug-app-info at rt.cpan.org> or file them at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <david at justatheory.com>
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info>, L<File::Spec|File::Spec>,
+L<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache>
+L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL>
+
+=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
Added: packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info.pm
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info.pm 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/t/lib/App/Info.pm 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,1347 @@
+package App::Info;
+
+# $Id: Info.pm,v 1.3 2005/01/08 07:18:58 theory Exp $
+
+=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<sample subclasses|"SEE ALSO"> 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<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache> 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<App::Info::HTTPD|App::Info::HTTPD> and L<App::Info::Lib|App::Info::Lib>).
+See L<Subclassing|"SUBCLASSING"> 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<new()> 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<bin_dir> 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<lib_dir> and C<so_lib_dir>
+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<inc_dir> attribute
+in addition to and in preference to the defaults used by each subclass.
+
+=back
+
+The parameters to C<new()> 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<new()>, 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<version()> 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<version()> 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<version()> 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<new()> 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<new()> 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<new()> constructor to find an executable to execute
+and collect application info. The found directory will also generally then
+be returned by the C<bin_dir> 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<lib_dir()> 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<so_lib_dir()> 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<lib_dir()> and C<so_lib_dir()> 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<inc_dir()> 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<inc_dir()> 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<App::Info::Handler|App::Info::Handler> 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<App::Info::Handler::Print|App::Info::Handler::Print> 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<App::Info::Handler::Print|App::Info::Handler::Print> 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<App::Info::Handler::Carp|App::Info::Handler::Carp> 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<App::Info::Handler::Prompt|App::Info::Handler::Prompt> 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<httpd_root()> 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<File::Spec|File::Spec> in order to offer easy access to
+commonly-used methods from that class, e.g., C<path()>. 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<App::Info::Util|App::Info::Util> 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<message> 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<message>
+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<unknown()>. The parameters are
+as follows:
+
+=over 4
+
+=item key
+
+The C<key> 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<unknown()> as was returned by the first call, and no
+handlers will be activated. Typical values are "version" and "lib_dir".
+
+=item prompt
+
+The C<prompt> 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<key_name()> method
+and the C<key> parameter. The result would be something like "Enter a valid
+FooApp version". The C<prompt> parameter value will be stored in the
+C<message> 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<callback> 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<sub { -d }>. The C<callback> parameter code reference will be stored in the
+C<callback> 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<callback> 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<callback> identified as invalid, a message to display might
+be something like "Invalid directory path". Note that if the C<error>
+parameter is not provided, App::Info will supply the generic error message
+"Invalid value". This value will be stored in the C<error> 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<unknown()>, 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<confirm()>, its use is quite similar
+to that of C<unknown()>. Its parameters are as follows:
+
+=over
+
+=item key
+
+Same as for C<unknown()>, 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<confirm()> as was
+returned by the first call for a given key.
+
+=item prompt
+
+Same as for C<unknown()>. Although C<confirm()> is called to confirm a value,
+typically the prompt should request the relevant value, just as for
+C<unknown()>. The difference is that the handler I<should> use the C<value>
+parameter as the default should the user not provide a value. The C<prompt>
+parameter will be stored in the C<message> 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<value> attribute of the
+App::Info::Request object passed to event handlers.
+
+=item callback
+
+Same as for C<unknown()>. Because the user can enter data to replace the
+default value provided via the C<value> parameter, you might want to validate
+it. Use this code reference to do so. The callback will be stored in the
+C<callback> attribute of the App::Info::Request object passed to event
+handlers.
+
+=item error
+
+Same as for C<unknown()>: an error message to display in the event that a
+value entered by the user isn't validated by the C<callback> code reference.
+This value will be stored in the C<error> 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<info()> and, if
+necessary, C<error()> 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<info()> method to display a status message to let the
+user know what we're doing. Then we used the C<error()> 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<info()>
+method call. But rather than call the C<error()> 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<unknown()> 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<unknown()> 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<error()>
+and when to use C<unknown()>. 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<error()> 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<unknown()> 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<metadata object methods|"Metadata
+Object Methods">. And of course, C<error()> 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<version()> 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<unknown()> method. The C<version()> 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<version()> will return the same value that was returned
+the first time it was called. Of course, thanks to the C<key> parameter in the
+call to C<unknown()>, we could have have tried to enumerate the version number
+every time, as C<unknown()> will return the same value every time it is called
+(as, indeed, should C<_find_version()>. But by checking for the C<version> 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<unknown()> method. Thus, the C<major()> 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<confirm()> 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<confirm()> method is quite similar to that of C<unknown()>. 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</bin/myapp>, but the user may really be interested in F</usr/bin/myapp>.
+Thus the C<confirm()> 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<confirm()> or C<unknown()> 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<new()> 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<alt_paths> 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<new()> 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<new()> constructor, always call C<SUPER::new(@_)>. This
+ensures that the event handling methods methods defined by the App::Info base
+classes (e.g., C<error()>) 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<App::Info::Util|App::Info::Util> for complete
+documentation of its interface.
+
+=item *
+
+Use the C<info()> event triggering method to send messages to users of your
+subclass.
+
+=item *
+
+Use the C<error()> event triggering method to alert users of unexpected
+conditions. Fatal errors should still be fatal; use C<Carp::croak()> to throw
+exceptions for fatal errors.
+
+=item *
+
+Use the C<unknown()> 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<confirm()> event triggering method when a core piece of data is
+known (such as the location of an executable in the C<new()> constructor) and
+you need to make sure that you have the I<correct> information.
+
+=item *
+
+Be sure to implement B<all> 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 <bug-app-info at rt.cpan.org> or file them at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <david at justatheory.com>
+
+=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<App::Info::HTTP|App::Info::HTTPD>
+
+=item L<App::Info::RDBMS|App::Info::RDBMS>
+
+=item L<App::Info::Lib|App::Info::Lib>
+
+=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<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache>
+
+=item L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL>
+
+=item L<App::Info::Lib::Expat|App::Info::Lib::Expat>
+
+=item L<App::Info::Lib::Iconv|App::Info::Lib::Iconv>
+
+=back
+
+L<App::Info::Util|App::Info::Util> provides utility methods for App::Info
+subclasses.
+
+L<App::Info::Handler|App::Info::Handler> 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<App::Info::Handler::Print|App::Info::Handler::Print>
+
+=item L<App::Info::Handler::Carp|App::Info::Handler::Carp>
+
+=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt>
+
+=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
Added: packages/libdbd-pg-perl/branches/upstream/current/types.c
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/types.c 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/types.c 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,476 @@
+/*
+
+ $Id: types.c,v 1.27 2006/02/22 00:24:08 turnstep Exp $
+
+ Copyright (c) 2003-2006 PostgreSQL Global Development Group
+
+ You may distribute under the terms of either the GNU General Public
+ License or the Artistic License, as specified in the Perl README file.
+
+*/
+
+/*
+ Please do not edit the C portions of this file directly.
+ It is automatically generated by the enclosed Perl script.
+*/
+
+
+#include "Pg.h"
+
+static sql_type_info_t pg_types[] = {
+ {ABSTIMEOID, "abstime", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {ACLITEMOID, "aclitem", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {ANYARRAYOID, "anyarray", null_quote, null_dequote, {SQL_ARRAY}, DBDPG_TRUE},
+ {ANYELEMENTOID, "anyelement", 0, 0, {0}, DBDPG_FALSE},
+ {ANYOID, "any", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {BITOID, "bitstring", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {BOOLOID, "bool", quote_bool, dequote_bool, {SQL_BOOLEAN}, DBDPG_TRUE},
+ {BOXOID, "box", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {BPCHAROID, "bpchar", quote_string, dequote_char, {SQL_CHAR}, DBDPG_TRUE},
+ {BYTEAOID, "bytea", quote_bytea, dequote_bytea, {SQL_VARBINARY}, DBDPG_TRUE},
+ {CASHOID, "money", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {CHAROID, "char", quote_string, dequote_char, {0}, DBDPG_TRUE},
+ {CIDOID, "cid", null_quote, null_dequote, {SQL_INTEGER}, DBDPG_TRUE},
+ {CIDROID, "IP - cidr", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {CIRCLEOID, "circle", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {CSTRINGOID, "cstring", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {DATEOID, "date", null_quote, null_dequote, {SQL_TYPE_DATE}, DBDPG_TRUE},
+ {FLOAT4OID, "float4", quote_string, dequote_char, {SQL_NUMERIC}, DBDPG_TRUE},
+ {FLOAT8OID, "float8", null_quote, null_dequote, {SQL_REAL}, DBDPG_TRUE},
+ {INETOID, "IP address", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {INT2OID, "int2", null_quote, null_dequote, {SQL_SMALLINT}, DBDPG_TRUE},
+ {INT2VECTOROID, "int28", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {INT4ARRAYOID, "int4array", 0, 0, {0}, DBDPG_FALSE},
+ {INT4OID, "int4", null_quote, null_dequote, {SQL_INTEGER}, DBDPG_TRUE},
+ {INT8OID, "int8", null_quote, null_dequote, {SQL_DOUBLE}, DBDPG_TRUE},
+ {INTERNALOID, "internal", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {INTERVALOID, "timespan", quote_string, dequote_string, {SQL_INTERVAL}, DBDPG_TRUE},
+ {LANGUAGE_HANDLEROID, "languagehandle", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {LINEOID, "line", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {LSEGOID, "lseg", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {MACADDROID, "MAC address", quote_string, dequote_string, {0}, DBDPG_TRUE},
+ {NAMEOID, "name", null_quote, null_dequote, {SQL_VARCHAR}, DBDPG_TRUE},
+ {NUMERICOID, "numeric", null_quote, null_dequote, {SQL_DECIMAL}, DBDPG_TRUE},
+ {OIDOID, "oid", null_quote, null_dequote, {SQL_INTEGER}, DBDPG_TRUE},
+ {OIDVECTOROID, "oid8", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {OPAQUEOID, "opaque", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {PATHOID, "path", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {PG_ATTRIBUTE_RELTYPE_OID, "pg_attribute_reltype", 0, 0, {0}, DBDPG_FALSE},
+ {PG_CLASS_RELTYPE_OID, "pg_class_reltype", 0, 0, {0}, DBDPG_FALSE},
+ {PG_PROC_RELTYPE_OID, "pg_proc_reltype", 0, 0, {0}, DBDPG_FALSE},
+ {PG_TYPE_RELTYPE_OID, "pg_type_reltype", 0, 0, {0}, DBDPG_FALSE},
+ {POINTOID, "point", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {POLYGONOID, "polygon", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {RECORDOID, "record", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {REFCURSOROID, "refcursor", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {REGCLASSOID, "regclass", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {REGOPERATOROID, "registeroperator_args", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {REGOPEROID, "registeredoperator", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {REGPROCEDUREOID, "regprocedureoid", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {REGPROCOID, "regproc", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {REGTYPEARRAYOID, "regtypearray", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {REGTYPEOID, "regtype", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {RELTIMEOID, "reltime", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {TEXTOID, "text", quote_string, dequote_string, {SQL_VARCHAR}, DBDPG_TRUE},
+ {TIDOID, "tid", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {TIMEOID, "time", null_quote, null_dequote, {SQL_TYPE_TIME}, DBDPG_TRUE},
+ {TIMESTAMPOID, "timestamp", quote_string, dequote_string, {SQL_TYPE_TIMESTAMP}, DBDPG_TRUE},
+ {TIMESTAMPTZOID, "datetime", quote_string, dequote_string, {SQL_TYPE_TIMESTAMP_WITH_TIMEZONE}, DBDPG_TRUE},
+ {TIMETZOID, "timestamptz", null_quote, null_dequote, {SQL_TYPE_TIME_WITH_TIMEZONE}, DBDPG_TRUE},
+ {TINTERVALOID, "tinterval", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {TRIGGEROID, "trigger", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {UNKNOWNOID, "unknown", quote_string, dequote_string, {SQL_UNKNOWN_TYPE}, DBDPG_TRUE},
+ {VARBITOID, "vbitstring", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {VARCHAROID, "varchar", quote_string, dequote_string, {SQL_VARCHAR}, DBDPG_TRUE},
+ {VOIDOID, "void", null_quote, null_dequote, {0}, DBDPG_TRUE},
+ {XIDOID, "xid", null_quote, null_dequote, {0}, DBDPG_TRUE},
+};
+
+sql_type_info_t* pg_type_data(sql_type)
+ int sql_type;
+{
+ switch(sql_type) {
+
+ case ABSTIMEOID: return &pg_types[0];
+ case ACLITEMOID: return &pg_types[1];
+ case ANYARRAYOID: return &pg_types[2];
+ case ANYELEMENTOID: return &pg_types[3];
+ case ANYOID: return &pg_types[4];
+ case BITOID: return &pg_types[5];
+ case BOOLOID: return &pg_types[6];
+ case BOXOID: return &pg_types[7];
+ case BPCHAROID: return &pg_types[8];
+ case BYTEAOID: return &pg_types[9];
+ case CASHOID: return &pg_types[10];
+ case CHAROID: return &pg_types[11];
+ case CIDOID: return &pg_types[12];
+ case CIDROID: return &pg_types[13];
+ case CIRCLEOID: return &pg_types[14];
+ case CSTRINGOID: return &pg_types[15];
+ case DATEOID: return &pg_types[16];
+ case FLOAT4OID: return &pg_types[17];
+ case FLOAT8OID: return &pg_types[18];
+ case INETOID: return &pg_types[19];
+ case INT2OID: return &pg_types[20];
+ case INT2VECTOROID: return &pg_types[21];
+ case INT4ARRAYOID: return &pg_types[22];
+ case INT4OID: return &pg_types[23];
+ case INT8OID: return &pg_types[24];
+ case INTERNALOID: return &pg_types[25];
+ case INTERVALOID: return &pg_types[26];
+ case LANGUAGE_HANDLEROID: return &pg_types[27];
+ case LINEOID: return &pg_types[28];
+ case LSEGOID: return &pg_types[29];
+ case MACADDROID: return &pg_types[30];
+ case NAMEOID: return &pg_types[31];
+ case NUMERICOID: return &pg_types[32];
+ case OIDOID: return &pg_types[33];
+ case OIDVECTOROID: return &pg_types[34];
+ case OPAQUEOID: return &pg_types[35];
+ case PATHOID: return &pg_types[36];
+ case PG_ATTRIBUTE_RELTYPE_OID: return &pg_types[37];
+ case PG_CLASS_RELTYPE_OID: return &pg_types[38];
+ case PG_PROC_RELTYPE_OID: return &pg_types[39];
+ case PG_TYPE_RELTYPE_OID: return &pg_types[40];
+ case POINTOID: return &pg_types[41];
+ case POLYGONOID: return &pg_types[42];
+ case RECORDOID: return &pg_types[43];
+ case REFCURSOROID: return &pg_types[44];
+ case REGCLASSOID: return &pg_types[45];
+ case REGOPERATOROID: return &pg_types[46];
+ case REGOPEROID: return &pg_types[47];
+ case REGPROCEDUREOID: return &pg_types[48];
+ case REGPROCOID: return &pg_types[49];
+ case REGTYPEARRAYOID: return &pg_types[50];
+ case REGTYPEOID: return &pg_types[51];
+ case RELTIMEOID: return &pg_types[52];
+ case TEXTOID: return &pg_types[53];
+ case TIDOID: return &pg_types[54];
+ case TIMEOID: return &pg_types[55];
+ case TIMESTAMPOID: return &pg_types[56];
+ case TIMESTAMPTZOID: return &pg_types[57];
+ case TIMETZOID: return &pg_types[58];
+ case TINTERVALOID: return &pg_types[59];
+ case TRIGGEROID: return &pg_types[60];
+ case UNKNOWNOID: return &pg_types[61];
+ case VARBITOID: return &pg_types[62];
+ case VARCHAROID: return &pg_types[63];
+ case VOIDOID: return &pg_types[64];
+ case XIDOID: return &pg_types[65];
+ default:return NULL;
+ }
+}
+
+static sql_type_info_t sql_types[] = {
+ {SQL_BOOLEAN, "SQL_BOOLEAN", quote_bool, dequote_bool, {BOOLOID}, DBDPG_TRUE},
+ {SQL_CHAR, "SQL_CHAR", quote_string, dequote_char, {BPCHAROID}, DBDPG_TRUE},
+ {SQL_VARBINARY, "SQL_VARBINARY", quote_bytea, dequote_bytea, {BYTEAOID}, DBDPG_TRUE},
+ {SQL_TYPE_DATE, "SQL_TYPE_DATE", null_quote, null_dequote, {DATEOID}, DBDPG_TRUE},
+ {SQL_NUMERIC, "SQL_NUMERIC", quote_string, dequote_char, {FLOAT4OID}, DBDPG_TRUE},
+ {SQL_REAL, "SQL_REAL", null_quote, null_dequote, {FLOAT8OID}, DBDPG_TRUE},
+ {SQL_SMALLINT, "SQL_SMALLINT", null_quote, null_dequote, {INT2OID}, DBDPG_TRUE},
+ {SQL_INTEGER, "SQL_INTEGER", null_quote, null_dequote, {INT4OID}, DBDPG_TRUE},
+ {SQL_DOUBLE, "SQL_DOUBLE", null_quote, null_dequote, {INT8OID}, DBDPG_TRUE},
+ {SQL_DECIMAL, "SQL_DECIMAL", null_quote, null_dequote, {NUMERICOID}, DBDPG_TRUE},
+ {SQL_TYPE_TIME, "SQL_TYPE_TIME", null_quote, null_dequote, {TIMEOID}, DBDPG_TRUE},
+ {SQL_TYPE_TIMESTAMP, "SQL_TYPE_TIMESTAMP", quote_string, dequote_string, {TIMESTAMPOID}, DBDPG_TRUE},
+ {SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, "SQL_TYPE_TIMESTAMP_WITH_TIMEZONE", quote_string, dequote_string, {TIMESTAMPTZOID}, DBDPG_TRUE},
+ {SQL_VARCHAR, "SQL_VARCHAR", quote_string, dequote_string, {VARCHAROID}, DBDPG_TRUE},
+};
+
+sql_type_info_t* sql_type_data(sql_type)
+ int sql_type;
+{ switch(sql_type) {
+ case SQL_BOOLEAN: return &sql_types[0];
+ case SQL_CHAR: return &sql_types[1];
+ case SQL_VARBINARY: return &sql_types[2];
+ case SQL_TYPE_DATE: return &sql_types[3];
+ case SQL_NUMERIC: return &sql_types[4];
+ case SQL_REAL: return &sql_types[5];
+ case SQL_SMALLINT: return &sql_types[6];
+ case SQL_INTEGER: return &sql_types[7];
+ case SQL_DOUBLE: return &sql_types[8];
+ case SQL_DECIMAL: return &sql_types[9];
+ case SQL_TYPE_TIME: return &sql_types[10];
+ case SQL_TYPE_TIMESTAMP: return &sql_types[11];
+ case SQL_TYPE_TIMESTAMP_WITH_TIMEZONE: return &sql_types[12];
+ case SQL_VARCHAR: return &sql_types[13];
+ default: return NULL;
+ }
+}
+
+/*
+#!perl
+
+## Autogenerate all type information and populate types.c and types.h
+
+## You should only run this if you are developing DBD::Pg and
+## understand what this script does
+
+## Usage: perl -x $0 "path-to-pgsql-source"
+
+use strict; use warnings; use Data::Dumper;
+
+my $arg = shift || die "Usage: $0 path-to-pgsql-source\n";
+
+-d $arg or die qq{Sorry, but "$arg" is not a directory!\n};
+
+my $file = "$arg/src/include/catalog/pg_type.h";
+
+open(F, $file) or die qq{Could not open file "$file": $!\n};
+my %oid;
+my $maxlen = 1;
+while(<F>) {
+ next unless /^#define\s+([A-Z0-9_]*OID)\s+(\d+)/o;
+ $oid{$1} = $2;
+ length($1) > $maxlen and $maxlen = length($1);
+}
+close(F);
+
+my $outfile = "types.h";
+open(OUT, ">$outfile") or die qq{Could not open "$outfile": $!\n};
+
+print OUT
+qq!#ifndef DBDPGTYEPSH
+#define DBDPGTYEPSH
+
+typedef struct sql_type_info {
+ int type_id;
+ char *type_name;
+ char* (*quote)();
+ void (*dequote)();
+ union {
+ int pg;
+ int sql;
+ } type;
+ bool bind_ok;
+} sql_type_info_t;
+
+sql_type_info_t* pg_type_data(int);
+sql_type_info_t* sql_type_data(int);
+
+!;
+
+## We sort alphabetically because it is easier to read that way,
+## and we don't really care that much about the numbers
+for (sort { $a cmp $b } keys %oid) {
+ printf OUT "#define %${maxlen}s $oid{$_}\n", $_;
+}
+
+
+print OUT "\n#endif\n";
+close(OUT);
+
+print "Wrote $outfile\n";
+
+$outfile = "types.c.tmp";
+open(OUT, ">$outfile") or die qq{Could not open "$outfile": $!\n};
+
+print OUT
+'/' . q{*
+
+ $Id: types.c,v 1.27 2006/02/22 00:24:08 turnstep Exp $
+
+ Copyright (c) 2003-2006 PostgreSQL Global Development Group
+
+ You may distribute under the terms of either the GNU General Public
+ License or the Artistic License, as specified in the Perl README file.
+
+*} . "/\n\n/" . qq{*
+ Please do not edit the C portions of this file directly.
+ It is automatically generated by the enclosed Perl script.
+*} . qq{/
+
+
+#include "Pg.h"
+
+};
+
+## Map all types into a sql_type_info structure
+
+#Each must have a "name" e.g. declared as column type name
+#whether we quote it or not (DBDPG_TRUE)
+#the quoting function to use
+#the dequoting function to use
+#the closest SQL_ match
+#whether this is the "master" for sql matches
+
+# Group by quoting function, then name
+# Start with bool
+
+print OUT "static sql_type_info_t pg_types[] = {\n";
+
+
+my %type;
+while (<DATA>) {
+ last if /^__END__/;
+ next unless /^[A-Z]/o;
+ chomp;
+ my ($name, at info) = split m#\s*,\s*# => $_;
+ $type{$name} = \@info;
+}
+
+my %pos;
+my $item = 0;
+for (sort keys %oid) {
+ ## Check for any new ones
+ if (!exists $type{$_}) {
+ warn "Unknown type: $_\n";
+ next;
+ }
+ ## {BOOLOID, "bool", quote_bool, dequote_bool, {SQL_BOOLEAN}, DBDPG_TRUE},
+ printf OUT qq!\t{$_, "%s", %s, %s, \{%s\}, %s\},\n!,
+ $type{$_}[0], $type{$_}[1], $type{$_}[2], $type{$_}[3], ($type{$_}[1] ? "DBDPG_TRUE" : "DBDPG_FALSE");
+ $pos{$_} = $item++;
+}
+
+print OUT "\};\n\n";
+
+print OUT
+"sql_type_info_t* pg_type_data(sql_type)
+\tint sql_type;
+{
+\tswitch(sql_type) {
+\n";
+
+
+for (sort keys %type) {
+ if (!exists $oid{$_}) {
+ warn "Unreferenced type: $_\n";
+ }
+ printf OUT qq{\t\tcase %-*s return \&pg_types\[%d\];\n}, 1+$maxlen, "$_:", $pos{$_};
+}
+
+print OUT "\t\tdefault:return NULL;\n\t\}\n\}\n\n";
+
+
+print OUT "static sql_type_info_t sql_types[] = \{\n";
+
+undef %pos;
+$item=0;
+$maxlen = 1;
+for (sort keys %type) {
+ if (!exists $oid{$_}) {
+ warn "Unreferenced type: $_\n";
+ }
+ next unless $type{$_}[4];
+ my $sql = $type{$_}[3];
+ ## {SQL_VARCHAR, "SQL_VARCHAR", quote_string, dequote_string, {VARCHAROID}, DBDPG_TRUE },
+ printf OUT qq{\t\{$sql, "$sql", $type{$_}[1], $type{$_}[2], \{$_\}, DBDPG_TRUE\},\n};
+ $pos{$sql} = $item++;
+ $maxlen = length $sql if length $sql > $maxlen;
+}
+print OUT "\};\n\n";
+
+print OUT "sql_type_info_t* sql_type_data(sql_type)\n\tint sql_type;\n\{\tswitch(sql_type) \{\n";
+for (sort { $pos{$a} <=> $pos{$b} } keys %pos) {
+ printf OUT qq{\t\tcase %-*s return \&sql_types\[%d\];\n}, 1+$maxlen, "$_:", $pos{$_};
+}
+print OUT "\t\tdefault: return NULL;\n\t\}\n\}\n\n/" ."*\n";
+
+seek(DATA,0,0);
+1 while <DATA> !~ /!perl/;
+print OUT "#!perl\n";
+while (<DATA>) { print OUT $_; }
+close(OUT);
+system("mv $outfile types.c");
+print "Wrote types.c\n";
+
+exit;
+__DATA__
+## Format: for each row, there are 6 items, comma separated:
+## 1. The internal name, taken from the PG source code: always ends in "OID"
+## 2. The given name, usually as simple as lowercasing and dropping the OID
+## 3. The function name we use to do the quoting, or 0 if we do not bind it
+## 4. The function name we use for DE-quoting
+## 5. The closest SQL_ datatype, or 0 if there is none
+## 6. Whether this is the one to use for reverse SQL_ type mapping
+## Try to keep them grouped by the quoting function, SQL_ mapper, then the internal name
+
+## Numbers - no quoting needed
+INT2OID, int2, null_quote, null_dequote, SQL_SMALLINT, 1
+INT4OID, int4, null_quote, null_dequote, SQL_INTEGER, 1
+INT8OID, int8, null_quote, null_dequote, SQL_DOUBLE, 1
+FLOAT4OID, float4, quote_string, dequote_char, SQL_NUMERIC, 1
+FLOAT8OID, float8, null_quote,null_dequote, SQL_REAL, 1
+NUMERICOID, numeric, null_quote, null_dequote, SQL_DECIMAL, 1
+CIDOID, cid, null_quote, null_dequote, SQL_INTEGER, 0
+OIDOID, oid, null_quote, null_dequote, SQL_INTEGER, 0
+
+
+## Text - single quotes on end, escape backslashes and apostrophes
+VARCHAROID, varchar, quote_string, dequote_string, SQL_VARCHAR, 1
+BPCHAROID, bpchar, quote_string, dequote_char, SQL_CHAR, 1
+NAMEOID, name, null_quote, null_dequote, SQL_VARCHAR, 0
+TEXTOID, text, quote_string, dequote_string, SQL_VARCHAR, 0
+
+## Binary - special quoting rules
+BYTEAOID, bytea, quote_bytea, dequote_bytea, SQL_VARBINARY, 1
+CHAROID, char, quote_string, dequote_char, 0, 0
+
+## Boolean
+BOOLOID, bool, quote_bool, dequote_bool, SQL_BOOLEAN, 1
+
+## Time and date
+DATEOID, date, null_quote, null_dequote, SQL_TYPE_DATE, 1
+TIMEOID, time, null_quote, null_dequote, SQL_TYPE_TIME, 1
+TIMESTAMPOID, timestamp, quote_string, dequote_string, SQL_TYPE_TIMESTAMP, 1
+TIMESTAMPTZOID, datetime, quote_string, dequote_string, SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, 1
+TIMETZOID, timestamptz, null_quote, null_dequote, SQL_TYPE_TIME_WITH_TIMEZONE, 0
+
+
+## Others
+ANYELEMENTOID, anyelement, 0, 0, 0, 0
+ABSTIMEOID, abstime, null_quote, null_dequote, 0, 0
+ACLITEMOID, aclitem, null_quote, null_dequote, 0, 0
+ANYARRAYOID, anyarray, null_quote, null_dequote, SQL_ARRAY, 0
+ANYOID, any, null_quote, null_dequote, 0, 0
+BITOID, bitstring, null_quote, null_dequote, 0, 0
+BOXOID, box, null_quote, null_dequote, 0, 0
+CASHOID, money, null_quote, null_dequote, 0, 0
+CIDROID, IP - cidr, null_quote, null_dequote, 0, 0
+CIRCLEOID, circle, null_quote, null_dequote, 0, 0
+CSTRINGOID, cstring, null_quote, null_dequote, 0, 0
+INETOID, IP address, null_quote, null_dequote, 0, 0
+INT2VECTOROID, int28, null_quote, null_dequote, 0, 0
+INT4ARRAYOID, int4array, 0, 0, 0, 0
+INTERNALOID, internal, null_quote, null_dequote, 0, 0
+INTERVALOID, timespan, quote_string, dequote_string, SQL_INTERVAL, 0
+LANGUAGE_HANDLEROID, languagehandle, null_quote, null_dequote, 0, 0
+LINEOID, line, null_quote, null_dequote, 0, 0
+LSEGOID, lseg, null_quote, null_dequote, 0, 0
+MACADDROID, MAC address, quote_string,dequote_string, 0, 0
+OIDVECTOROID, oid8, null_quote, null_dequote, 0, 0
+OPAQUEOID, opaque, null_quote, null_dequote, 0, 0
+PATHOID, path, null_quote, null_dequote, 0, 0
+PG_ATTRIBUTE_RELTYPE_OID, pg_attribute_reltype, 0, 0, 0, 0
+PG_CLASS_RELTYPE_OID, pg_class_reltype, 0, 0, 0, 0
+PG_PROC_RELTYPE_OID, pg_proc_reltype, 0, 0, 0, 0
+PG_TYPE_RELTYPE_OID, pg_type_reltype, 0, 0, 0, 0
+POINTOID, point, null_quote, null_dequote, 0, 0
+POLYGONOID, polygon, null_quote, null_dequote, 0, 0
+RECORDOID, record, null_quote, null_dequote, 0, 0
+REFCURSOROID, refcursor, null_quote, null_dequote, 0, 0
+REGCLASSOID, regclass, null_quote, null_dequote, 0, 0
+REGOPERATOROID, registeroperator_args , null_quote, null_dequote, 0, 0
+REGOPEROID, registeredoperator, null_quote, null_dequote, 0, 0
+REGPROCEDUREOID, regprocedureoid, null_quote, null_dequote, 0, 0
+REGPROCOID, regproc, null_quote, null_dequote, 0, 0
+REGTYPEOID, regtype, null_quote, null_dequote, 0, 0
+REGTYPEARRAYOID, regtypearray, null_quote, null_dequote, 0, 0
+RELTIMEOID, reltime, null_quote, null_dequote, 0, 0
+TIDOID, tid, null_quote, null_dequote, 0, 0
+TINTERVALOID, tinterval, null_quote, null_dequote, 0, 0
+TRIGGEROID, trigger, null_quote, null_dequote, 0, 0
+UNKNOWNOID, unknown, quote_string, dequote_string, SQL_UNKNOWN_TYPE, 0
+VARBITOID, vbitstring, null_quote, null_dequote, 0, 0
+VOIDOID, void, null_quote, null_dequote, 0, 0
+XIDOID, xid, null_quote, null_dequote, 0, 0
+
+
+__END__
+
+
+*/
+
+
Added: packages/libdbd-pg-perl/branches/upstream/current/types.h
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/types.h 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/types.h 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,86 @@
+#ifndef DBDPGTYEPSH
+#define DBDPGTYEPSH
+
+typedef struct sql_type_info {
+ int type_id;
+ char *type_name;
+ char* (*quote)();
+ void (*dequote)();
+ union {
+ int pg;
+ int sql;
+ } type;
+ bool bind_ok;
+} sql_type_info_t;
+
+sql_type_info_t* pg_type_data(int);
+sql_type_info_t* sql_type_data(int);
+
+#define ABSTIMEOID 702
+#define ACLITEMOID 1033
+#define ANYARRAYOID 2277
+#define ANYELEMENTOID 2283
+#define ANYOID 2276
+#define BITOID 1560
+#define BOOLOID 16
+#define BOXOID 603
+#define BPCHAROID 1042
+#define BYTEAOID 17
+#define CASHOID 790
+#define CHAROID 18
+#define CIDOID 29
+#define CIDROID 650
+#define CIRCLEOID 718
+#define CSTRINGOID 2275
+#define DATEOID 1082
+#define FLOAT4OID 700
+#define FLOAT8OID 701
+#define INETOID 869
+#define INT2OID 21
+#define INT2VECTOROID 22
+#define INT4ARRAYOID 1007
+#define INT4OID 23
+#define INT8OID 20
+#define INTERNALOID 2281
+#define INTERVALOID 1186
+#define LANGUAGE_HANDLEROID 2280
+#define LINEOID 628
+#define LSEGOID 601
+#define MACADDROID 829
+#define NAMEOID 19
+#define NUMERICOID 1700
+#define OIDOID 26
+#define OIDVECTOROID 30
+#define OPAQUEOID 2282
+#define PATHOID 602
+#define PG_ATTRIBUTE_RELTYPE_OID 75
+#define PG_CLASS_RELTYPE_OID 83
+#define PG_PROC_RELTYPE_OID 81
+#define PG_TYPE_RELTYPE_OID 71
+#define POINTOID 600
+#define POLYGONOID 604
+#define RECORDOID 2249
+#define REFCURSOROID 1790
+#define REGCLASSOID 2205
+#define REGOPERATOROID 2204
+#define REGOPEROID 2203
+#define REGPROCEDUREOID 2202
+#define REGPROCOID 24
+#define REGTYPEARRAYOID 2211
+#define REGTYPEOID 2206
+#define RELTIMEOID 703
+#define TEXTOID 25
+#define TIDOID 27
+#define TIMEOID 1083
+#define TIMESTAMPOID 1114
+#define TIMESTAMPTZOID 1184
+#define TIMETZOID 1266
+#define TINTERVALOID 704
+#define TRIGGEROID 2279
+#define UNKNOWNOID 705
+#define VARBITOID 1562
+#define VARCHAROID 1043
+#define VOIDOID 2278
+#define XIDOID 28
+
+#endif
Added: packages/libdbd-pg-perl/branches/upstream/current/win32.mak
===================================================================
--- packages/libdbd-pg-perl/branches/upstream/current/win32.mak 2006-04-09 13:38:55 UTC (rev 2535)
+++ packages/libdbd-pg-perl/branches/upstream/current/win32.mak 2006-04-13 20:25:19 UTC (rev 2536)
@@ -0,0 +1,107 @@
+
+## Makefile for Microsoft Visual C++ 5.0 (or compat)
+
+## See the README.win32 file for instructions
+
+!IF "$(OS)" == "Windows_NT"
+NULL=
+!ELSE
+NULL=nul
+!ENDIF
+
+CPP=cl.exe
+
+!IFDEF DEBUG
+OPT=/Od /Zi /MDd
+LOPT=/DEBUG
+DEBUGDEF=/D _DEBUG
+OUTDIR=.\Debug
+INTDIR=.\Debug
+!ELSE
+OPT=/O2 /MD
+LOPT=
+DEBUGDEF=/D NDEBUG
+OUTDIR=.\Release
+INTDIR=.\Release
+!ENDIF
+
+ALL : "..\..\port\pg_config_paths.h" "$(OUTDIR)\pg_config.exe"
+
+CLEAN :
+ - at erase "$(INTDIR)\pg_config.obj"
+ - at erase "$(OUTDIR)\pg_config.exe"
+ - at erase "$(INTDIR)\..\..\port\pg_config_paths.h"
+
+"..\..\port\pg_config_paths.h": win32.mak
+ echo #define PGBINDIR "" >$@
+ echo #define PGSHAREDIR "" >>$@
+ echo #define SYSCONFDIR "" >>$@
+ echo #define INCLUDEDIR "" >>$@
+ echo #define PKGINCLUDEDIR "" >>$@
+ echo #define INCLUDEDIRSERVER "" >>$@
+ echo #define LIBDIR "" >>$@
+ echo #define PKGLIBDIR "" >>$@
+ echo #define LOCALEDIR "" >>$@
+
+"$(OUTDIR)" :
+ if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"
+
+CPP_PROJ=/nologo $(OPT) /W3 /GX /D "WIN32" $(DEBUGDEF) /D "_CONSOLE" /D\
+ "_MBCS" /Fp"$(INTDIR)\pg_config.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c \
+ /I ..\..\include /I ..\..\interfaces\libpq /I ..\..\include\port\win32 \
+ /D "HAVE_STRDUP" /D "FRONTEND" /D VAL_CONFIGURE="\"\""
+
+CPP_OBJS=$(INTDIR)/
+CPP_SBRS=.
+
+LINK32=link.exe
+LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib\
+ advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib\
+ odbccp32.lib wsock32.lib /nologo /subsystem:console /incremental:no\
+ /pdb:"$(OUTDIR)\pg_config.pdb" /machine:I386 $(LOPT) /out:"$(OUTDIR)\pg_config.exe"
+LINK32_OBJS= \
+ "$(INTDIR)\pg_config.obj" \
+ "$(INTDIR)\pgstrcasecmp.obj" \
+ "$(OUTDIR)\path.obj" \
+ "$(INTDIR)\exec.obj" \
+!IFDEF DEBUG
+ "..\..\interfaces\libpq\Debug\libpqddll.lib"
+!ELSE
+ "..\..\interfaces\libpq\Release\libpqdll.lib"
+!ENDIF
+
+"$(OUTDIR)\pg_config.exe" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS)
+ $(LINK32) @<<
+ $(LINK32_FLAGS) $(LINK32_OBJS)
+<<
+
+"$(OUTDIR)\pg_config.obj" : .\pg_config.c
+ $(CPP) @<<
+ $(CPP_PROJ) ..\pg_config.c
+<<
+
+"$(OUTDIR)\path.obj" : "$(OUTDIR)" ..\..\port\path.c
+ $(CPP) @<<
+ $(CPP_PROJ) ..\..\port\path.c
+<<
+
+"$(INTDIR)\pgstrcasecmp.obj" : ..\..\port\pgstrcasecmp.c
+ $(CPP) @<<
+ $(CPP_PROJ) ..\..\port\pgstrcasecmp.c
+<<
+
+"$(INTDIR)\exec.obj" : ..\..\port\exec.c
+ $(CPP) @<<
+ $(CPP_PROJ) ..\..\port\exec.c
+<<
+
+..c{$(CPP_OBJS)}.obj::
+ $(CPP) @<<
+ $(CPP_PROJ) $<
+<<
+
+..cpp{$(CPP_OBJS)}.obj::
+ $(CPP) @<<
+ $(CPP_PROJ) $<
+<<
+
More information about the Pkg-perl-cvs-commits
mailing list