DBD-Pg-3.20.2/0000755000175000017500000000000015175422003011164 5ustar greggregDBD-Pg-3.20.2/dbivport.h0000644000175000017500000000374015147431635013204 0ustar greggreg/* dbivport.h Provides macros that enable greater portability between DBI versions. This file should be *copied* and included in driver distributions and #included into the source, after #include DBIXS.h New driver releases should include an updated copy of dbivport.h from the most recent DBI release. */ #ifndef DBI_VPORT_H #define DBI_VPORT_H #ifndef DBIh_SET_ERR_CHAR /* Emulate DBIh_SET_ERR_CHAR Only uses the err_i, errstr and state parameters. */ #define DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method) \ sv_setiv(DBIc_ERR(imp_xxh), err_i); \ (state) ? (void)sv_setpv(DBIc_STATE(imp_xxh), state) : (void)SvOK_off(DBIc_STATE(imp_xxh)); \ sv_setpv(DBIc_ERRSTR(imp_xxh), errstr) #endif #ifndef DBIcf_Executed #define DBIcf_Executed 0x080000 #endif #ifndef DBIc_TRACE_LEVEL_MASK #define DBIc_TRACE_LEVEL_MASK 0x0000000F #define DBIc_TRACE_FLAGS_MASK 0xFFFFFF00 #define DBIc_TRACE_SETTINGS(imp) (DBIc_DBISTATE(imp)->debug) #define DBIc_TRACE_LEVEL(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_LEVEL_MASK) #define DBIc_TRACE_FLAGS(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_FLAGS_MASK) /* DBIc_TRACE_MATCHES - true if s1 'matches' s2 (c.f. trace_msg()) DBIc_TRACE_MATCHES(foo, DBIc_TRACE_SETTINGS(imp)) */ #define DBIc_TRACE_MATCHES(s1, s2) \ ( ((s1 & DBIc_TRACE_LEVEL_MASK) >= (s2 & DBIc_TRACE_LEVEL_MASK)) \ || ((s1 & DBIc_TRACE_FLAGS_MASK) & (s2 & DBIc_TRACE_FLAGS_MASK)) ) /* DBIc_TRACE - true if flags match & DBI level>=flaglevel, or if DBI level>level DBIc_TRACE(imp, 0, 0, 4) = if level >= 4 DBIc_TRACE(imp, DBDtf_FOO, 2, 4) = if tracing DBDtf_FOO & level>=2 or level>=4 DBIc_TRACE(imp, DBDtf_FOO, 2, 0) = as above but never trace just due to level */ #define DBIc_TRACE(imp, flags, flaglevel, level) \ ( (flags && (DBIc_TRACE_FLAGS(imp) & flags) && (DBIc_TRACE_LEVEL(imp) >= flaglevel)) \ || (level && DBIc_TRACE_LEVEL(imp) >= level) ) #endif #endif /* !DBI_VPORT_H */ DBD-Pg-3.20.2/dbdimp.h0000644000175000017500000002770115166170753012617 0ustar greggreg/* Copyright (c) 2000-2026 Greg Sabino Mullane and others: see the Changes file Portions Copyright (c) 1997-2000 Edmund Mergl Portions Copyright (c) 1994-1997 Tim Bunce You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. */ /* Define drh implementor data structure */ struct imp_drh_st { dbih_drc_t com; /* MUST be first element in structure */ }; /* Define dbh implementor data structure */ struct imp_dbh_st { dbih_dbc_t com; /* MUST be first element in structure */ int pg_protocol; /* value of PQprotocolVersion, usually 3 (could also be 0) */ int pg_server_version; /* server version e.g. 80100 */ int pid_number; /* prefixed before prepare_number */ int prepare_number; /* internal prepared statement name modifier */ int copystate; /* 0=none PGRES_COPY_IN PGRES_COPY_OUT */ bool copybinary; /* whether the copy is in binary format */ int pg_errorlevel; /* PQsetErrorVerbosity. Set by user, defaults to 1 */ bool server_prepare; /* do we want to use PQexecPrepared? Can be changed by user */ int switch_prepared; /* how many executes until we switch to PQexecPrepared */ int async_status; /* 0=no async 1=async started -1=async has been cancelled */ imp_sth_t *async_sth; /* current async statement handle */ AV *savepoints; /* list of savepoints */ PGconn *conn; /* connection structure */ char *sqlstate; /* from the last result */ bool pg_bool_tf; /* do bools return 't'/'f'? Set by user, default is 0 */ bool pg_int8_as_string; /* Return bigint values as string values always, default is 0 */ bool skip_deallocate; /* Do not deallocate our named prepare statements; default is 0 */ bool prepare_now; /* force immediate prepares, even with placeholders. Set by user, default is 0 */ bool done_begin; /* have we done a begin? (e.g. are we in a transaction?) */ bool dollaronly; /* only consider $1, $2 ... as valid placeholders */ bool nocolons; /* do not consider :1, :2 ... as valid placeholders */ bool ph_escaped; /* allow backslash to escape placeholders */ bool expand_array; /* transform arrays from the db into Perl arrays? Default is 1 */ bool txn_read_only; /* are we in read-only mode? Set with $dbh->{ReadOnly} */ int pg_enable_utf8; /* legacy utf8 flag: force utf8 flag on or off, regardless of client_encoding */ bool pg_utf8_flag; /* are we currently flipping the utf8 flag on? */ bool client_encoding_utf8; /* is the client_encoding utf8 last we checked? */ PGresult *last_result; /* PGresult structure from the last executed query (can be from imp_dbh or imp_sth) */ bool result_clearable; /* Is it alright to call PQclear on last_result? (statements handles set it to false */ imp_sth_t *do_tmp_sth; /* temporary sth to refer inside a do() call */ }; /* Each statement is broken up into segments */ struct seg_st { char *segment; /* non-placeholder string segment */ int placeholder; /* which placeholder this points to, 0=none */ struct ph_st *ph; /* points to the relevant ph structure */ struct seg_st *nextseg; /* linked lists are fun */ }; typedef struct seg_st seg_t; /* The placeholders are also a linked list */ struct ph_st { char *fooname; /* name if using :foo style */ char *value; /* the literal passed-in value, may be binary */ STRLEN valuelen; /* length of the value */ char *quoted; /* quoted version of the value, for PQexec only */ STRLEN quotedlen; /* length of the quoted value */ bool referenced; /* used for PREPARE AS construction */ bool defaultval; /* is it using a generic 'default' value? */ bool iscurrent; /* do we want to use a literal CURRENT_TIMESTAMP? */ bool isdefault; /* are we passing a literal 'DEFAULT'? */ bool isinout; /* is this a bind_param_inout value? */ SV *inout; /* what variable we are updating via inout magic */ sql_type_info_t* bind_type; /* type information for this placeholder */ struct ph_st *nextph; /* more linked list goodness */ }; typedef struct ph_st ph_t; typedef enum { PLACEHOLDER_NONE, PLACEHOLDER_QUESTIONMARK, PLACEHOLDER_DOLLAR, PLACEHOLDER_COLON } PGPlaceholderType; #define PLACEHOLDER_TYPE_COUNT (PLACEHOLDER_COLON + 1) /* Define sth implementor data structure */ struct imp_sth_st { dbih_stc_t com; /* MUST be first element in structure */ bool server_prepare; /* inherited from dbh */ int switch_prepared; /* inherited from dbh */ int number_iterations; /* how many times has the statement been executed? Used by switch_prepared */ PGPlaceholderType 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 */ long rows; /* number of affected rows */ int async_flag; /* async? 0=no 1=async 2=cancel 4=wait */ int async_status; /* 0=no async 1=async started -1=async has been cancelled */ STRLEN totalsize; /* total string length of the statement (with no placeholders)*/ const char ** PQvals; /* List of values to pass to PQ* */ int * PQlens; /* List of lengths to pass to PQ* */ int * PQfmts; /* List of formats to pass to PQ* */ Oid * PQoids; /* List of types to pass to PQ* */ char *prepare_name; /* name of the prepared query; NULL if not prepared */ char *firstword; /* first word of the statement */ PGresult *result; /* result structure from the executed query */ sql_type_info_t **type_info; /* type of each column in result */ seg_t *seg; /* linked list of segments */ ph_t *ph; /* linked list of placeholders */ bool prepare_now; /* prepare this statement right away, even if it has placeholders */ bool prepared_by_us; /* false if {prepare_name} set directly */ bool direct; /* allow bypassing of the statement parsing */ bool is_dml; /* is this SELECT/INSERT/UPDATE/DELETE/MERGE/VALUES/TABLE/WITH? */ bool has_binary; /* does it have one or more binary placeholders? */ bool has_default; /* does it have one or more 'DEFAULT' values? */ bool has_current; /* does it have one or more 'DEFAULT' values? */ bool dollaronly; /* Only use $1 as placeholders, allow all else */ bool nocolons; /* do not consider :1, :2 ... as valid placeholders */ bool use_inout; /* Any placeholders using inout? */ bool all_bound; /* Have all placeholders been bound? */ }; /* Avoid name clashes by assigning DBI funcs to a pg_ name. */ /* In order of appearance in dbdimp.c */ #define dbd_init pg_init extern void dbd_init (dbistate_t *dbistate); #define dbd_db_login6 pg_db_login6 int dbd_db_login6 (SV * dbh, imp_dbh_t * imp_dbh, char * dbname, char * uid, char * pwd, SV *attr); #define dbd_db_continue_connect pg_db_continue_connect int dbd_db_continue_connect(SV *h); #define dbd_db_ping pg_db_ping int dbd_db_ping(SV *dbh); #define dbd_db_commit pg_db_commit int dbd_db_commit (SV * dbh, imp_dbh_t * imp_dbh); #define dbd_db_rollback pg_db_rollback int dbd_db_rollback (SV * dbh, imp_dbh_t * imp_dbh); #define dbd_db_disconnect pg_db_disconnect int dbd_db_disconnect (SV * dbh, imp_dbh_t * imp_dbh); #define dbd_db_destroy pg_db_destroy void dbd_db_destroy (SV * dbh, imp_dbh_t * imp_dbh); #define dbd_db_FETCH_attrib pg_db_FETCH_attrib SV * dbd_db_FETCH_attrib (SV * dbh, imp_dbh_t * imp_dbh, SV * keysv); #define dbd_db_STORE_attrib pg_db_STORE_attrib int dbd_db_STORE_attrib (SV * dbh, imp_dbh_t * imp_dbh, SV * keysv, SV * valuesv); #define dbd_st_FETCH_attrib pg_st_FETCH_attrib SV * dbd_st_FETCH_attrib (SV * sth, imp_sth_t * imp_sth, SV * keysv); #define dbd_st_STORE_attrib pg_st_STORE_attrib int dbd_st_STORE_attrib (SV * sth, imp_sth_t * imp_sth, SV * keysv, SV * valuesv); #define dbd_discon_all pg_discon_all int dbd_discon_all (SV * drh, imp_drh_t * imp_drh); #define dbd_st_prepare_sv pg_st_prepare_sv int dbd_st_prepare_sv (SV * sth, imp_sth_t * imp_sth, SV * statement_sv, SV * attribs); #define dbd_bind_ph pg_bind_ph int dbd_bind_ph (SV * sth, imp_sth_t * imp_sth, SV * ph_name, SV * newvalue, IV sql_type, SV * attribs, int is_inout, IV maxlen); #define dbd_st_execute pg_st_execute long dbd_st_execute (SV * sth, imp_sth_t * imp_sth); #define dbd_st_fetch pg_st_fetch AV * dbd_st_fetch (SV * sth, imp_sth_t * imp_sth); #define dbd_st_rows pg_st_rows long dbd_st_rows (SV * sth, imp_sth_t * imp_sth); #define dbd_st_finish pg_st_finish int dbd_st_finish (SV * sth, imp_sth_t * imp_sth); #define dbd_st_cancel pg_st_cancel int dbd_st_cancel (SV * sth, imp_sth_t * imp_sth); #define dbd_st_destroy pg_st_destroy void dbd_st_destroy (SV * sth, imp_sth_t * imp_sth); #define dbd_st_blob_read pg_st_blob_read int dbd_st_blob_read (SV * sth, imp_sth_t * imp_sth, int lobjId, long offset, long len, SV * destrv, long destoffset); #define dbd_st_canonical_ids pg_st_canonical_ids SV* dbd_st_canonical_ids(SV *sth, imp_sth_t *imp_sth); #define dbd_st_canonical_names pg_st_canonical_names SV* dbd_st_canonical_names(SV *sth, imp_sth_t *imp_sth); /* Everything else should map back to the DBI version, or be handled by Pg.pm TODO: Explicitly map out each one. */ /* Custom PG functions, in order they appear in dbdimp.c */ int pg_db_getfd (imp_dbh_t * imp_dbh); SV * pg_db_pg_notifies (SV *dbh, imp_dbh_t *imp_dbh); SV * pg_rightgraded_sv(pTHX_ SV *input, bool utf8); SV * pg_stringify_array(SV * input, const char * array_delim, int server_version, bool utf8); long pg_quickexec (SV *dbh, const char *sql, const int asyncflag); int pg_db_putline (SV *dbh, SV *svbuf); int pg_db_getline (SV *dbh, SV * svbuf, int length); int pg_db_getcopydata (SV *dbh, SV * dataline, int async); int pg_db_putcopydata (SV *dbh, SV * dataline); int pg_db_putcopyend (SV * dbh); int pg_db_endcopy (SV * dbh); SV * pg_db_error_field (SV *dbh, char * fieldname); void pg_db_pg_server_trace (SV *dbh, FILE *fh); void pg_db_pg_server_untrace (SV *dbh); int pg_db_savepoint (SV *dbh, imp_dbh_t *imp_dbh, char * savepoint); int pg_db_rollback_to (SV *dbh, imp_dbh_t *imp_dbh, const char * savepoint); int pg_db_release (SV *dbh, imp_dbh_t *imp_dbh, char * savepoint); unsigned int pg_db_lo_creat (SV *dbh, int mode); int pg_db_lo_open (SV *dbh, unsigned int lobjId, int mode); int pg_db_lo_close (SV *dbh, int fd); int pg_db_lo_read (SV *dbh, int fd, char *buf, size_t len); int pg_db_lo_write (SV *dbh, int fd, char *buf, size_t len); IV pg_db_lo_lseek (SV *dbh, int fd, IV offset, int whence); IV pg_db_lo_tell (SV *dbh, int fd); int pg_db_lo_truncate (SV *dbh, int fd, IV len); int pg_db_lo_unlink (SV *dbh, unsigned int lobjId); unsigned int pg_db_lo_import (SV *dbh, char *filename); unsigned int pg_db_lo_import_with_oid (SV *dbh, char *filename, unsigned int lobjId); int pg_db_lo_export (SV *dbh, unsigned int lobjId, char *filename); long pg_db_result (SV *h, imp_dbh_t *imp_dbh); int pg_db_ready(SV *h, imp_dbh_t *imp_dbh); int pg_db_send_cancel (SV *h, imp_dbh_t *imp_dbh); int pg_db_cancel (SV *h, imp_dbh_t *imp_dbh); int pg_db_cancel_sth (SV *sth, imp_sth_t *imp_sth); SV * pg_upgraded_sv(pTHX_ SV *input); SV * pg_downgraded_sv(pTHX_ SV *input); /* end of dbdimp.h */ DBD-Pg-3.20.2/SIGNATURE0000644000175000017500000001272415175421702012463 0ustar greggregThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.89. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: RIPEMD160 SHA256 e4c6f4cdc9560a09492f196fc9a180867fab12742d7d05052d9842b395c6a9eb .dir-locals.el SHA256 f08dbb0ceace735e096914b6ead26b420c10fe8aa2fb3eab00e7f22c875a8a4a .perlcriticrc SHA256 56479e9cf7c00a72bc5458593463a5a6e5481f74f3a4be5ef94129e01c3e2f91 CONTRIBUTING.md SHA256 f0a7aafdcc7b87914a748893368ca26a7c9a2a6115a3d1d3fa5c191d06ccd412 Changes SHA256 d52a34724b2e3c40ffa2b3b378b574b9e3db27bc3132c88e0be3675f93f378a5 LICENSES/artistic.txt SHA256 ab15fd526bd8dd18a9e77ebc139656bf4d33e97fc7238cd11bf60e2b9b8666c6 LICENSES/gpl-2.0.txt SHA256 f1d6ae83502e63f642b493abc3ab68d323b2ffce34210caae6ce5ae906ed37cb MANIFEST SHA256 ed893c9f3a0f4e70f9588751d6761c7ef539a7afd1eae8de4b6c2d2e77b91454 MANIFEST.SKIP SHA256 5cb3423cbfea0a909f507ba2ca5ca2b35fa5812419993cff9fdb16615781cb2b META.json SHA256 7e0f4d8d031d60c546d3c66f05131267a17fdd3c438e89d2af4f9150ee04fc05 META.yml SHA256 25ed727f792aa3834da5f70c9303b16a99295fb9c8f51361668f4eccdb7d66e2 Makefile.PL SHA256 4692b5bc416cd83b61a82c09ea07062b29ff07a914980067b58d1752cdf287b0 Pg.h SHA256 13bee5c74c50d140220b94731be3ded692d2562bbd602c4bf6441f0ebc113eac Pg.pm SHA256 c1e75e152079f72af022f024fc9db1f1dda817cd3464c0fd052618ca43668f17 Pg.xs SHA256 b454eaa2b5e758d2dafecdd694b391af6a389f84d3eb2ba29fe0757feab41eac README SHA256 e64146064271c75de2193fff2127eafe059f3ce3e5a61e0f12f21954d8395a7a README.dev SHA256 a1d224603fe3a343ba0a0f40086065c81d57fbebc734b5382b0d359da16bdd94 README.win32 SHA256 5ae3cde268eba10902eb80b0b5604770179919c7d13b6c70555a5350b351dbe6 SECURITY.md SHA256 b5d05735f4b76491339cac7070bdf4909420cffb11fd0ccd0d15a63da88a2f03 TODO SHA256 483cff38365ee41ba173674367c756fc88446b6f410f9bb668a627cc3a51a15a dbdimp.c SHA256 e9646b251576dac1175337d761d0a338658f46b576696251a458e8154fa3f07a dbdimp.h SHA256 9e53f7f41aaaf1b540e2784756ef6f16f61b63df0d9956483aded3c49b6e0f48 dbivport.h SHA256 c4b26bafe2f67def43475415d35826c983f421fe0079aa0a6bc1dd06d3c2885a lib/Bundle/DBD/Pg.pm SHA256 d442a67aa9e735c2a14587edc651bb1ad10a48ccf25872c8563fce3c0ff6e3de quote.c SHA256 bd0907b366d3c14a5af85c2ab2664a9d8125156400a5ccff48ce1acc1a96cd01 quote.h SHA256 49950c2c882018916ef89b59a1707b732064eb3bb6acb6a350111e1dc81000b8 t/00_signature.t SHA256 4a95e025f903ed2d6a0aa4470f46f075d4692b9a21bd1d316ead19fb9cabd2dd t/00basic.t SHA256 7173c7221f401ee5e599fb70b9ce5b062989028dada13e2f1fb4c111b4891f67 t/01connect.t SHA256 b3b4515b0183179330b6122a7ee887fb5257fc4a3b0359b3972f6a0503f1c7f9 t/01constants.t SHA256 41d43177764062237447339902738c07aa7d34a1b03636124f3d3ce95275e344 t/01keywords.t SHA256 259f68fdb2c658c7fe128fed7c050732396d7ce5c3940eac469587ec82636d40 t/02attribs.t SHA256 094e76dad65e987983cfdb4a0384d78048d6de7e5ffa28a1c7ba617282294e27 t/03dbmethod.t SHA256 d5707daebd0767965dbce29fcd6e4832f9e825a9e7b7f288b5f697e99dd28487 t/03smethod.t SHA256 f90291f7b6e62460f234573de7c5c03b86bab10fdd8e5ade3fccfbcef2a4a31b t/04misc.t SHA256 f5348b4ad07891a20151aaddef89c2db1f0b9c1c1880f119eb241cf21200b66c t/06bytea.t SHA256 2911ac070cf23dc9b3f69d98e8c8a559e2b422eb1d849c3300c33e902845b6b3 t/07copy.t SHA256 0b459f943935babfa9ed5f28db42b72f3e9b619b6c92fc42fa9a609668d51e53 t/08async.t SHA256 3eb19cccca6e2afdfe46ec59743d32bbea3b537d23c01d90675f7f820bfbd51a t/09arrays.t SHA256 8261ab099249ddfa0f754c22bb9e5143cd866e3c79f16d846773060970c7dfb8 t/10_pg_error_field.t SHA256 754d0ac5bb4fa1ee8ebaeeb8e48237152349dec68ee54ef201d3fcbdfd548477 t/12placeholders.t SHA256 982a438ec73b0428c263ed4608d82fd466a1668cfd4095c69d93ae002486368c t/20savepoints.t SHA256 0fa74a74f959184b3b9027c47c67e8cfe0c4370223029e223d7aaacc22ab3ed0 t/30unicode.t SHA256 16b874ee36dcedc566b6c9b4c8142173e3a6babc660721939756d8a0a7d697f2 t/99cleanup.t SHA256 d937513d373cc970071f915dfba9dd5c0da7dc4fe02b956b4700635a13a3c07c t/dbdpg_test_setup.pl SHA256 3f53191613dc10d2d30414f7e6e31a3b3486d91fe07ee77d24ea3d6f2eb61bb6 t/lib/App/Info.pm SHA256 8faf2c2b3ff952ff0721c04ac8e04ec143939592b0d55a135ea15d310144f576 t/lib/App/Info/Handler.pm SHA256 e3c5a92afea9c568bf9534a0f13e84864bce0899d2d96857bdaba2c2c565d6e8 t/lib/App/Info/Handler/Print.pm SHA256 e98cd9cf586aaba135ca06d9029d881337843620de4856b19465aa78674d08ab t/lib/App/Info/Handler/Prompt.pm SHA256 8519856d47937472c0ad078827319400c235a4c9ed7dadb9f3449937416d7922 t/lib/App/Info/RDBMS.pm SHA256 1a04a802a38fa8ba2cf001deb6bb20e0e4f9705b93d45600329372c26e108803 t/lib/App/Info/RDBMS/PostgreSQL.pm SHA256 17ffc3a80591fbdddc74bd13a622284e05421c58f773c8deaaad6e0eae417c77 t/lib/App/Info/Request.pm SHA256 0cc067040c7056734dec93ea399d7b4dbc7d202aa5c081e6030081c5ed726ff6 t/lib/App/Info/Util.pm SHA256 93ebeadf8b7dcdb233f0e5dfa1298d1ce4329a949522ba528427d756030b0254 testme.tmp.pl SHA256 d7cabd2aa413100d1308b7ed0d5ed84c424e41d1cb145674485905a41e547b35 types.c SHA256 4aa0615cb419d0fcdfec6cd42ef3a921f39dd7a714ea1c90e7e11473fbe5cfcd types.h SHA256 4628f92764bdb3e2b04bda7f30fc497231fbbf80dfd24cc09ee3df2e6d6d4387 win32.mak -----BEGIN PGP SIGNATURE----- iF0EAREDAB0WIQQlKd9quPeUB+lERbS8m5BnFJZKyAUCafYjwgAKCRC8m5BnFJZK yPozAJkB5tsw97NPZydPfrFUTy49rhvTEACgohCLWEOjUJbPKCLIj9gip0AY4w8= =Vj46 -----END PGP SIGNATURE----- DBD-Pg-3.20.2/SECURITY.md0000644000175000017500000001024415166170753012772 0ustar greggregThis is the Security Policy for the Perl DBD-Pg distribution. Report security issues via the [private security issue reporting feature in GitHub](https://github.com/bucardo/dbdpg/security/advisories/new). The latest version of the Security Policy can be found in the [GitHub repository for DBD::Pg](https://github.com/bucardo/dbdpg). This text is based on the CPAN Security Group's Guidelines for Adding a Security Policy to Perl Distributions (version 1.4.2) https://security.metacpan.org/docs/guides/security-policy-for-authors.html # How to Report a Security Vulnerability Security vulnerabilities can be reported via the [private security issue reporting feature in GitHub](https://github.com/bucardo/dbdpg/security/advisories/new). Please include as many details as possible, including code samples and/or test cases, so that the issue can be reproduced. Check that your report does not expose any sensitive data, such as passwords, tokens, or personal information. Project maintainers will normally credit the reporter when a vulnerability is disclosed or fixed. If you do not want to be credited publicly, please indicate that in your report. If you would like any help with triaging the issue, or if the issue is being actively exploited, please copy the report to the CPAN Security Group (CPANSec) at . Please *do not* use the public issue reporting system on RT or GitHub issues for reporting security vulnerabilities in DBD::Pg. Please do not disclose the security vulnerability in public forums until past any proposed date for public disclosure, or it has been made public by the maintainers or CPANSec. That includes patches or pull requests or mitigation advice. For more information, see [Report a Security Issue](https://security.metacpan.org/docs/report.html) on the CPANSec website. ## Response to Reports The maintainer(s) aim to acknowledge your security report as soon as possible. However, they cannot guarantee a rapid response. If you have not received a response from them within a week, then please send a reminder to them and copy the report to CPANSec at . Please note that the initial response to your report will be an acknowledgement, with a possible query for more information. It will not necessarily include any fixes for the issue. The project maintainer(s) may forward this issue to the security contacts for other projects where we believe it is relevant. This may include embedded libraries, system libraries, prerequisite modules or downstream software that uses this software. They may also forward this issue to CPANSec. # Which Software This Policy Applies To Any security vulnerabilities in DBD::Pg are covered by this policy. Security vulnerabilities in versions of any libraries that are included in DBD::Pg are also covered by this policy. Security vulnerabilities are considered anything that allows users to execute unauthorised code, access unauthorised resources, or to have an adverse impact on accessibility, integrity or performance of a system. Security vulnerabilities in upstream software (prerequisite modules or system libraries, or in Perl), are not covered by this policy unless they affect DBD::Pg, or DBD::Pg can be used to exploit vulnerabilities in them. Security vulnerabilities in downstream software (any software that uses DBD::Pg, or plugins to it that are not included with the DBD::Pg distribution) are not covered by this policy. ## Supported Versions of DBD::Pg The maintainer(s) will release security fixes for the latest version of DBD::Pg only. If a security vulnerability can be fixed by increasing the minimum version of Perl or the minimum version of other third-party software prerequisite, then they may do so. # Installation and Usage Issues The distribution metadata specifies minimum versions of prerequisites that are required for DBD::Pg to work. However, some of these prerequisites may have security vulnerabilities, and you should ensure that you are using the most up-to-date versions of these prerequisites when assessing security vulnerabilities in DBD::Pg. Where security vulnerabilities are known, the metadata may indicate newer versions as recommended. DBD-Pg-3.20.2/MANIFEST0000644000175000017500000000150615166170753012333 0ustar greggregChanges README CONTRIBUTING.md SECURITY.md SIGNATURE Pg.pm META.yml META.json TODO Makefile.PL .dir-locals.el MANIFEST MANIFEST.SKIP README.win32 README.dev win32.mak LICENSES/gpl-2.0.txt LICENSES/artistic.txt testme.tmp.pl Pg.h Pg.xs dbivport.h dbdimp.c dbdimp.h types.c types.h quote.c quote.h .perlcriticrc t/dbdpg_test_setup.pl t/00_signature.t t/00basic.t t/01connect.t t/01constants.t t/01keywords.t t/02attribs.t t/03dbmethod.t t/03smethod.t t/04misc.t t/06bytea.t t/07copy.t t/08async.t t/09arrays.t t/10_pg_error_field.t t/12placeholders.t t/20savepoints.t t/30unicode.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/Handler/Print.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 lib/Bundle/DBD/Pg.pm DBD-Pg-3.20.2/t/0000755000175000017500000000000015175422003011427 5ustar greggregDBD-Pg-3.20.2/t/03smethod.t0000644000175000017500000007103015166170753013437 0ustar greggreg#!perl ## Test of the statement handle methods ## The following methods are *not* currently tested here: ## "execute" ## "finish" ## "dump_results" use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use POSIX qw(:signal_h); use Test::More; use DBI ':sql_types'; use DBD::Pg qw/ :async /; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 152; isnt ($dbh, undef, 'Connect to database for statement handle method testing'); my ($SQL, $sth, $sth2, $result, @results, $expected, $rows, $t); my ($schema,$schema2,$schema3) = ('dbd_pg_testschema', 'dbd_pg_testschema2', 'dbd_pg_testschema3'); # # Test of the prepare flags # $t=q{Calling prepare() with no arguments gives an error}; eval{ $sth = $dbh->prepare(); }; like ($@, qr{\+ 0}, $t); $t=q{Calling prepare() with an undefined value returns undef}; $sth = $dbh->prepare(undef); is ($sth, undef, $t); $t='Prepare/execute with no flags works'; $SQL = 'SELECT id FROM dbd_pg_test WHERE id = ?'; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_server_prepare off at database handle works'; $dbh->{pg_server_prepare} = 0; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); $t='Setting database attribute pg_switch_prepared to 7 works'; $dbh->{pg_switch_prepared} = 7; is ($dbh->{pg_switch_prepared}, 7, $t); $t='Statement handle inherits pg_switch_prepared setting'; $sth = $dbh->prepare($SQL); is ($sth->{pg_switch_prepared}, 7, $t); $t='Setting statement attribute pg_switch_prepared to 6 works'; $sth->{pg_switch_prepared} = 6; is ($sth->{pg_switch_prepared}, 6, $t); $t='Running with statement attribute pg_switch_prepared at 6 works'; for (1..10) { $sth->execute(1); my $it = "$t (run $_ of 10)"; ok ($sth->execute, $it); } $t='Running with statement attribute pg_switch_prepared at -1 works'; $sth->{pg_switch_prepared} = -1; for (1..4) { $sth->execute(1); my $it = "$t (run $_ of 4)"; ok ($sth->execute, $it); } $t='Running with statement attribute pg_switch_prepared at 0 works'; $sth->{pg_switch_prepared} = 0; for (1..4) { $sth->execute(1); my $it = "$t (run $_ of 4)"; ok ($sth->execute, $it); } $t='Running with statement attribute pg_switch_prepared at 1 works'; $sth->{pg_switch_prepared} = 1; for (1..4) { $sth->execute(1); my $it = "$t (run $_ of 4)"; ok ($sth->execute, $it); } $t='Prepare/execute with pg_server_prepare on at database handle works'; $dbh->{pg_server_prepare} = 1; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); ## We must send a hashref as the final arg $t='Prepare fails when sent a non-hashref'; eval { $sth = $dbh->prepare('SELECT 123', ['I am not a hashref!']); }; like ($@, qr{not a hash}, $t); # Make sure that undefs are converted to NULL. $t='Prepare/execute with undef converted to NULL'; $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id, pdate) VALUES (?,?)'); ok ($sth->execute(401, undef), $t); $t='Prepare/execute with pg_server_prepare off at statement handle works'; $sth = $dbh->prepare($SQL, {pg_server_prepare => 0}); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_server_prepare on at statement handle works'; $sth = $dbh->prepare($SQL, {pg_server_prepare => 1}); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_prepare_now on at database handle works'; $dbh->{pg_prepare_now} = 1; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_prepare_now off at database handle works'; $dbh->{pg_prepare_now} = 0; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_prepare_now off at statement handle works'; $sth = $dbh->prepare($SQL, {pg_prepare_now => 0}); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_prepare_now on at statement handle works'; $sth = $dbh->prepare($SQL, {pg_prepare_now => 1}); $sth->execute(1); ok ($sth->execute, $t); # Test using our own prepared statements $t='Prepare/execute works with pg_prepare_name'; my $myname = 'dbdpg_test_1'; $dbh->do("PREPARE $myname(int) AS SELECT COUNT(*) FROM pg_class WHERE reltuples > \$1", {pg_direct=> 1}); $sth = $dbh->prepare('SELECT ?'); $sth->bind_param(1, 1, SQL_INTEGER); $sth->{pg_prepare_name} = $myname; ok ($sth->execute(1), $t); $dbh->do("DEALLOCATE $myname"); # # Test of the "bind_param" statement handle method # $t='Statement handle method "bind_param" works when binding an int column with an int'; $SQL = 'SELECT id FROM dbd_pg_test WHERE id = ?'; $sth = $dbh->prepare($SQL); ok ($sth->bind_param(1, 1), $t); $t='Statement handle method "bind_param" works when rebinding an int column with a string'; ok ($sth->bind_param(1, 'foo'), $t); # Check if the server is sending us warning messages # We assume that older servers are okay my $client_level = ''; $sth2 = $dbh->prepare('SHOW client_min_messages'); $sth2->execute(); $client_level = $sth2->fetchall_arrayref()->[0][0]; # # Test of the "bind_param_inout" statement handle method # $t='Invalid placeholder fails for bind_param_inout'; my $var = 123; $sth = $dbh->prepare('SELECT 1+?::int'); eval { $sth->bind_param_inout(0, \$var, 0); }; like ($@, qr{Cannot bind}, $t); eval { $sth->bind_param_inout(3, \$var, 0); }; like ($@, qr{Cannot bind}, $t); $t = q{Calling bind_param_inout with a non-scalar reference fails}; eval { $sth->bind_param_inout(1, 'noway', 0); }; like ($@, qr{needs a reference}, $t); eval { $sth->bind_param_inout(1, $t, 0); }; like ($@, qr{needs a reference}, $t); eval { $sth->bind_param_inout(1, [123], 0); }; like ($@, qr{needs a reference}, $t); $t = q{Calling bind_param_inout changes an integer value}; eval { $sth->bind_param_inout(1, \$var, 0); }; is ($@, q{}, $t); $var = 999; $sth->execute(); $sth->fetch; is ($var, 1000, $t); $t = q{Calling bind_param_inout changes a string value}; $sth = $dbh->prepare(q{SELECT 'X'||?::text}); $sth->bind_param_inout(1, \$var, 0); $var = 'abc'; $sth->execute(); $sth->fetch; is ($var, 'Xabc', $t); ## nospellcheck $t = q{Calling bind_param_inout changes a string to a float}; $sth = $dbh->prepare('SELECT ?::float'); $sth->bind_param_inout(1, \$var, 0); $var = '1e+6'; $sth->execute(); $sth->fetch; is ($var, '1000000', $t); $t = q{Calling bind_param_inout works for second placeholder}; $sth = $dbh->prepare('SELECT ?::float, 1+?::int'); $sth->bind_param_inout(2, \$var, 0); $var = 111; $sth->execute(222,333); $sth->fetch; is ($var, 112, $t); $t = q{Calling bind_param_inout changes two variables at once}; my $var2 = 234; $sth = $dbh->prepare('SELECT 1+?::float, 1+?::int'); $sth->bind_param_inout(1, \$var, 0); $sth->bind_param_inout(2, \$var2, 0); $var = 444; $var2 = 555; $sth->execute(); $sth->fetch; is ($var, 445, $t); is ($var2, 556, $t); # # Test of the "bind_param_array" statement handle method # $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id, val) VALUES (?,?)'); # Try with 1, 2, and 3 values. All should succeed $t='Statement handle method "bind_param_array" fails if second arg is a hashref'; eval { $sth->bind_param_array(1, {}, SQL_INTEGER); }; like ($@, qr{must be a scalar or an arrayref}, $t); $t='Statement handle method "bind_param_array" fails if first arg is not a number'; eval { $sth->bind_param_array('bread pudding', 123, SQL_INTEGER); }; like ($@, qr{named placeholders}, $t); $t='Statement handle method "bind_param_array" works binding three values to the first placeholder'; eval { $sth->bind_param_array(1, [ 30, 31, 32 ], SQL_INTEGER); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works binding one scalar value to the second placeholder'; eval { $sth->bind_param_array(2, 'Mulberry'); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works binding three values to the second placeholder'; eval { $sth->bind_param_array(2, [ 'Mango', 'Strawberry', 'Gooseberry' ]); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works when binding one value to the second placeholder'; eval { $sth->bind_param_array(2, [ 'Mangoz' ]); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works when binding two values to the second placeholder'; eval { $sth->bind_param_array(2, [ 'Plantain', 'Apple' ]); }; is ($@, q{}, $t); # # Test of the "execute_array" statement handle method # $t='Statement method handle "execute_array" works'; $dbh->{RaiseError}=1; my @tuple_status; $rows = $sth->execute_array( { ArrayTupleStatus => \@tuple_status }); is_deeply (\@tuple_status, [1,1,1], $t); $t='Statement method handle "execute_array" returns correct number of rows'; is ($rows, 3, $t); # Test the ArrayTupleFetch attribute $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id, val) VALUES (?,?)'); # Try with 1, 2, and 3 values. All should succeed $sth->bind_param_array(1, [ 20, 21, 22 ], SQL_INTEGER); $sth->bind_param_array(2, 'fruit'); my $counter=0; my @insertvals = ( [33 => 'Peach'], [34 => 'Huckleberry'], [35 => 'Guava'], [36 => 'Lemon'], ); sub getval { return $insertvals[$counter++]; } $t='Statement method handle "execute_array" works with ArrayTupleFetch'; undef @tuple_status; $rows = $sth->execute_array( { ArrayTupleStatus => \@tuple_status, ArrayTupleFetch => \&getval }); is_deeply (\@tuple_status, [1,1,1,1], $t); $t='Statement method handle "execute_array" returns correct number of rows with ArrayTupleFetch'; is ($rows, 4, $t); # # Test of the "execute_for_fetch" statement handle method # $sth = $dbh->prepare('SELECT id+200, val FROM dbd_pg_test'); my $goodrows = $sth->execute(); $sth2 = $dbh->prepare(q{INSERT INTO dbd_pg_test (id, val) VALUES (?,?)}); $sth2->bind_param(1,'',SQL_INTEGER); my $fetch_tuple_sub = sub { $sth->fetchrow_arrayref() }; undef @tuple_status; $rows = $sth2->execute_for_fetch($fetch_tuple_sub, \@tuple_status); $t='Statement handle method "execute_for_fetch" works'; is_deeply (\@tuple_status, [map{1}(1..$goodrows)], $t); $t='Statement handle method "execute_for_fetch" returns correct number of rows'; is ($rows, $goodrows, $t); # # Test of the "fetchrow_arrayref" statement handle method # $t='Statement handle method "fetchrow_arrayref" returns first row correctly'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id = 34'); $sth->execute(); $result = $sth->fetchrow_arrayref(); is_deeply ($result, [34, 'Huckleberry'], $t); $t='Statement handle method "fetchrow_arrayref" returns undef when done'; $result = $sth->fetchrow_arrayref(); is_deeply ($result, undef, $t); # Test of the "fetch" alias $t='Statement handle method alias "fetch" returns first row correctly'; $sth->execute(); $result = $sth->fetch(); $expected = [34, 'Huckleberry']; is_deeply ($result, $expected, $t); $t='Statement handle method alias "fetch" returns undef when done'; $result = $sth->fetch(); is_deeply ($result, undef, $t); # # Test of the "fetchrow_array" statement handle method # $t='Statement handle method "fetchrow_array" returns first row correctly'; $sth->execute(); @results = $sth->fetchrow_array(); is_deeply (\@results, $expected, $t); $t='Statement handle method "fetchrow_array" returns an empty list when done'; @results = $sth->fetchrow_array(); is_deeply (\@results, [], $t); # # Test of the "fetchrow_hashref" statement handle method # $t='Statement handle method "fetchrow_hashref" works with a slice argument'; $sth->execute(); $result = $sth->fetchrow_hashref(); $expected = {id => 34, val => 'Huckleberry'}; is_deeply ($result, $expected, $t); $t='Statement handle method "fetchrow_hashref" returns undef when done'; $result = $sth->fetchrow_hashref(); is_deeply ($result, undef, $t); # # Test of the "fetchall_arrayref" statement handle method # $t='Statement handle method "fetchall_arrayref" returns first row correctly'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (35,36) ORDER BY id ASC'); $sth->execute(); $result = $sth->fetchall_arrayref(); $expected = [[35,'Guava'],[36,'Lemon']]; is_deeply ($result, $expected, $t); # Test of the 'slice' argument $t='Statement handle method "fetchall_arrayref" works with an arrayref slice'; $sth->execute(); $result = $sth->fetchall_arrayref([1]); $expected = [['Guava'],['Lemon']]; is_deeply ($result, $expected, $t); $t='Statement handle method "fetchall_arrayref" works with a hashref slice'; $sth->execute(); $result = $sth->fetchall_arrayref({id => 1}); $expected = [{id => 35},{id => 36}]; is_deeply ($result, $expected, $t); # My personal favorite way of grabbing data $t='Statement handle method "fetchall_arrayref" works with an empty hashref slice'; $sth->execute(); $result = $sth->fetchall_arrayref({}); $expected = [{id => 35, val => 'Guava'},{id => 36, val => 'Lemon'}]; is_deeply ($result, $expected, $t); SKIP: { if ($DBI::VERSION >= 1.603) { skip ('fetchall_arrayref max rows broken in DBI 1.603', 2); } # Test of the 'maxrows' argument $t=q{Statement handle method "fetchall_arrayref" works with a 'maxrows' argument}; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id >= 33 ORDER BY id ASC LIMIT 10'); $sth->execute(); $result = $sth->fetchall_arrayref(undef,2); $expected = [[33,'Peach'],[34,'Huckleberry']]; is_deeply ($result, $expected, $t); $t=q{Statement handle method "fetchall_arrayref" works with an arrayref slice and a 'maxrows' argument}; $result = $sth->fetchall_arrayref([1],2); $expected = [['Guava'],['Lemon']]; $sth->finish(); is_deeply ($result, $expected, $t); } # # Test of the "fetchall_hashref" statement handle method # $t='Statement handle method "fetchall_hashref" gives an error when called with no arguments'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $sth->execute(); eval { $sth->fetchall_hashref(); }; isnt ($@, q{}, $t); $t='Statement handle method "fetchall_hashref" works with a named key field'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $sth->execute(); $result = $sth->fetchall_hashref('id'); $expected = {33=>{id => 33, val => 'Peach'},34=>{id => 34, val => 'Huckleberry'}}; is_deeply ($result, $expected, $t); $t='Statement handle method "fetchall_hashref" returns an empty hash when no rows returned'; $sth->execute(); $result = $sth->fetchall_hashref(1); is_deeply ($result, $expected, q{Statement handle method "fetchall_hashref" works with a numeric key field}); $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id < 1'); $sth->execute(); $result = $sth->fetchall_hashref(1); is_deeply ($result, {}, $t); # # Test of the "rows" statement handle method # $t='Statement handle method "rows" returns -1 before an execute'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $rows = $sth->rows(); is ($rows, -1, $t); $t='Statement handle method "rows" returns correct number of rows'; $sth->execute(); $rows = $sth->rows(); $sth->finish(); is ($rows, 2, $t); # # Test of the "bind_col" statement handle method # $t='Statement handle method "bind_col" returns the correct value'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $sth->execute(); my $bindme; $result = $sth->bind_col(2, \$bindme); is ($result, 1, $t); $t='Statement handle method "bind_col" correctly binds parameters'; $sth->fetch(); is ($bindme, 'Peach', $t); $dbh->do(q{UPDATE dbd_pg_test SET testarray = '{2,3,55}' WHERE id = 33}); $t='Statement handle method "bind_col" returns the correct value'; my $bindarray; $sth = $dbh->prepare('SELECT id, testarray FROM dbd_pg_test WHERE id = 33'); $sth->execute(); $result = $sth->bind_col(1, \$bindme); is ($result, 1, $t); $t='Statement handle method "bind_col" returns the correct value'; $result = $sth->bind_col(2, \$bindarray); is ($result, 1, $t); $t='Statement handle method "bind_col" correctly binds parameters'; $sth->fetch(); is ($bindme, '33', $t); $t='Statement handle method "bind_col" correctly binds arrayref'; is_deeply ($bindarray, [2,3,55], $t); # # Test of the "bind_columns" statement handle method # $t='Statement handle method "bind_columns" fails when called with wrong number of arguments'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34) ORDER BY id'); $sth->execute(); my $bindme2; eval { $sth->bind_columns(1); }; isnt ($@, q{}, $t); $t='Statement handle method "bind_columns" returns the correct value'; $result = $sth->bind_columns(\$bindme, \$bindme2); is ($result, 1, $t); $t='Statement handle method "bind_columns" correctly binds parameters'; $sth->fetch(); $expected = [33, 'Peach']; my $got = [$bindme, $bindme2]; $sth->finish(); is_deeply ($got, $expected, $t); # # Test of the statement handle method "state" # $t='Statement handle method "state" returns an empty string on success'; $result = $sth->state(); is ($result, q{}, $t); $t='Statement handle method "state" returns a five-character code on error'; eval { $sth = $dbh->prepare('SELECT dbdpg_throws_an_error'); $sth->execute(); }; $result = $sth->state(); like ($result, qr/^[A-Z0-9]{5}$/, $t); $t='Statement and database handle method "state" return same code'; my $result2 = $dbh->state(); is ($result, $result2, $t); $t='Statement handle method "state" returns expected code'; is ($result, '42703', $t); # # Test of the statement handle method "private_attribute_info" # SKIP: { if ($DBI::VERSION < 1.54) { skip ('DBI must be at least version 1.54 to test $sth->private_attribute_info', 2); } $t='Statement handle method "private_attribute_info" returns at least one record'; $sth = $dbh->prepare('SELECT 123'); my $private = $sth->private_attribute_info(); my ($valid,$invalid) = (0,0); for my $name (keys %$private) { $name =~ /^pg_\w+/ ? $valid++ : $invalid++; } cmp_ok ($valid, '>=', 1, $t); $t='Statement handle method "private_attribute_info" returns only internal names'; $sth->finish(); is ($invalid, 0, $t); } # # Test of the statement handle method "pg_numbound" # $dbh->rollback(); $t=q{Statement handle attribute pg_numbound returns 0 if no placeholders}; $sth = $dbh->prepare('SELECT 123'); is ($sth->{pg_numbound}, 0, $t); $sth->execute(); is ($sth->{pg_numbound}, 0, $t); $t=q{Statement handle attribute pg_numbound returns 0 if no placeholders bound yet}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); is ($sth->{pg_numbound}, 0, $t); $t=q{Statement handle attribute pg_numbound returns 1 if one placeholder bound}; $sth->bind_param(1, 123); is ($sth->{pg_numbound}, 1, $t); $t=q{Statement handle attribute pg_numbound returns 2 if two placeholders bound}; $sth->bind_param(2, 345); is ($sth->{pg_numbound}, 2, $t); $t=q{Statement handle attribute pg_numbound returns 1 if one placeholders bound as NULL}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); $sth->bind_param(1, undef); is ($sth->{pg_numbound}, 1, $t); # # Test of the statement handle method "pg_async" # $t=q{Statement handle attribute pg_async returns 0 if not set yet}; $sth = $dbh->prepare('SELECT 123'); is ($sth->{pg_async}, 0, $t); $t=q{Statement handle attribute pg_async returns 0 if not set yet (post-execute)}; $sth->execute(); is ($sth->{pg_async}, 0, $t); $t=q{Statement handle attribute pg_async returns correct value when set true}; $sth = $dbh->prepare('SELECT 123', { pg_async => PG_ASYNC }); is ($sth->{pg_async}, 1, $t); $t=q{Statement handle attribute pg_async returns correct value when set false}; $sth = $dbh->prepare('SELECT 123', { pg_async => 0 }); is ($sth->{pg_async}, 0, $t); # # Test of the statement handle method "pg_bound" # $t=q{Statement handle attribute pg_bound returns an empty hash if no placeholders}; $sth = $dbh->prepare('SELECT 123'); is_deeply ($sth->{pg_bound}, {}, $t); $sth->execute(); is_deeply ($sth->{pg_bound}, {}, $t); $t=q{Statement handle attribute pg_bound returns correct value if no placeholders bound yet}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); is_deeply ($sth->{pg_bound}, {1=>0, 2=>0}, $t); $t=q{Statement handle attribute pg_bound returns correct value if one placeholder bound}; $sth->bind_param(2, 123); is_deeply ($sth->{pg_bound}, {1=>0, 2=>1}, $t); $t=q{Statement handle attribute pg_bound returns correct value if two placeholders bound}; $sth->bind_param(1, 123); is_deeply ($sth->{pg_bound}, {1=>1, 2=>1}, $t); # # Test of the statement handle method "pg_numbound" # $t=q{Statement handle attribute pg_numbound returns 1 if one placeholders bound as NULL}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); $sth->bind_param(1, undef); is_deeply ($sth->{pg_bound}, {1=>1, 2=>0}, $t); # # Test of the statement handle method "pg_current_row" # $t=q{Statement handle attribute pg_current_row returns zero until first row fetched}; $sth = $dbh->prepare('SELECT 1 FROM pg_class LIMIT 5'); is ($sth->{pg_current_row}, 0, $t); $t=q{Statement handle attribute pg_current_row returns zero until first row fetched}; $sth->execute(); is ($sth->{pg_current_row}, 0, $t); $t=q{Statement handle attribute pg_current_row returns 1 after a fetch}; $sth->fetch(); is ($sth->{pg_current_row}, 1, $t); $t=q{Statement handle attribute pg_current_row returns correct value while fetching}; my $x = 2; while (defined $sth->fetch()) { is ($sth->{pg_current_row}, $x++, $t); } $t=q{Statement handle attribute pg_current_row returns 0 when done fetching}; is ($sth->{pg_current_row}, 0, $t); $t=q{Statement handle attribute pg_current_row returns 0 after fetchall_arrayref}; $sth->execute(); $sth->fetchall_arrayref(); is ($sth->{pg_current_row}, 0, $t); # # Test of the statement handle method "cancel" # SKIP: { if ($^O =~ /Win/) { skip ('Cannot test POSIX signaling on Windows', 1); } $dbh->do('INSERT INTO dbd_pg_test (id) VALUES (?)',undef,1); $dbh->commit; $dbh->do('SELECT * FROM dbd_pg_test WHERE id = ? FOR UPDATE',undef,1); my $dbh2 = $dbh->clone; $dbh2->do('SET search_path TO ' . $dbh->selectrow_array('SHOW search_path')); my $oldaction; eval { # This statement will block indefinitely because of the 'FOR UPDATE' clause, # so we set up an alarm to cancel it after 2 seconds. my $sthl = $dbh2->prepare('SELECT * FROM dbd_pg_test WHERE id = ? FOR UPDATE'); $sthl->{RaiseError} = 1; my $action = POSIX::SigAction->new( sub {$sthl->cancel},POSIX::SigSet->new(SIGALRM)); $oldaction = POSIX::SigAction->new; POSIX::sigaction(SIGALRM,$action,$oldaction); alarm(2); # seconds before alarm $sthl->execute(1); alarm(0); # cancel alarm (if execute didn't block) }; # restore original signal handler POSIX::sigaction(SIGALRM,$oldaction); like ($@, qr/execute failed/, 'cancel'); $dbh2->disconnect(); } # # Test of the statement handle methods "pg_canonical_names" # $t=q{Statement handle method "pg_canonical_names" returns expected values}; $sth = $dbh->prepare('SELECT id, id AS not_id, id + 1 AS not_a_simple FROM dbd_pg_test LIMIT 1'); $sth->execute; is_deeply ($sth->pg_canonical_names, [ 'dbd_pg_testschema.dbd_pg_test.id', 'dbd_pg_testschema.dbd_pg_test.id', undef ], $t); $t=q{2Statement handle method "pg_canonical_names" returns expected values}; $sth = $dbh->prepare('SELECT id, id AS not_id, id + 1 AS not_a_simple FROM dbd_pg_test LIMIT 1'); $sth->execute; is_deeply ($sth->pg_canonical_names, [ 'dbd_pg_testschema.dbd_pg_test.id', 'dbd_pg_testschema.dbd_pg_test.id', undef ], $t); $t=q{3Statement handle method "pg_canonical_names" returns expected values}; $sth = $dbh->prepare('SELECT id, id AS not_id, id + 1 AS not_a_simple FROM dbd_pg_test LIMIT 1'); $sth->execute; is_deeply ($sth->pg_canonical_names, [ 'dbd_pg_testschema.dbd_pg_test.id', 'dbd_pg_testschema.dbd_pg_test.id', undef ], $t); # # Test of the statement handle method "pg_canonical_ids" # $t=q{Statement handle method "pg_canonical_ids" returns correct length}; my $data = $sth->pg_canonical_ids; is ($#$data, 2, $t); $t=q{Statement handle method pg_canonical_ids has undef as the last element in returned array}; is ($data->[2], undef, $t); $t=q{Statement handle method "pg_canonical_ids" returns identical first and second elements}; $t=q{first and second array elements must be the same}; is_deeply ($data->[0], $data->[1], $t); $sth->finish; # # Test for regression reported in GitHub issue #72: # Perl length() returns the wrong value on array elements returned by fetchrow_arrayref() # { $t = q{Statement handle fetched strings give correct length()}; my @strings = qw( abcdefghij abcd abcdefg abcdefghijklmno a abcdefghijklmnopqrstuvwxyz ); $SQL = join(q{ UNION ALL }, ('SELECT ?::text,?::text') x @strings) . q{ ORDER BY 1}; $sth = $dbh->prepare($SQL); my $i = 0; $sth->execute(map { $i++, $_ } @strings); while (my $row = $sth->fetchrow_arrayref) { is(length($row->[1]), length(shift(@strings)), 'Perl length() of returned string'); } $sth->finish; } # # Test of the statement handle method "last_insert_id" # SKIP: { if ($DBI::VERSION < 1.642) { skip ('DBI must be at least version 1.642 to test $sth->last_insert_id', 12); } $t='Statement handle method "last_insert_id" fails when no arguments are given'; $dbh->rollback(); $sth = $dbh->prepare('SELECT 1'); eval { $sth->last_insert_id(undef,undef,undef,undef); }; like ($@, qr{last_insert_id.*least}, $t); $t='Statement handle method "last_insert_id" fails when given a non-existent sequence'; eval { $sth->last_insert_id(undef,undef,undef,undef,{sequence=>'dbd_pg_nonexistentsequence_test'}); }; is ($dbh->state, '42P01', $t); $t='Statement handle method "last_insert_id" fails when given a non-existent table'; $dbh->rollback(); $sth = $dbh->prepare('SELECT 1'); eval { $sth->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef); }; like ($@, qr{not find}, $t); $t='Statement handle method "last_insert_id" fails when given an arrayref as last argument'; $dbh->rollback(); $sth = $dbh->prepare('SELECT 1'); eval { $sth->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef,[]); }; like ($@, qr{last_insert_id.*hashref}, $t); $t='Statement handle method "last_insert_id" works when given an empty sequence argument'; $dbh->rollback(); $sth = $dbh->prepare('SELECT 1'); eval { $sth->last_insert_id(undef,undef,'dbd_pg_test',undef,{sequence=>''}); }; is ($@, q{}, $t); $t='Statement handle method "last_insert_id" fails when given a table with no primary key'; $dbh->rollback(); $sth = $dbh->prepare('CREATE TEMP TABLE dbd_pg_test_temp(a int)'); $sth->execute(); eval { $sth->last_insert_id(undef,undef,'dbd_pg_test_temp',undef); }; like ($@, qr{last_insert_id}, $t); my $parent = 'dbd_pg_test_parent'; my $kid = 'dbd_pg_test_inherit'; $dbh->do(q{SET client_min_messages = 'ERROR'}); $dbh->do("CREATE TABLE $schema.$parent(id SERIAL primary key)"); $dbh->do("CREATE TABLE $schema.$kid (foo text) INHERITS ($parent)"); $sth = $dbh->prepare("INSERT INTO $parent DEFAULT VALUES"); $sth->execute(); $t='Statement handle method "last_insert_id" works for a normal table'; $result = ''; eval { $result = $sth->last_insert_id(undef,undef,$parent,undef); }; is ($@, q{}, $t); $t='Statement handle method "last_insert_id" returns correct value for a normal table'; is ($result, 1, $t); $sth = $dbh->prepare("INSERT INTO $kid DEFAULT VALUES"); $sth->execute(); $t='Statement handle method "last_insert_id" works for an inherited table'; $result = ''; eval { $result = $sth->last_insert_id(undef,undef,$kid,undef); }; is ($@, q{}, $t); $t='Statement handle method "last_insert_id" returns correct value for an inherited table'; is ($result, 2, $t); my $doublename1 = q{dbdpg_test_table""full-o'quotes}; my $doublename2 = q{dbdpg_test_table"full-o'quotes}; $dbh->do("CREATE TABLE $schema.\"$doublename1\" (id SERIAL primary key)"); $sth = $dbh->prepare("INSERT INTO \"$doublename1\" DEFAULT VALUES"); $sth->execute(); $t='Statement handle method "last_insert_id" works for table name containing double quotes'; $result = ''; eval { $result = $sth->last_insert_id(undef,undef,$doublename2,undef); }; is ($@, q{}, $t); $t='Statement handle method "last_insert_id" returns correct value for table name containing double quotes'; is ($result, 1, $t); } cleanup_database($dbh,'test'); $dbh->rollback(); $dbh->disconnect(); DBD-Pg-3.20.2/t/04misc.t0000644000175000017500000004553715166170753012745 0ustar greggreg#!perl ## Various stuff that does not go elsewhere use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Test::More; use Data::Dumper; use DBI; use DBD::Pg qw/:pg_types :pg_limits/; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 105; my $superuser = is_super(); isnt ($dbh, undef, 'Connect to database for miscellaneous tests'); my $t = q{Method 'server_trace_flag' is available without a database handle}; my $num; eval { $num = DBD::Pg->parse_trace_flag('NONE'); }; is ($@, q{}, $t); $t = q{Driver handle is obtainable directly from DBD::Pg}; my $drh = DBD::Pg->driver; is (ref $drh, 'DBI::dr', $t); $t = q{Method 'private_attribute_info' is available without a database handle and returns an empty hashref}; my $result = $drh->private_attribute_info(); is_deeply ($result, {}, $t); $t = q{Internal method 'CLONE' returns undef}; $result = DBD::Pg->CLONE(); is ($result, undef, $t); $t = 'Constant PG_MIN_SMALLINT returns expected value of -32768'; my $sth = $dbh->prepare('SELECT ?::smallint'); $sth->execute(PG_MIN_SMALLINT); is ( $sth->fetch->[0], -32768, $t); $t = 'Trying to fit one less than PG_MIN_SMALLINT into a smallint returns expected error'; eval { $sth->execute(PG_MIN_SMALLINT-1) }; is ( $dbh->state, '22003', $t); $dbh->rollback(); $t = 'Constant PG_MAX_SMALLINT returns expected value of 32767'; $sth->execute(PG_MAX_SMALLINT); is ( $sth->fetch->[0], 32767, $t); $t = 'Trying to fit one more than PG_MAX_SMALLINT into a smallint returns expected error'; eval { $sth->execute(PG_MAX_SMALLINT+1) }; is ( $dbh->state, '22003', $t); $dbh->rollback(); $t = 'Constant PG_MIN_INTEGER returns expected value of -2147483648'; $sth = $dbh->prepare('SELECT ?::integer'); $sth->execute(PG_MIN_INTEGER); is ( $sth->fetch->[0], -2147483648, $t); $t = 'Trying to fit one less than PG_MIN_INTEGER into an int returns expected error'; eval { $sth->execute(PG_MIN_INTEGER-1) }; is ( $dbh->state, '22003', $t); $dbh->rollback(); $t = 'Constant PG_MAX_INTEGER returns expected value of 2147483647'; $sth->execute(PG_MAX_INTEGER); is ( $sth->fetch->[0], 2147483647, $t); $t = 'Trying to fit one more than PG_MAX_INTEGER into an int returns expected error'; eval { $sth->execute(PG_MAX_INTEGER+1) }; is ( $dbh->state, '22003', $t); $dbh->rollback(); $t = 'Constant PG_MIN_BIGINT returns expected value of -9223372036854775808'; $sth = $dbh->prepare('SELECT ?::bigint'); $sth->execute(PG_MIN_BIGINT); is ( $sth->fetch->[0], '-9223372036854775808', $t); $t = 'Trying to fit one less than PG_MIN_BIGINT into a bigint returns expected error'; ## Unlike the others, we cannot modify Perl side in case of a 32-bit system $sth = $dbh->prepare('SELECT ?::bigint-1'); eval { $sth->execute(PG_MIN_BIGINT) }; is ( $dbh->state, '22003', $t); $dbh->rollback(); $t = 'Constant PG_MAX_BIGINT returns expected value of 9223372036854775807'; $sth = $dbh->prepare('SELECT ?::bigint'); $sth->execute(PG_MAX_BIGINT); is ( $sth->fetch->[0], '9223372036854775807', $t); $t = 'Trying to fit one more than PG_MAX_BIGINT into a bigint returns expected error'; $sth = $dbh->prepare('SELECT ?::bigint+1'); eval { $sth->execute(PG_MAX_BIGINT) }; is ( $dbh->state, '22003', $t); $dbh->rollback(); $t = 'Constant PG_MIN_SMALLSERIAL is set to 1'; is (PG_MIN_SMALLSERIAL, 1, $t); $t = 'Constant PG_MAX_SMALLSERIAL returns expected value of 32767 (same as PG_MAX_SMALLINT)'; $sth = $dbh->prepare('SELECT ?::bigint'); $sth->execute(PG_MAX_SMALLSERIAL); is ( $sth->fetch->[0], 32767, $t); $t = 'Constant PG_MIN_SERIAL is set to 1'; is (PG_MIN_SERIAL, 1, $t); $t = 'Constant PG_MAX_SERIAL returns expected value of 2147483647 (same as PG_MAX_INTEGER)'; $sth->execute(PG_MAX_SERIAL); is ( $sth->fetch->[0], 2147483647, $t); $t = 'Constant PG_MIN_BIGSERIAL is set to 1'; is (PG_MIN_BIGSERIAL, 1, $t); $t = 'Constant PG_MAX_BIGSERIAL returns expected value of 9223372036854775807 (same as PG_MAX_BIGINT)'; $sth->execute(PG_MAX_BIGSERIAL); is ( $sth->fetch->[0], '9223372036854775807', $t); $t='Method "server_trace_flag" returns undef on bogus argument'; is ($num, undef, $t); $t=q{Method "server_trace_flag" returns 0x00000100 for DBI value 'SQL'}; $num = DBD::Pg->parse_trace_flag('SQL'); is ($num, 0x00000100, $t); $t=q{Method "server_trace_flag" returns 0x01000000 for DBD::Pg flag 'pglibpq'}; $num = DBD::Pg->parse_trace_flag('pglibpq'); is ($num, 0x01000000, $t); $t=q{Database handle method "server_trace_flag" returns undef on bogus argument}; $num = $dbh->parse_trace_flag('NONE'); is ($num, undef, $t); $t=q{Database handle method "server_trace_flag" returns 0x00000100 for DBI value 'SQL'}; $num = $dbh->parse_trace_flag('SQL'); is ($num, 0x00000100, $t); $t=q{Database handle method 'server_trace_flags' returns 0x01000100 for 'SQL|pglibpq'}; $num = $dbh->parse_trace_flags('SQL|pglibpq'); is ($num, 0x01000100, $t); $t=q{Database handle method 'server_trace_flags' returns 0x03000100 for 'SQL|pglibpq|pgstart'}; $num = $dbh->parse_trace_flags('SQL|pglibpq|pgstart'); is ($num, 0x03000100, $t); $t = q{Method 'server_trace_flags' is available without a database handle}; $num = DBD::Pg->parse_trace_flags('SQL|pglibpq|pgstart'); is ($num, 0x03000100, $t); my $flagexp = 24; $sth = $dbh->prepare('SELECT 1'); for my $flag (qw/pglibpq pgstart pgend pgprefix pglogin pgquote/) { my $hex = 2**$flagexp++; $t = qq{Database handle method "server_trace_flag" returns $hex for flag $flag}; $num = $dbh->parse_trace_flag($flag); is ($num, $hex, $t); $t = qq{Database handle method 'server_trace_flags' returns $hex for flag $flag}; $num = $dbh->parse_trace_flags($flag); is ($num, $hex, $t); $t = qq{Statement handle method "server_trace_flag" returns $hex for flag $flag}; $num = $sth->parse_trace_flag($flag); is ($num, $hex, $t); $t = qq{Statement handle method 'server_trace_flags' returns $hex for flag $flag}; $num = $sth->parse_trace_flag($flag); is ($num, $hex, $t); } $t = q{Database handle method "server_trace_flag" returns all-but-pgprefix for flag 'DBD'}; $num = $dbh->parse_trace_flag('DBD'); is ($num, 0x7FFFFF00 - 0x08000000, $t); SKIP: { my $SQL = q{ CREATE OR REPLACE FUNCTION dbdpg_test_error_handler(TEXT) RETURNS boolean LANGUAGE plpgsql AS $BC$ DECLARE level ALIAS FOR $1; BEGIN IF level ~* 'notice' THEN RAISE NOTICE 'RAISE NOTICE FROM dbdpg_test_error_handler'; ELSIF level ~* 'warning' THEN RAISE WARNING 'RAISE WARNING FROM dbdpg_test_error_handler'; ELSIF level ~* 'exception' THEN RAISE EXCEPTION 'RAISE EXCEPTION FROM dbdpg_test_error_handler'; END IF; RETURN TRUE; END; $BC$ }; eval { $dbh->do($SQL); $dbh->commit(); }; if ($@) { $dbh->rollback(); $@ and skip ('Cannot load function for testing', 6); } $sth = $dbh->prepare('SELECT * FROM dbdpg_test_error_handler( ? )'); is( $sth->err, undef, q{Statement attribute 'err' is initially undef}); $dbh->do(q{SET client_min_messages = 'ERROR'}); TODO: { local $TODO = q{Known bug: notice and warnings should set err to 6}; for my $level (qw/notice warning/) { $sth->execute($level); is( $sth->err, 6, qq{Statement attribute 'err' set to 6 for level $level}); } } for my $level (qw/exception/) { eval { $sth->execute($level);}; is( $sth->err, 7, qq{Statement attribute 'err' set to 7 for level $level}); $dbh->rollback; } for my $level (qw/normal/) { $sth->execute($level); is( $sth->err, undef, q{Statement attribute 'err' set to undef when no notices raised}); } $sth->finish; is( $sth->err, undef, q{Statement attribute 'err' set to undef after statement finishes}); $dbh->do('DROP FUNCTION dbdpg_test_error_handler(TEXT)') or die $dbh->errstr; $dbh->do('SET client_min_messages = NOTICE'); $dbh->commit(); } ## Some funkier connection attempts SKIP: { eval { require Test::Output; }; skip ('Test::Output is needed for some connection tests', 2) if $@; $t=q{Connect with 'dbd_verbose' attrib sets debug output on}; my ($testdsn,$testuser,$helpconnect,$su,$uid,$testdir,$pg_ctl,$initdb,$error,$version) = get_test_settings(); $testdsn =~ s/^dbi/DBI/i; my $ldbh; Test::Output::stderr_like( sub { $ldbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, dbd_verbose => 1}); $ldbh->do('select 1'); }, qr/dbd_db_STORE/, $t); ## DBI is way too sticky with tracing stuff, so we need to turn it off here $ldbh->trace(0); $t=q{Connect with no attributes at all works}; $ldbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}); ok (ref $ldbh, $t); } SKIP: { eval { require File::Temp; }; $@ and skip ('Must have File::Temp to complete trace flag testing', 9); my ($fh,$filename) = File::Temp::tempfile('dbdpg_test_XXXXXX', SUFFIX => '.tst', UNLINK => 1); my ($flag, $info, $expected, $SQL); $t=q{Trace flag 'SQL' works as expected}; $flag = $dbh->parse_trace_flags('SQL'); $dbh->trace($flag, $filename); $SQL = q{SELECT 'dbdpg_flag_testing'}; $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = qq{begin;\n\n$SQL;\n\ncommit;\n\n}; is ($info, $expected, $t); $t=q{Trace flag 'pglibpq' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flag('pglibpq'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{PQclear PQexec PQresultStatus PQresultErrorField PQclear PQexec PQresultStatus PQresultErrorField PQntuples PQtransactionStatus PQtransactionStatus PQclear PQexec PQresultStatus PQresultErrorField }; is ($info, $expected, $t); $t=q{Trace flag 'pgstart' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pgstart'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Begin pg_quickexec (query: SELECT 'dbdpg_flag_testing' async: 0 async_status: 0) Begin _result (sql: begin) Begin _sqlstate Begin _sqlstate Begin dbd_db_commit Begin pg_db_rollback_commit (action: commit AutoCommit: 0 BegunWork: 0) Begin PGTransactionStatusType Begin _result (sql: commit) Begin _sqlstate }; is ($info, $expected, $t); $t=q{Trace flag 'pgprefix' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pgstart|pgprefix'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{dbdpg: Begin pg_quickexec (query: SELECT 'dbdpg_flag_testing' async: 0 async_status: 0) dbdpg: Begin _result (sql: begin) dbdpg: Begin _sqlstate dbdpg: Begin _sqlstate dbdpg: Begin dbd_db_commit dbdpg: Begin pg_db_rollback_commit (action: commit AutoCommit: 0 BegunWork: 0) dbdpg: Begin PGTransactionStatusType dbdpg: Begin _result (sql: commit) dbdpg: Begin _sqlstate }; is ($info, $expected, $t); $t=q{Trace flag 'pgend' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pgend'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{End _sqlstate (status: 1) End _result End _sqlstate (status: 2) End pg_quickexec (rows: 1, txn_status: 2) End _sqlstate (status: 1) End _result End pg_db_rollback_commit (result: 1) }; is ($info, $expected, $t); $t=q{Trace flag 'pglogin' returns undef if no activity}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pglogin'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; $info = <$fh>; } $expected = undef; is ($info, $expected, $t); $t=q{Trace flag 'pglogin' works as expected with DBD::Pg->parse_trace_flag()}; $dbh->disconnect(); my $flagval = DBD::Pg->parse_trace_flag('pglogin'); seek $fh, 0, 0; truncate $fh, tell($fh); DBI->trace($flagval, $filename); $dbh = connect_database({nosetup => 1}); $dbh->do($SQL); $dbh->disconnect(); $dbh = connect_database({nosetup => 1}); $dbh->disconnect(); DBI->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Login connection string: Connection complete Disconnection complete }; $info =~ s/(Login connection string: ).+/$1/g; is ($info, "$expected$expected", $t); $t=q{Trace flag 'pglogin' works as expected with DBD::Pg->parse_trace_flag()}; seek $fh, 0, 0; truncate $fh, tell($fh); DBI->trace($flagval, $filename); $dbh = connect_database({nosetup => 1}); $dbh->disconnect(); DBI->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Login connection string: Connection complete Disconnection complete }; $info =~ s/(Login connection string: ).+/$1/g; is ($info, "$expected", $t); $t=q{Trace flag 'pgprefix' and 'pgstart' appended to 'pglogin' work as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); DBI->trace($flagval, $filename); $dbh = connect_database({nosetup => 1}); $dbh->do($SQL); $flagval += $dbh->parse_trace_flags('pgprefix|pgstart'); $dbh->trace($flagval); $dbh->do($SQL); $dbh->trace(0); $dbh->rollback(); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Login connection string: Connection complete dbdpg: Begin pg_quickexec (query: SELECT 'dbdpg_flag_testing' async: 0 async_status: 0) dbdpg: Begin _sqlstate }; $info =~ s/(Login connection string: ).+/$1/g; is ($info, "$expected", $t); } ## end trace flag testing using File::Temp # # Test of the "data_sources" method # $t='The "data_sources" method returns an entry for template0 when called via $dbh'; my @sources = $dbh->data_sources('Pg'); my $expected = qr{\bdbi:Pg:dbname=template0\b}; like ((join ' ' => @sources), $expected, $t); $t='The "data_sources" method returns an entry for template0 when called via DBI'; @sources = DBI->data_sources('Pg'); like ((join ' ' => @sources), $expected, $t); $t='The "data_sources" method returns an error when called with no arg via DBI'; eval { @sources = DBI->data_sources(); }; like ($@, qr/usage:/, $t); $t='The "data_sources" method returns an entry for template0 when called with no arg via $dbh'; eval { @sources = $dbh->data_sources(); }; like ((join ' ' => @sources), $expected, $t); $t='The "data_sources" method returns correct DSN when second arg is a port'; my $port = 12345; @sources = DBI->data_sources('Pg',"port=$port"); like ((join ' ' => @sources), qr{dbi:Pg:dbname=template0;port=$port}, $t); $t='The "data_sources" method returns correct DSN when second arg is a port and a leading semicolon'; @sources = DBI->data_sources('Pg',";port=$port"); like ((join ' ' => @sources), qr{dbi:Pg:dbname=template0;port=$port}, $t); SKIP: { $t='The "data_sources" method handles database names with spaces'; my $test_db_name = 'dbdpg space test'; if (! grep { /\b$test_db_name\b/ } @sources) { eval { $dbh->{AutoCommit} = 1; $dbh->do(qq{CREATE DATABASE "$test_db_name" TEMPLATE template0}); }; if ($@) { skip (qq{Could not create database "$test_db_name": $@}, 1); } } @sources = DBI->data_sources('Pg',"port=$port"); like ((join ' ' => @sources), qr{dbi:Pg:dbname="$test_db_name";port=$port}, $t); eval { $dbh->{AutoCommit} = 1; $dbh->do(qq{DROP DATABASE "$test_db_name"}); }; $@ and diag "Unable to drop database $test_db_name: $@"; } # # Test the use of $DBDPG_DEFAULT # ## Do NOT use the variable at all before the call - even in a string (test for RT #112309) $t=q{Using $DBDPG_DEFAULT works}; $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id, pname) VALUES (?,?)}); eval { $sth->execute(600,$DBDPG_DEFAULT); }; is ($@, q{}, $t); $sth->execute(602,123); # # Test transaction status changes # $t='Raw ROLLBACK via do() resets the transaction status correctly'; $dbh->{AutoCommit} = 1; $dbh->begin_work(); $dbh->do('SELECT 123'); eval { $dbh->do('ROLLBACK'); }; is ($@, q{}, $t); eval { $dbh->begin_work(); }; is ($@, q{}, $t); $t='Using dbh->commit() resets the transaction status correctly'; eval { $dbh->commit(); }; is ($@, q{}, $t); eval { $dbh->begin_work(); }; is ($@, q{}, $t); $t='Raw COMMIT via do() resets the transaction status correctly'; eval { $dbh->do('COMMIT'); }; is ($@, q{}, $t); eval { $dbh->begin_work(); }; is ($@, q{}, $t); $t='Calling COMMIT via prepare/execute resets the transaction status correctly'; $sth = $dbh->prepare('COMMIT'); $sth->execute(); eval { $dbh->begin_work(); }; is ($@, q{}, $t); ## Check for problems in pg_st_split_statement by having it parse long strings my $problem; for my $length (0..16384) { my $sql = sprintf 'SELECT %*d', $length + 3, $length; my $cur_len = $dbh->selectrow_array($sql); next if $cur_len == $length; $problem = "length $length gave us a select of $cur_len"; last; } if (defined $problem) { fail ("pg_st_split_statment failed: $problem"); } else { pass ('pg_st_split_statement gave no problems with various lengths'); } my $newdepth = $^O =~ /win/i ? 3000 : 7600; $superuser and $dbh->do("set max_stack_depth = $newdepth"); ## Check for problems with insane number of placeholders for my $ph (1..13) { my $total = 2**$ph; $t = "prepare/execute works with $total placeholders"; my $sql = 'SELECT count(*) FROM pg_class WHERE relpages IN (' . ('?,' x $total); $sql =~ s/.$/\)/; $sth = $dbh->prepare($sql); my @arr = (1..$total); my $count = $sth->execute(@arr); is $count, 1, $t; $sth->finish(); } ## Make sure our mapping of char/SQL_CHAR/bpchar is working as expected $dbh->do('CREATE TEMP TABLE tt (c_test int, char4 char(4))'); $sth = $dbh->prepare ('SELECT * FROM tt'); $sth->execute; my @stt = @{$sth->{TYPE}}; $sth = $dbh->prepare('INSERT INTO tt VALUES (?,?)'); $sth->bind_param(1, undef, $stt[0]); ## 4 $sth->bind_param(2, undef, $stt[1]); ## 1 aka SQL_CHAR $sth->execute(2, '0301'); my $SQL = 'SELECT char4 FROM tt'; $result = $dbh->selectall_arrayref($SQL)->[0][0]; $t = q{Using bind_param with type 1 yields a correct bpchar value}; is( $result, '0301', $t); $dbh->{AutoCommit} = 1; $t = q{Cloned database handle inherits the changed AutoCommit value}; my $clone = $dbh->clone(); is ($clone->{AutoCommit}, 1, $t); $t = q{Cloned database handle is separate from its parent}; $dbh->{AutoCommit} = 0; is ($clone->{AutoCommit}, 1, $t); cleanup_database($dbh,'test'); $dbh->disconnect(); DBD-Pg-3.20.2/t/01constants.t0000644000175000017500000004304315166170753014011 0ustar greggreg#!perl use 5.008001; use strict; ## We cannot 'use warnings' here as PG_TSQUERY and others trip it up ## no critic (RequireUseWarnings) use lib 'blib/lib', 'blib/arch', 't'; use Test::More; select(($|=1,select(STDERR),$|=1)[1]); use DBD::Pg qw(:pg_types :async); ## Should match the list in Pg.xs ## This is auto-generated by types.c, so do not edit manually please is (PG_ACLITEM , 1033, 'PG_ACLITEM returns correct value'); is (PG_ACLITEMARRAY , 1034, 'PG_ACLITEMARRAY returns correct value'); is (PG_ANY , 2276, 'PG_ANY returns correct value'); is (PG_ANYARRAY , 2277, 'PG_ANYARRAY returns correct value'); is (PG_ANYCOMPATIBLE , 5077, 'PG_ANYCOMPATIBLE returns correct value'); is (PG_ANYCOMPATIBLEARRAY , 5078, 'PG_ANYCOMPATIBLEARRAY returns correct value'); is (PG_ANYCOMPATIBLEMULTIRANGE , 4538, 'PG_ANYCOMPATIBLEMULTIRANGE returns correct value'); is (PG_ANYCOMPATIBLENONARRAY , 5079, 'PG_ANYCOMPATIBLENONARRAY returns correct value'); is (PG_ANYCOMPATIBLERANGE , 5080, 'PG_ANYCOMPATIBLERANGE returns correct value'); is (PG_ANYELEMENT , 2283, 'PG_ANYELEMENT returns correct value'); is (PG_ANYENUM , 3500, 'PG_ANYENUM returns correct value'); is (PG_ANYMULTIRANGE , 4537, 'PG_ANYMULTIRANGE returns correct value'); is (PG_ANYNONARRAY , 2776, 'PG_ANYNONARRAY returns correct value'); is (PG_ANYRANGE , 3831, 'PG_ANYRANGE returns correct value'); is (PG_BIT , 1560, 'PG_BIT returns correct value'); is (PG_BITARRAY , 1561, 'PG_BITARRAY returns correct value'); is (PG_BOOL , 16, 'PG_BOOL returns correct value'); is (PG_BOOLARRAY , 1000, 'PG_BOOLARRAY returns correct value'); is (PG_BOX , 603, 'PG_BOX returns correct value'); is (PG_BOXARRAY , 1020, 'PG_BOXARRAY returns correct value'); is (PG_BPCHAR , 1042, 'PG_BPCHAR returns correct value'); is (PG_BPCHARARRAY , 1014, 'PG_BPCHARARRAY returns correct value'); is (PG_BYTEA , 17, 'PG_BYTEA returns correct value'); is (PG_BYTEAARRAY , 1001, 'PG_BYTEAARRAY returns correct value'); is (PG_CHAR , 18, 'PG_CHAR returns correct value'); is (PG_CHARARRAY , 1002, 'PG_CHARARRAY returns correct value'); is (PG_CID , 29, 'PG_CID returns correct value'); is (PG_CIDARRAY , 1012, 'PG_CIDARRAY returns correct value'); is (PG_CIDR , 650, 'PG_CIDR returns correct value'); is (PG_CIDRARRAY , 651, 'PG_CIDRARRAY returns correct value'); is (PG_CIRCLE , 718, 'PG_CIRCLE returns correct value'); is (PG_CIRCLEARRAY , 719, 'PG_CIRCLEARRAY returns correct value'); is (PG_CSTRING , 2275, 'PG_CSTRING returns correct value'); is (PG_CSTRINGARRAY , 1263, 'PG_CSTRINGARRAY returns correct value'); is (PG_DATE , 1082, 'PG_DATE returns correct value'); is (PG_DATEARRAY , 1182, 'PG_DATEARRAY returns correct value'); is (PG_DATEMULTIRANGE , 4535, 'PG_DATEMULTIRANGE returns correct value'); is (PG_DATEMULTIRANGEARRAY , 6155, 'PG_DATEMULTIRANGEARRAY returns correct value'); is (PG_DATERANGE , 3912, 'PG_DATERANGE returns correct value'); is (PG_DATERANGEARRAY , 3913, 'PG_DATERANGEARRAY returns correct value'); is (PG_EVENT_TRIGGER , 3838, 'PG_EVENT_TRIGGER returns correct value'); is (PG_FDW_HANDLER , 3115, 'PG_FDW_HANDLER returns correct value'); is (PG_FLOAT4 , 700, 'PG_FLOAT4 returns correct value'); is (PG_FLOAT4ARRAY , 1021, 'PG_FLOAT4ARRAY returns correct value'); is (PG_FLOAT8 , 701, 'PG_FLOAT8 returns correct value'); is (PG_FLOAT8ARRAY , 1022, 'PG_FLOAT8ARRAY returns correct value'); is (PG_GTSVECTOR , 3642, 'PG_GTSVECTOR returns correct value'); is (PG_GTSVECTORARRAY , 3644, 'PG_GTSVECTORARRAY returns correct value'); is (PG_INDEX_AM_HANDLER , 325, 'PG_INDEX_AM_HANDLER returns correct value'); is (PG_INET , 869, 'PG_INET returns correct value'); is (PG_INETARRAY , 1041, 'PG_INETARRAY returns correct value'); is (PG_INT2 , 21, 'PG_INT2 returns correct value'); is (PG_INT2ARRAY , 1005, 'PG_INT2ARRAY returns correct value'); is (PG_INT2VECTOR , 22, 'PG_INT2VECTOR returns correct value'); is (PG_INT2VECTORARRAY , 1006, 'PG_INT2VECTORARRAY returns correct value'); is (PG_INT4 , 23, 'PG_INT4 returns correct value'); is (PG_INT4ARRAY , 1007, 'PG_INT4ARRAY returns correct value'); is (PG_INT4MULTIRANGE , 4451, 'PG_INT4MULTIRANGE returns correct value'); is (PG_INT4MULTIRANGEARRAY , 6150, 'PG_INT4MULTIRANGEARRAY returns correct value'); is (PG_INT4RANGE , 3904, 'PG_INT4RANGE returns correct value'); is (PG_INT4RANGEARRAY , 3905, 'PG_INT4RANGEARRAY returns correct value'); is (PG_INT8 , 20, 'PG_INT8 returns correct value'); is (PG_INT8ARRAY , 1016, 'PG_INT8ARRAY returns correct value'); is (PG_INT8MULTIRANGE , 4536, 'PG_INT8MULTIRANGE returns correct value'); is (PG_INT8MULTIRANGEARRAY , 6157, 'PG_INT8MULTIRANGEARRAY returns correct value'); is (PG_INT8RANGE , 3926, 'PG_INT8RANGE returns correct value'); is (PG_INT8RANGEARRAY , 3927, 'PG_INT8RANGEARRAY returns correct value'); is (PG_INTERNAL , 2281, 'PG_INTERNAL returns correct value'); is (PG_INTERVAL , 1186, 'PG_INTERVAL returns correct value'); is (PG_INTERVALARRAY , 1187, 'PG_INTERVALARRAY returns correct value'); is (PG_JSON , 114, 'PG_JSON returns correct value'); is (PG_JSONARRAY , 199, 'PG_JSONARRAY returns correct value'); is (PG_JSONB , 3802, 'PG_JSONB returns correct value'); is (PG_JSONBARRAY , 3807, 'PG_JSONBARRAY returns correct value'); is (PG_JSONPATH , 4072, 'PG_JSONPATH returns correct value'); is (PG_JSONPATHARRAY , 4073, 'PG_JSONPATHARRAY returns correct value'); is (PG_LANGUAGE_HANDLER , 2280, 'PG_LANGUAGE_HANDLER returns correct value'); is (PG_LINE , 628, 'PG_LINE returns correct value'); is (PG_LINEARRAY , 629, 'PG_LINEARRAY returns correct value'); is (PG_LSEG , 601, 'PG_LSEG returns correct value'); is (PG_LSEGARRAY , 1018, 'PG_LSEGARRAY returns correct value'); is (PG_MACADDR , 829, 'PG_MACADDR returns correct value'); is (PG_MACADDR8 , 774, 'PG_MACADDR8 returns correct value'); is (PG_MACADDR8ARRAY , 775, 'PG_MACADDR8ARRAY returns correct value'); is (PG_MACADDRARRAY , 1040, 'PG_MACADDRARRAY returns correct value'); is (PG_MONEY , 790, 'PG_MONEY returns correct value'); is (PG_MONEYARRAY , 791, 'PG_MONEYARRAY returns correct value'); is (PG_NAME , 19, 'PG_NAME returns correct value'); is (PG_NAMEARRAY , 1003, 'PG_NAMEARRAY returns correct value'); is (PG_NUMERIC , 1700, 'PG_NUMERIC returns correct value'); is (PG_NUMERICARRAY , 1231, 'PG_NUMERICARRAY returns correct value'); is (PG_NUMMULTIRANGE , 4532, 'PG_NUMMULTIRANGE returns correct value'); is (PG_NUMMULTIRANGEARRAY , 6151, 'PG_NUMMULTIRANGEARRAY returns correct value'); is (PG_NUMRANGE , 3906, 'PG_NUMRANGE returns correct value'); is (PG_NUMRANGEARRAY , 3907, 'PG_NUMRANGEARRAY returns correct value'); is (PG_OID , 26, 'PG_OID returns correct value'); is (PG_OID8 , 8256, 'PG_OID8 returns correct value'); is (PG_OID8ARRAY , 8261, 'PG_OID8ARRAY returns correct value'); is (PG_OIDARRAY , 1028, 'PG_OIDARRAY returns correct value'); is (PG_OIDVECTOR , 30, 'PG_OIDVECTOR returns correct value'); is (PG_OIDVECTORARRAY , 1013, 'PG_OIDVECTORARRAY returns correct value'); is (PG_PATH , 602, 'PG_PATH returns correct value'); is (PG_PATHARRAY , 1019, 'PG_PATHARRAY returns correct value'); is (PG_PG_ATTRIBUTE , 75, 'PG_PG_ATTRIBUTE returns correct value'); is (PG_PG_ATTRIBUTEARRAY , 270, 'PG_PG_ATTRIBUTEARRAY returns correct value'); is (PG_PG_BRIN_BLOOM_SUMMARY , 4600, 'PG_PG_BRIN_BLOOM_SUMMARY returns correct value'); is (PG_PG_BRIN_MINMAX_MULTI_SUMMARY , 4601, 'PG_PG_BRIN_MINMAX_MULTI_SUMMARY returns correct value'); is (PG_PG_CLASS , 83, 'PG_PG_CLASS returns correct value'); is (PG_PG_CLASSARRAY , 273, 'PG_PG_CLASSARRAY returns correct value'); is (PG_PG_DDL_COMMAND , 32, 'PG_PG_DDL_COMMAND returns correct value'); is (PG_PG_DEPENDENCIES , 3402, 'PG_PG_DEPENDENCIES returns correct value'); is (PG_PG_LSN , 3220, 'PG_PG_LSN returns correct value'); is (PG_PG_LSNARRAY , 3221, 'PG_PG_LSNARRAY returns correct value'); is (PG_PG_MCV_LIST , 5017, 'PG_PG_MCV_LIST returns correct value'); is (PG_PG_NDISTINCT , 3361, 'PG_PG_NDISTINCT returns correct value'); is (PG_PG_NODE_TREE , 194, 'PG_PG_NODE_TREE returns correct value'); is (PG_PG_PROC , 81, 'PG_PG_PROC returns correct value'); is (PG_PG_PROCARRAY , 272, 'PG_PG_PROCARRAY returns correct value'); is (PG_PG_SNAPSHOT , 5038, 'PG_PG_SNAPSHOT returns correct value'); is (PG_PG_SNAPSHOTARRAY , 5039, 'PG_PG_SNAPSHOTARRAY returns correct value'); is (PG_PG_TYPE , 71, 'PG_PG_TYPE returns correct value'); is (PG_PG_TYPEARRAY , 210, 'PG_PG_TYPEARRAY returns correct value'); is (PG_POINT , 600, 'PG_POINT returns correct value'); is (PG_POINTARRAY , 1017, 'PG_POINTARRAY returns correct value'); is (PG_POLYGON , 604, 'PG_POLYGON returns correct value'); is (PG_POLYGONARRAY , 1027, 'PG_POLYGONARRAY returns correct value'); is (PG_RECORD , 2249, 'PG_RECORD returns correct value'); is (PG_RECORDARRAY , 2287, 'PG_RECORDARRAY returns correct value'); is (PG_REFCURSOR , 1790, 'PG_REFCURSOR returns correct value'); is (PG_REFCURSORARRAY , 2201, 'PG_REFCURSORARRAY returns correct value'); is (PG_REGCLASS , 2205, 'PG_REGCLASS returns correct value'); is (PG_REGCLASSARRAY , 2210, 'PG_REGCLASSARRAY returns correct value'); is (PG_REGCOLLATION , 4191, 'PG_REGCOLLATION returns correct value'); is (PG_REGCOLLATIONARRAY , 4192, 'PG_REGCOLLATIONARRAY returns correct value'); is (PG_REGCONFIG , 3734, 'PG_REGCONFIG returns correct value'); is (PG_REGCONFIGARRAY , 3735, 'PG_REGCONFIGARRAY returns correct value'); is (PG_REGDATABASE , 8326, 'PG_REGDATABASE returns correct value'); is (PG_REGDATABASEARRAY , 8327, 'PG_REGDATABASEARRAY returns correct value'); is (PG_REGDICTIONARY , 3769, 'PG_REGDICTIONARY returns correct value'); is (PG_REGDICTIONARYARRAY , 3770, 'PG_REGDICTIONARYARRAY returns correct value'); is (PG_REGNAMESPACE , 4089, 'PG_REGNAMESPACE returns correct value'); is (PG_REGNAMESPACEARRAY , 4090, 'PG_REGNAMESPACEARRAY returns correct value'); is (PG_REGOPER , 2203, 'PG_REGOPER returns correct value'); is (PG_REGOPERARRAY , 2208, 'PG_REGOPERARRAY returns correct value'); is (PG_REGOPERATOR , 2204, 'PG_REGOPERATOR returns correct value'); is (PG_REGOPERATORARRAY , 2209, 'PG_REGOPERATORARRAY returns correct value'); is (PG_REGPROC , 24, 'PG_REGPROC returns correct value'); is (PG_REGPROCARRAY , 1008, 'PG_REGPROCARRAY returns correct value'); is (PG_REGPROCEDURE , 2202, 'PG_REGPROCEDURE returns correct value'); is (PG_REGPROCEDUREARRAY , 2207, 'PG_REGPROCEDUREARRAY returns correct value'); is (PG_REGROLE , 4096, 'PG_REGROLE returns correct value'); is (PG_REGROLEARRAY , 4097, 'PG_REGROLEARRAY returns correct value'); is (PG_REGTYPE , 2206, 'PG_REGTYPE returns correct value'); is (PG_REGTYPEARRAY , 2211, 'PG_REGTYPEARRAY returns correct value'); is (PG_TABLE_AM_HANDLER , 269, 'PG_TABLE_AM_HANDLER returns correct value'); is (PG_TEXT , 25, 'PG_TEXT returns correct value'); is (PG_TEXTARRAY , 1009, 'PG_TEXTARRAY returns correct value'); is (PG_TID , 27, 'PG_TID returns correct value'); is (PG_TIDARRAY , 1010, 'PG_TIDARRAY returns correct value'); is (PG_TIME , 1083, 'PG_TIME returns correct value'); is (PG_TIMEARRAY , 1183, 'PG_TIMEARRAY returns correct value'); is (PG_TIMESTAMP , 1114, 'PG_TIMESTAMP returns correct value'); is (PG_TIMESTAMPARRAY , 1115, 'PG_TIMESTAMPARRAY returns correct value'); is (PG_TIMESTAMPTZ , 1184, 'PG_TIMESTAMPTZ returns correct value'); is (PG_TIMESTAMPTZARRAY , 1185, 'PG_TIMESTAMPTZARRAY returns correct value'); is (PG_TIMETZ , 1266, 'PG_TIMETZ returns correct value'); is (PG_TIMETZARRAY , 1270, 'PG_TIMETZARRAY returns correct value'); is (PG_TRIGGER , 2279, 'PG_TRIGGER returns correct value'); is (PG_TSMULTIRANGE , 4533, 'PG_TSMULTIRANGE returns correct value'); is (PG_TSMULTIRANGEARRAY , 6152, 'PG_TSMULTIRANGEARRAY returns correct value'); is (PG_TSM_HANDLER , 3310, 'PG_TSM_HANDLER returns correct value'); is (PG_TSQUERY , 3615, 'PG_TSQUERY returns correct value'); is (PG_TSQUERYARRAY , 3645, 'PG_TSQUERYARRAY returns correct value'); is (PG_TSRANGE , 3908, 'PG_TSRANGE returns correct value'); is (PG_TSRANGEARRAY , 3909, 'PG_TSRANGEARRAY returns correct value'); is (PG_TSTZMULTIRANGE , 4534, 'PG_TSTZMULTIRANGE returns correct value'); is (PG_TSTZMULTIRANGEARRAY , 6153, 'PG_TSTZMULTIRANGEARRAY returns correct value'); is (PG_TSTZRANGE , 3910, 'PG_TSTZRANGE returns correct value'); is (PG_TSTZRANGEARRAY , 3911, 'PG_TSTZRANGEARRAY returns correct value'); is (PG_TSVECTOR , 3614, 'PG_TSVECTOR returns correct value'); is (PG_TSVECTORARRAY , 3643, 'PG_TSVECTORARRAY returns correct value'); is (PG_TXID_SNAPSHOT , 2970, 'PG_TXID_SNAPSHOT returns correct value'); is (PG_TXID_SNAPSHOTARRAY , 2949, 'PG_TXID_SNAPSHOTARRAY returns correct value'); is (PG_UNKNOWN , 705, 'PG_UNKNOWN returns correct value'); is (PG_UUID , 2950, 'PG_UUID returns correct value'); is (PG_UUIDARRAY , 2951, 'PG_UUIDARRAY returns correct value'); is (PG_VARBIT , 1562, 'PG_VARBIT returns correct value'); is (PG_VARBITARRAY , 1563, 'PG_VARBITARRAY returns correct value'); is (PG_VARCHAR , 1043, 'PG_VARCHAR returns correct value'); is (PG_VARCHARARRAY , 1015, 'PG_VARCHARARRAY returns correct value'); is (PG_VOID , 2278, 'PG_VOID returns correct value'); is (PG_XID , 28, 'PG_XID returns correct value'); is (PG_XID8 , 5069, 'PG_XID8 returns correct value'); is (PG_XID8ARRAY , 271, 'PG_XID8ARRAY returns correct value'); is (PG_XIDARRAY , 1011, 'PG_XIDARRAY returns correct value'); is (PG_XML , 142, 'PG_XML returns correct value'); is (PG_XMLARRAY , 143, 'PG_XMLARRAY returns correct value'); done_testing(); DBD-Pg-3.20.2/t/30unicode.t0000644000175000017500000002340115166170753013421 0ustar greggreg#!perl ## Test everything related to Unicode. ## At the moment, this basically means testing the UTF8 client_encoding ## and $dbh->{pg_enable_utf8} bits use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use utf8; ## no critic (TooMuchCode::ProhibitUnnecessaryUTF8Pragma) use charnames ':full'; use Encode qw(encode_utf8); use Data::Dumper; use Test::More; use open qw/ :std :encoding(utf8) /; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } isnt ($dbh, undef, 'Connect to database for unicode testing'); my @tests; my $server_encoding = $dbh->selectrow_array('SHOW server_encoding'); my $client_encoding = $dbh->selectrow_array('SHOW client_encoding'); # Beware, characters used for testing need to be known to Unicode version 4.0.0, # which is what perl 5.8.1 shipped with. foreach ( [ascii => 'Ada Lovelace'], ['latin 1 range' => "\N{LATIN CAPITAL LETTER E WITH ACUTE}milie du Ch\N{LATIN SMALL LETTER A WITH CIRCUMFLEX}telet"], # I'm finding it awkward to continue the theme of female mathematicians ['base plane' => "Interrobang\N{INTERROBANG}"], ['astral plane' => "\N{MUSICAL SYMBOL CRESCENDO}"], ) { my ($range, $text) = @$_; my $name_d = my $name_u = $text; utf8::upgrade($name_u); # Before 5.12.0 the text to the left of => gets to be SvUTF8() under use utf8; # even if it's plain ASCII. This would confuse what we test for below. push @tests, ( [upgraded => $range => 'text' => $name_u], [upgraded => $range => 'text[]' => [$name_u]], ); if (utf8::downgrade($name_d, 1)) { push @tests, ( [downgraded => $range => 'text' => $name_d], [downgraded => $range => 'text[]' => [$name_d]], [mixed => $range => 'text[]' => [$name_d,$name_u]], ); } } my %ranges = ( UTF8 => qr/.*/, LATIN1 => qr/\A(?:ascii|latin 1 range)\z/, ); eval { $dbh->do('DROP TABLE dbd_pg_test_unicode') }; $dbh->commit(); $dbh->do('CREATE TABLE dbd_pg_test_unicode(t TEXT)'); foreach (@tests) { my ($state, $range, $type, $value) = @$_; SKIP: foreach my $test ( { qtype => 'placeholder', sql => "SELECT ?::$type", args => [$value], }, (($type eq 'text') ? ( { qtype => 'interpolated', sql => "SELECT '$value'::$type", }, { qtype => 'interpolated insert', sql => "INSERT INTO dbd_pg_test_unicode VALUES ('$value'::$type)", }, # Test that what we send is the same as the database's idea of characters: { qtype => 'placeholder length', sql => "SELECT length(?::$type)", args => [$value], want => length($value), }, { qtype => 'placeholder length insert', sql => "INSERT INTO dbd_pg_test_unicode VALUES (length(?::$type))", args => [$value], want => length($value), }, { qtype => 'interpolated length', sql => "SELECT length('$value'::$type)", want => length($value), }, { qtype => 'interpolated length insert', sql => "INSERT INTO dbd_pg_test_unicode VALUES (length('$value'::$type))", want => length($value), }, ):()), ) { skip "Can't do $range tests with server_encoding='$server_encoding'", 1 if $range !~ ($ranges{$server_encoding} || qr/\A(?:ascii)\z/); skip 'Cannot perform range tests if client_encoding is not UTF8', 1 if $client_encoding ne 'UTF8'; foreach my $enable_utf8 (1, 0, -1) { my $description = "$state $range UTF-8 $test->{qtype} $type (pg_enable_utf8=$enable_utf8)"; my @args = @{$test->{args} || []}; my $want = exists $test->{want} ? $test->{want} : $value; if (!$enable_utf8) { $want = ref $want ? [ map encode_utf8($_), @{$want} ] ## no critic : encode_utf8($want); } is(utf8::is_utf8($test->{sql}), ($state eq 'upgraded'), "$description query has correct flag") if $test->{qtype} =~ /^interpolated/; if ($state ne 'mixed') { foreach my $arg (map { ref($_) ? @{$_} : $_ } @args) { ## no critic is(utf8::is_utf8($arg), ($state eq 'upgraded'), "$description arg has correct flag") } } $dbh->{pg_enable_utf8} = $enable_utf8; ## Skip pg_enable_utf=0 for now if (0 == $enable_utf8) { if ($range eq 'latin 1 range' or $range eq 'base plane' or $range eq 'astral plane') { pass ("Skipping test of pg_enable_utf=0 with $range"); next; } } my $sth = $dbh->prepare($test->{sql}); eval { $sth->execute(@args); }; if ($@) { diag "Failure: enable_utf8=$enable_utf8, SQL=$test->{sql}, range=$range\n"; die $@; } else { if ($test->{qtype} =~ /insert/) { $dbh->commit(); $sth = $dbh->prepare('SELECT * FROM dbd_pg_test_unicode'); $sth->execute(); } my $result = $sth->fetchall_arrayref->[0][0]; is_deeply ($result, $want, "$description via prepare+execute+fetchall returns proper value"); if ($test->{qtype} !~ /length/) { # Whilst XS code can set SVf_UTF8 on an IV, the core's SV # copying code doesn't copy it. So we can't assume that numeric # values we see "out here" still have it set. Hence skip this # test for the SQL length() tests. is (utf8::is_utf8($_), !!$enable_utf8, "$description via prepare+execute+fetchall returns string with correct UTF-8 flag") for (ref $result ? @{$result} : $result); } } if ($test->{qtype} =~ /insert/) { $dbh->do('DELETE FROM dbd_pg_test_unicode'); $dbh->commit(); } my $result; if ($test->{qtype} =~ /insert/) { eval { $dbh->do($test->{sql}, undef, @args) }; if (not $@) { $dbh->commit(); $result = eval { $dbh->selectall_arrayref('SELECT * FROM dbd_pg_test_unicode')->[0][0] }; } } else { $result = eval { $dbh->selectall_arrayref($test->{sql}, undef, @args)->[0][0] }; } if ($@) { diag "Failure: enable_utf8=$enable_utf8, SQL=$test->{sql}, range=$range\n"; die $@; } else { is_deeply ($result, $want, "$description via do/selectall returns proper value"); if ($test->{qtype} !~ /length/) { # Whilst XS code can set SVf_UTF8 on an IV, the core's SV # copying code doesn't copy it. So we can't assume that numeric # values we see "out here" still have it set. Hence skip this # test for the SQL length() tests. is (utf8::is_utf8($_), !!$enable_utf8, "$description via do/selectall returns string with correct UTF-8 flag") for (ref $result ? @{$result} : $result); } } if ($test->{qtype} =~ /insert/) { $dbh->do('DELETE FROM dbd_pg_test_unicode'); $dbh->commit(); } } } } my %ord_max = ( LATIN1 => 255, UTF8 => 2**31, ); # Test that what we get is the same as the database's idea of characters: for my $name ('LATIN CAPITAL LETTER N', 'LATIN SMALL LETTER E WITH ACUTE', 'CURRENCY SIGN', # Has a different code point in Unicode, Windows 1252 and ISO-8859-15 'EURO SIGN', 'POUND SIGN', 'YEN SIGN', # Has a different code point in Unicode and Windows 1252 'LATIN CAPITAL LETTER S WITH CARON', 'SNOWMAN', # U+1D196 should be 1 character, not a surrogate pair 'MUSICAL SYMBOL TR', ) { my $ord = charnames::vianame($name); SKIP: foreach my $enable_utf8 (1, 0, -1) { my $description = sprintf "chr(?) for U+%04X $name, \$enable_utf8=$enable_utf8", $ord; skip "Pg < 8.3 has broken $description", 1 if $ord > 127 && $dbh->{pg_server_version} < 80300; skip "Cannot do $description with server_encoding='$server_encoding'", 1 if $ord > ($ord_max{$server_encoding} || 127); $dbh->{pg_enable_utf8} = $enable_utf8; my $sth = $dbh->prepare('SELECT chr(?)'); $sth->execute($ord); my $result = $sth->fetchall_arrayref->[0][0]; if (!$enable_utf8) { # We asked for UTF-8 octets to arrive in Perl-space. # Check this, and convert them to character(s). # If we didn't, the next two tests are meaningless, so skip them. is(utf8::decode($result), 1, "Got valid UTF-8 for $description") or next; } is (length $result, 1, "Got 1 character for $description"); is (ord $result, $ord, "Got correct character for $description"); } } $dbh->do('DROP TABLE dbd_pg_test_unicode'); $dbh->commit(); cleanup_database($dbh,'test'); $dbh->disconnect(); done_testing(); DBD-Pg-3.20.2/t/00basic.t0000644000175000017500000000234015116315266013043 0ustar greggreg#!perl ## Simply test that we can load the DBI and DBD::Pg modules, ## and that the latter gives a good version use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Test::More tests => 3; select(($|=1,select(STDERR),$|=1)[1]); BEGIN { use_ok ('DBI') or BAIL_OUT 'Cannot continue without DBI'; ## If we cannot load DBD::Pg, output some compiler information for debugging: if (! use_ok ('DBD::Pg')) { my $file = 'Makefile'; if (! -e $file) { $file = '../Makefile'; } my $fh; if (open $fh, '<', $file) { ## no critic (CompileTime) { local $/; $_ = <$fh>; } close $fh or die qq{Could not close file "$file" $!\n}; ## no critic (CompileTime) for my $keyword (qw/ CCFLAGS INC LIBS /) { if (/^#\s+$keyword => (.+)/m) { diag "$keyword: $1"; } } } diag 'If the error mentions libpq.so, please see the troubleshooting section of the README file'; BAIL_OUT 'Cannot continue without DBD::Pg'; } } use DBD::Pg; like ($DBD::Pg::VERSION, qr/^v?[0-9]+\.[0-9]+\.[0-9]+(?:_[0-9]+)?$/, qq{Found DBD::Pg::VERSION as "$DBD::Pg::VERSION"}); DBD-Pg-3.20.2/t/dbdpg_test_setup.pl0000644000175000017500000007577115174664234015361 0ustar greggreg## Helper file for the DBD::Pg tests use strict; use warnings; use lib 'blib/lib', 'blib/arch'; ## no critic use Data::Dumper; use DBI; use File::Temp; use Cwd; use Test::More qw//; use 5.008001; select(($|=1,select(STDERR),$|=1)[1]); my $superuser = 1; my $TEST_PORT_MIN = 5442; my $TEST_PORT_MAX = 5542; my $testfh; if (exists $ENV{TEST_OUTPUT}) { my $file = $ENV{TEST_OUTPUT}; open $testfh, '>>', $file or die qq{Could not append file "$file": $!\n}; Test::More->builder->failure_output($testfh); Test::More->builder->todo_output($testfh); } my @views = ( 'dbd_pg_view', ); my @matviews = ( 'dbd_pg_matview', ); my @operators = ( '?.integer.integer', '??.text.text', ); my @schemas = ( 'dbd_pg_testschema', 'dbd_pg_testschema2', ); my @tables = ( 'dbd_pg_test5', 'dbd_pg_test4', 'dbd_pg_test3', 'dbd_pg_testschema2.dbd_pg_test3', 'dbd_pg_testschema2.dbd_pg_test2', 'dbd_pg_test2', 'dbd_pg_test1', 'dbd_pg_test', 'dbd_pg_test_geom', ); my @sequences = ( 'dbd_pg_testsequence', 'dbd_pg_testschema2.dbd_pg_testsequence2', 'dbd_pg_testschema2.dbd_pg_testsequence3', ); ## Schema used for testing: my $S = 'dbd_pg_testschema'; ## File written so we don't have to retry connections: my $helpfile = 'README.testdatabase'; our $fh; sub connect_database { ## Connect to the database (unless 'dbh' is passed in) ## Setup all the tables (unless 'nocreate' is passed in) ## Returns three values: ## 1. helpconnect for use by 01connect.t ## 2. Any error generated ## 3. The database handle, or undef my $arg = shift || {}; ref $arg and ref $arg eq 'HASH' or die qq{Need a hashref!\n}; my $dbh = $arg->{dbh} || ''; my $alias = qr{(database|db|dbname)}; my $info; my $olddir = getcwd; my $debug = $ENV{DBDPG_DEBUG} || 0; delete @ENV{ 'PGSERVICE', 'PGDATABASE' }; ## We'll try various ways to get to a database to test with ## First, check to see if we've been here before and left directions my ($testdsn,$testuser,$helpconnect,$su,$uid,$testdir,$pg_ctl,$initdb,$error,$version) = get_test_settings(); if ($debug) { Test::More::diag "Test settings: dsn: $testdsn user: $testuser helpconnect: $helpconnect su: $su uid: $uid testdir: $testdir pg_ctl: $pg_ctl initdb: $initdb error: $error version: $version "; for my $key ( grep { /^DBDPG/ } sort keys %ENV ) { Test::More::diag "ENV $key = $ENV{$key}\n"; } } ## Did we fail last time? Fail this time too, but quicker! if ($testdsn =~ /FAIL!/) { $debug and Test::More::diag 'Previous failure detected'; return $helpconnect, "Previous failure ($error)", undef; } ## We may want to force an initdb call if ((!$helpconnect and $ENV{DBDPG_TESTINITDB}) or (exists $ENV{DBDPG_INITDB} and $initdb ne $ENV{DBDPG_INITDB})) { $debug and Test::More::diag 'Jumping to INITDB'; goto INITDB; } ## Got a working DSN? Give it an attempt if ($testdsn and $testuser) { $debug and Test::More::diag "Trying with $testuser and $testdsn"; ## Used by t/01connect.t if ($arg->{dbreplace}) { $testdsn =~ s/$alias\s*=/$arg->{dbreplace}=/; } if ($arg->{dbquotes}) { $testdsn =~ s/$alias\s*=([\-\w]+)/'db="'.lc $2.'"'/e; } goto GOTDBH if eval { $dbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 1}); 1; }; $debug and Test::More::diag "Connection failed: $@"; if ($@ =~ /invalid connection option/ or $@ =~ /dbbarf/) { return $helpconnect, $@, undef; } if ($arg->{nocreate}) { return $helpconnect, '', undef; } ## If this was created by us, try and restart it if (16 == $helpconnect) { $debug and Test::More::diag 'Attempting restart of existing test cluster'; ## Bypass if the testdir has been removed if (! -e $testdir) { $arg->{nocreate} and return $helpconnect, '', undef; warn "Test directory $testdir has been removed, will create a new one\n"; } else { my $pidfile = "$testdir/data/postmaster.pid"; if (-e $pidfile) { $debug and Test::More::diag "Found $pidfile"; ## Assume it's up, and move on } else { if ($arg->{norestart}) { return $helpconnect, '', undef; } warn "Restarting test database $testdsn at $testdir\n"; my $COM = qq{$pg_ctl -o '-k $testdir' -l $testdir/dbdpg_test.logfile -D $testdir/data start}; if ($su) { $COM = qq{su -m $su -c "$COM"}; chdir $testdir; } $info = ''; eval { $info = qx{$COM}; }; my $err = $@; $su and chdir $olddir; if ($info !~ /starting/ and ($err or $info !~ /\w/)) { $err = "Could not startup THIS new database (err=$err) ($info)"; return $helpconnect, $err, undef; } ## Wait for it to startup and verify the connection sleep 1; } my $loop = 1; STARTUP: { eval { $dbh = DBI->connect($testdsn, $testuser, '', {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; if ($@ =~ /starting up/ or $@ =~ /PGSQL\.[0-9]+/) { if ($loop++ < 20) { $debug and Test::More::diag "Failed to start, sleeping 1 second round $loop/20"; sleep 1; redo STARTUP; } } } if ($@) { return $helpconnect, $@, $dbh; } ## We've got a good connection, so do final tweaks and return goto GOTDBH; } ## end testdir exists } ## end error and we created this database } ## end got testdsn and testuser ## No previous info (or failed attempt), so try to connect and possible create our own cluster $testdsn ||= $ENV{DBI_DSN}; $testuser ||= $ENV{DBI_USER}; if (! $testdsn) { $helpconnect = 1; $testdsn = $^O =~ /Win32/ ? 'dbi:Pg:host=localhost' : 'dbi:Pg:dbname=postgres'; } if (! $testuser) { $testuser = 'postgres'; } ## From here on out, we don't return directly, but save it first GETHANDLE: { eval { $dbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; last GETHANDLE if ! $@; ## Made it! ## If the error was because of the user, try a few others if ($@ =~ /postgres/) { if ($helpconnect) { $testdsn .= ';dbname=postgres'; $helpconnect += 2; } $helpconnect += 4; $testuser = $^O =~ /openbsd/ ? '_postgresql' : $^O =~ /bsd/i ? 'pgsql' : 'postgres'; eval { $dbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; last GETHANDLE if ! $@; ## Made it! ## Final user tweak: set to postgres for Beastie if ($testuser ne 'postgres') { $helpconnect += 8; $testuser = 'postgres'; eval { $dbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; last GETHANDLE if ! $@; ## Made it! } } ## Cannot connect to an existing database, so we'll create our own if ($arg->{nocreate}) { return $helpconnect, '', undef; } INITDB: $helpconnect = 16; ## Let the ENV variables win for my $key (qw/ DBDPG_INITDB PGINITDB /) { if (exists $ENV{$key} and length $ENV{$key}) { $initdb = $ENV{$key}; ($pg_ctl = $initdb) =~ s/initdb/pg_ctl/; last; } } ## Use the initdb found by App::Info if (! length $initdb or $initdb eq 'default') { $initdb = 'initdb'; } if ($initdb ne 'initdb' and ! -e $initdb) { die "Invalid initdb: $initdb\n"; } ## Make sure initdb exists and is working properly $ENV{LANG} = 'C'; $info = ''; eval { $info = qx{$initdb --version 2>&1}; }; last GETHANDLE if $@; ## Fail - initdb bad $version = 0; if (!defined $info or ($info !~ /Postgres|EnterpriseDB/i and $info !~ /run as root/)) { if (defined $info) { if ($info !~ /\w/) { $@ = 'initdb not found: cannot run full tests without a Postgres database'; } else { $@ = "Bad initdb output: $info"; } } else { my $msg = 'Failed to run initdb (executable probably not available)'; exists $ENV{DBDPG_INITDB} and $msg .= " ENV was: $ENV{DBDPG_INITDB}"; $msg .= " Final call was: $initdb"; $@ = $msg; } last GETHANDLE; ## Fail - initdb bad } elsif ($info =~ /([0-9]+)(?:devel|beta|rc|alpha)/) { ## Can be 10devel $version = $1; } elsif ($info =~ /([0-9]+\.[0-9]+)/) { $version = $1; } else { die "No version from initdb?! ($info)\n"; } ## Make sure pg_ctl is available as well before we go further if (! -e $pg_ctl) { $pg_ctl = 'pg_ctl'; } $info = ''; eval { $info = qx{$pg_ctl --help 2>&1}; }; last GETHANDLE if $@; ## Fail - pg_ctl bad if (!defined $info or ($info !~ /\@(?:[a-z.-]*?postgresql\.org|enterprisedb\.com)/ and $info !~ /run as root/)) { $@ = defined $initdb ? "Bad pg_ctl output: $info" : 'Bad pg_ctl output'; last GETHANDLE; ## Fail - pg_ctl bad } ## initdb and pg_ctl seems to be available, let's use them to fire up a cluster warn "Please wait, creating new Postgres cluster (version $version) for testing\n"; $info = ''; my $locale = $ENV{DBDPG_TEST_LOCALE} || 'C'; eval { my $com = "$initdb --locale=$locale -E UTF8 -D $testdir/data"; $debug and warn" Attempting: $com\n"; $info = qx{$com 2>&1}; }; last GETHANDLE if $@; ## Fail - initdb bad ## initdb and pg_ctl cannot be run as root, so let's handle that if ($info =~ /run as root/ or $info =~ /unprivilegierte/) { my $founduser = 0; $su = $testuser = ''; $testdir = exists $ENV{DBDPG_TEMPDIR} ? File::Temp::tempdir("$ENV{DBDPG_TEMPDIR}/dbdpg_testdatabase_XXXXXX", CLEANUP => 0) : File::Temp::tempdir('dbdpg_testdatabase_XXXXXX', TMPDIR => 1, CLEANUP => 0); my $readme = "$testdir/README"; if (open $fh, '>', $readme) { print {$fh} "This is a test directory for DBD::Pg and may be removed\n"; print {$fh} "You may want to ensure the postmaster has been stopped first.\n"; print {$fh} "Check the data/postmaster.pid file\n"; close $fh or die qq{Could not close "$readme": $!\n}; } ## Likely candidates for running this my @userlist = (qw/postgres postgresql pgsql _postgres/); ## Start with whoever owns this file, unless it's us my $username = getpwuid ((stat($0))[4]); unshift @userlist, $username if defined $username and $username ne getpwent; my %doneuser; for (@userlist) { $testuser = $_; next if $doneuser{$testuser}++; $uid = (getpwnam $testuser)[2]; next if !defined $uid; next unless chown $uid, -1, $testdir; next unless chown $uid, -1, $readme; $su = $testuser; $founduser++; $info = ''; $olddir = getcwd; eval { chdir $testdir; $info = qx{su -m $testuser -c "/bin/sh -c '$initdb --locale=C -E UTF8 -D $testdir/data 2>&1'"}; }; my $err = $@; chdir $olddir; last if !$err; } if (!$founduser) { $@ = 'Unable to find a user to run initdb as'; last GETHANDLE; ## Fail - no user } if (! -e "$testdir/data") { $@ = 'Could not create a test database via initdb'; last GETHANDLE; ## Fail - no datadir created } ## At this point, both $su and $testuser are set } if ($info =~ /FATAL/) { $@ = "initdb gave a FATAL error: $info"; last GETHANDLE; ## Fail - FATAL } if ($info =~ /but is not empty/) { ## Assume this is already good to go } elsif ($info !~ /pg_ctl/) { $@ = "initdb did not give a pg_ctl string: $info"; last GETHANDLE; ## Fail - bad output } ## Which user do we connect as? if (!$su and $info =~ /owned by user "(.+?)"/) { $testuser = $1; } ## Attempt to boost the system oids above an int for certain testing (my $resetxlog = $initdb) =~ s/initdb/pg_resetxlog/; if ($version >= 10) { $resetxlog =~ s/pg_resetxlog/pg_resetwal/; } eval { if ($su) { $info = qx{su -m "$testuser" -c "$resetxlog --help"}; } else { $info = qx{$resetxlog --help}; } }; if (! $@ and $info =~ /XID/) { if (! -e "$testdir/data/postmaster.pid") { eval { if ($su) { $info = qx{ su -m "$testuser" -c "$resetxlog -o 2222333344 $testdir/data" }; } else { $info = qx{ $resetxlog -o 2222333344 $testdir/data }; } }; ## We don't really care if it worked or not! } } ## Now we need to find an open port to use my $testport = $TEST_PORT_MIN; $info = ''; my $evalok = 0; eval { $info = qx{ss -QanO 2>&1}; $evalok = 1; }; if (!$evalok or ! defined $info) { warn "ss call to determine open port failed, trying port $testport\n"; } else { { last if $info !~ /:$testport /m; last if ++$testport > $TEST_PORT_MAX; redo; } if ($testport > $TEST_PORT_MAX) { $@ = "No free ports found for testing: tried $TEST_PORT_MIN to $TEST_PORT_MAX\n"; last GETHANDLE; ## Fail - no free ports } } $@ = ''; $debug and Test::More::diag "Port to use: $testport"; my $conf = "$testdir/data/postgresql.conf"; my $cfh; ## If there is already a pid file, do not modify the config ## We assume a previous run put it there, so we extract the port if (-e "$testdir/data/postmaster.pid") { $debug and Test::More::diag qq{File "$testdir/data/postmaster.pid" exists}; open my $cfh, '<', $conf or die qq{Could not open "$conf": $!\n}; while (<$cfh>) { if (/^\s*port\s*=\s*([0-9]+)/) { $testport = $1; $debug and Test::More::diag qq{Found port $testport inside conf file\n}; } } close $cfh or die qq{Could not close "$conf": $!\n}; ## Assume it's up, and move on } else { ## Change to this new port and fire it up if (! open $cfh, '>>', $conf) { $@ = qq{Could not open "$conf": $!}; $debug and Test::More::diag qq{Failed to open "$conf"}; last GETHANDLE; ## Fail - no conf file } $debug and Test::More::diag qq{Writing to "$conf"}; print {$cfh} "\n\n## DBD::Pg testing parameters\n"; print {$cfh} "port=$testport\n"; print {$cfh} "max_connections=11\n"; print {$cfh} "log_statement = 'all'\n"; print {$cfh} "log_min_duration_statement = 0\n"; print {$cfh} "log_line_prefix = '%m [%p] '\n"; print {$cfh} "log_filename = 'postgres%Y-%m-%d.log'\n"; print {$cfh} "log_rotation_size = 0\n"; if (8.1 == $version) { print {$cfh} "redirect_stderr = on\n"; } if ($version >= 8.3) { print {$cfh} "logging_collector = on\n"; } if ($version >= 9.4) { print {$cfh} "wal_level = logical\n"; print {$cfh} "max_replication_slots = 1\n"; print {$cfh} "max_wal_senders = 1\n"; open my $hba, '>>', "$testdir/data/pg_hba.conf" or die qq{Could not open "$testdir/data/pg_hba.conf": $!\n}; print {$hba} "local\treplication\tall\ttrust\n"; print {$hba} "host\treplication\tall\t127.0.0.1/32\ttrust\n"; print {$hba} "host\treplication\tall\t::1/128\ttrust\n"; close $hba or die qq{Could not close "$testdir/data/pg_hba.conf": $!\n}; } print {$cfh} "listen_addresses='127.0.0.1'\n" if $^O =~ /Win32/; print {$cfh} "\n"; close $cfh or die qq{Could not close "$conf": $!\n}; ## Attempt to start up the test server $info = ''; my $COM = qq{$pg_ctl -o '-k $testdir' -l $testdir/dbdpg_test.logfile -D $testdir/data start}; $olddir = getcwd; if ($su) { chdir $testdir; $COM = qq{su -m $su -c "$COM"}; } $debug and Test::More::diag qq{Running: $COM}; eval { $info = qx{$COM}; }; my $err = $@; $su and chdir $olddir; if ($err) { $@ = "Could not startup new database ($COM) ($err) ($info)"; last GETHANDLE; ## Fail - startup failed } sleep 1; } ## Attempt to connect to this server $testdsn = "dbi:Pg:dbname=postgres;port=$testport"; if ($^O =~ /Win32/) { $testdsn .= ';host=localhost'; } else { $testdsn .= ";host=$testdir"; } $debug and Test::More::diag qq{Test DSN: $testdsn}; my $loop = 1; STARTUP: { eval { $dbh = DBI->connect($testdsn, $testuser, '', {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; ## Regardless of the error, try again. ## We used to check the message, but LANG problems may complicate that. if ($@) { $debug and Test::More::diag qq{Connection error: $@\n}; if ($@ =~ /database "postgres" does not exist/) { ## Old server, so let's create a postgres database manually sleep 2; (my $tempdsn = $testdsn) =~ s/postgres/template1/; eval { $dbh = DBI->connect($tempdsn, $testuser, '', {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; if ($@) { die "Could not connect: $@\n"; } $dbh->do('CREATE DATABASE postgres'); $dbh->disconnect(); } if ($@ =~ /role "postgres" does not exist/) { ## Probably just created with the current user, so use that if (exists $ENV{USER} and length $ENV{USER}) { $debug and Test::More::diag qq{Switched to new user: $testuser\n}; eval { $dbh = DBI->connect($testdsn, $ENV{USER}, '', {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; if ($@) { die "Could not connect: $@\n"; } $dbh->do('CREATE USER postgres SUPERUSER'); $dbh->disconnect(); } } if ($loop++ < 5) { sleep 1; redo STARTUP; } } last GETHANDLE; ## Made it! } } ## end of GETHANDLE ## At this point, we've got a connection, or have failed ## Either way, we record for future runs my $connerror = $@; if (open $fh, '>', $helpfile) { print {$fh} "## This is a temporary file created for testing DBD::Pg\n"; print {$fh} '## Created: ' . scalar localtime() . "\n"; print {$fh} "## Feel free to remove it!\n"; print {$fh} "## Helpconnect: $helpconnect\n"; print {$fh} "## pg_ctl: $pg_ctl\n"; print {$fh} "## initdb: $initdb\n"; print {$fh} "## Version: $version\n"; if ($connerror) { print {$fh} "## DSN: FAIL!\n"; print {$fh} "## ERROR: $connerror\n"; } else { print {$fh} "## DSN: $testdsn\n"; print {$fh} "## User: $testuser\n"; print {$fh} "## Testdir: $testdir\n" if 16 == $helpconnect; print {$fh} "## Testowner: $su\n" if $su; print {$fh} "## Testowneruid: $uid\n" if $uid; } close $fh or die qq{Could not close "$helpfile": $!\n}; } $connerror and return $helpconnect, $connerror, undef; GOTDBH: ## This allows things like data_sources() to work if we did an initdb $ENV{DBI_DSN} = $testdsn; $ENV{DBI_USER} = $testuser; $debug and Test::More::diag "Got a database handle ($dbh)"; if (!$arg->{quickreturn} or 1 != $arg->{quickreturn}) { ## non-ASCII parts of the tests assume UTF8 $dbh->do('SET client_encoding = utf8'); $dbh->{pg_enable_utf8} = -1; ## Always want this on for consistent testing if ($dbh->{pg_server_version} >= 80200) { $dbh->do('SET array_nulls = ON'); } } if ($arg->{quickreturn}) { $debug and Test::More::diag 'Returning via quickreturn'; return $helpconnect, '', $dbh; } my $SQL = 'SELECT usesuper FROM pg_user WHERE usename = current_user'; $superuser = $dbh->selectall_arrayref($SQL)->[0][0]; if ($superuser) { $dbh->do(q{SET LC_MESSAGES = 'C'}); } if ($arg->{nosetup}) { return $helpconnect, '', $dbh unless schema_exists($dbh, $S); $dbh->do("SET search_path TO $S"); } else { $debug and Test::More::diag 'Attempting to cleanup database'; cleanup_database($dbh); eval { $dbh->do("CREATE SCHEMA $S"); }; $@ and $debug and Test::More::diag "Create schema error: $@"; if ($@ =~ /Permission denied/ and $helpconnect != 16) { ## Okay, this ain't gonna work, let's try initdb goto INITDB; } $@ and return $helpconnect, $@, undef; $dbh->do("SET search_path TO $S"); eval { $dbh->do('CREATE SEQUENCE dbd_pg_testsequence'); }; $@ and Test::More::BAIL_OUT('Failed to create test sequence'); # If you add columns to this, please do not use reserved words! $SQL = q{ CREATE TABLE dbd_pg_test ( id integer not null primary key, lii integer unique not null default nextval('dbd_pg_testsequence'), pname varchar(20) default 'Testing Default' , val text, score float CHECK(score IN ('1','2','3', '999')), Fixed character(5) CHECK (lii > -777), pdate timestamp default now(), testarray text[][], testarray2 int[], testarray3 bool[], "CaseTest" boolean CHECK (score < 888), expo numeric(6,2), bytetest bytea, bytearray bytea[] ) }; $dbh->{Warn} = 0; eval { $dbh->do($SQL); }; $@ and Test::More::BAIL_OUT('Failed to create test sequence'); $dbh->{Warn} = 1; $dbh->do(q{COMMENT ON COLUMN dbd_pg_test.id IS 'Bob is your uncle'}); } ## end setup $dbh->commit() unless $dbh->{AutoCommit}; if ($arg->{disconnect}) { $dbh->disconnect(); return $helpconnect, '', undef; } $dbh->{AutoCommit} = 0 unless $arg->{AutoCommit}; return $helpconnect, '', $dbh; } ## end of connect_database sub is_super { return $superuser; } sub get_test_settings { ## Returns test database information from the testfile if it exists ## Defaults to ENV variables or blank ## Find the best candidate for the pg_ctl program my $pg_ctl = 'pg_ctl'; my $initdb = 'default'; if (exists $ENV{POSTGRES_HOME} and -e "$ENV{POSTGRES_HOME}/bin/pg_ctl") { $pg_ctl = "$ENV{POSTGRES_HOME}/bin/pg_ctl"; $initdb = "$ENV{POSTGRES_HOME}/bin/initdb"; } elsif (exists $ENV{DBDPG_INITDB} and -e $ENV{DBDPG_INITDB}) { ($pg_ctl = $ENV{DBDPG_INITDB}) =~ s/initdb/pg_ctl/; } elsif (exists $ENV{PGINITDB} and -e $ENV{PGINITDB}) { ($pg_ctl = $ENV{PGINITDB}) =~ s/initdb/pg_ctl/; } my ($testdsn, $testuser, $testdir, $error) = ('','','','?'); my ($helpconnect, $su, $uid, $version) = (0,'','',0); my $inerror = 0; if (-e $helpfile and ! $ENV{DBDPG_TEST_NOHELPFILE}) { open $fh, '<', $helpfile or die qq{Could not open "$helpfile": $!\n}; while (<$fh>) { if ($inerror) { $error .= "\n$_"; } /DSN: (.+)/ and $testdsn = $1; /User: (\S+)/ and $testuser = $1; /Helpconnect: ([0-9]+)/ and $helpconnect = $1; /Testowner: (\w+)/ and $su = $1; /Testowneruid: ([0-9]+)/ and $uid = $1; /Testdir: (.+)/ and $testdir = $1; /pg_ctl: (.+)/ and $pg_ctl = $1; /initdb: (.+)/ and $initdb = $1; /ERROR: (.+)/ and $error = $1 and $inerror = 1; /Version: (.+)/ and $version = $1; } close $fh or die qq{Could not close "$helpfile": $!\n}; } if (!$testdir) { my $dir = getcwd(); $testdir = exists $ENV{DBDPG_TEMPDIR} ? File::Temp::tempdir("$ENV{DBDPG_TEMPDIR}/testdb_XXXXXX", CLEANUP => 0) : "$dir/testdb"; } ## Allow forcing of ENV variables if ($ENV{DBDPG_TEST_ALWAYS_ENV}) { $testdsn = $ENV{DBI_DSN} || ''; $testuser = $ENV{DBI_USER} || ''; } return $testdsn, $testuser, $helpconnect, $su, $uid, $testdir, $pg_ctl, $initdb, $error, $version; } ## end of get_test_settings sub schema_exists { my ($dbh,$schema) = @_; my $SQL = 'SELECT 1 FROM pg_catalog.pg_namespace WHERE nspname = ?'; my $sth = $dbh->prepare_cached($SQL); my $count = $sth->execute($schema); $sth->finish(); return $count < 1 ? 0 : 1; } ## end of schema_exists sub relation_exists { my ($dbh,$schema,$name) = @_; my $SQL = 'SELECT 1 FROM pg_catalog.pg_class c, pg_catalog.pg_namespace n '. 'WHERE n.oid=c.relnamespace AND n.nspname = ? AND c.relname = ?'; my $sth = $dbh->prepare_cached($SQL); my $count = $sth->execute($schema,$name); $sth->finish(); return $count < 1 ? 0 : 1; } ## end of relation_exists sub operator_exists { my ($dbh,$opname,$leftarg,$rightarg) = @_; my $schema = 'dbd_pg_testschema'; my $SQL = 'SELECT 1 FROM pg_operator o, pg_namespace n '. 'WHERE oprname=? AND oprleft = ?::regtype AND oprright = ?::regtype'. ' AND o.oprnamespace = n.oid AND n.nspname = ?'; my $sth = $dbh->prepare_cached($SQL); my $count = $sth->execute($opname,$leftarg,$rightarg,$schema); $sth->finish(); return $count < 1 ? 0 : 1; } ## end of operator_exists sub cleanup_database { ## Clear out any testing objects in the current database my $dbh = shift; return unless defined $dbh and ref $dbh and $dbh->ping(); ## For now, we always run and disregard the type $dbh->rollback() if ! $dbh->{AutoCommit}; for my $name (@matviews) { my $schema = ($name =~ s/(.+)\.(.+)/$2/) ? $1 : $S; next if ! relation_exists($dbh,$schema,$name); $dbh->do("DROP MATERIALIZED VIEW $schema.$name"); } for my $name (@views) { my $schema = ($name =~ s/(.+)\.(.+)/$2/) ? $1 : $S; next if ! relation_exists($dbh,$schema,$name); $dbh->do("DROP VIEW $schema.$name"); } for my $name (@operators) { my ($opname,$leftarg,$rightarg) = split /\./ => $name; next if ! operator_exists($dbh,$opname,$leftarg,$rightarg); $dbh->do("DROP OPERATOR dbd_pg_testschema.$opname($leftarg,$rightarg)"); } for my $name (@tables) { my $schema = ($name =~ s/(.+)\.(.+)/$2/) ? $1 : $S; next if ! relation_exists($dbh,$schema,$name); $dbh->do("DROP TABLE $schema.$name"); } for my $name (@sequences) { my $schema = ($name =~ s/(.+)\.(.+)/$2/) ? $1 : $S; next if ! relation_exists($dbh,$schema,$name); $dbh->do("DROP SEQUENCE $schema.$name"); } for my $schema (@schemas) { next if ! schema_exists($dbh,$schema); $dbh->do("DROP SCHEMA $schema CASCADE"); } $dbh->commit() if ! $dbh->{AutoCommit}; return; } ## end of cleanup_database sub shutdown_test_database { my ($testdsn,$testuser,$helpconnect,$su,$uid,$testdir,$pg_ctl,$initdb) = get_test_settings(); ## no critic (Variables::ProhibitUnusedVarsStricter) if (-e $testdir and -e "$testdir/data/postmaster.pid") { my $COM = qq{$pg_ctl -D $testdir/data -m fast stop}; my $olddir = getcwd; if ($su) { $COM = qq{su $su -m -c "$COM"}; chdir $testdir; } eval { qx{$COM}; }; $su and chdir $olddir; } ## Remove the test directory entirely return if $ENV{DBDPG_TESTINITDB}; return if ! eval { require File::Path; 1; }; File::Path::rmtree($testdir); return; } ## end of shutdown_test_database 1; DBD-Pg-3.20.2/t/03dbmethod.t0000644000175000017500000032163115166170753013567 0ustar greggreg#!perl ## Test of the database handle methods ## The following methods are *not* (explicitly) tested here: ## "take_imp_data" "pg_server_trace" "pg_server_untrace" ## "data_sources" (see 04misc.t) ## "disconnect" (see 01connect.t) ## "pg_savepoint" "pg_release" "pg_rollback_to" (see 20savepoints.t) ## "pg_getline" "pg_endcopy" "pg_getcopydata" "pg_getcopydata_async" (see 07copy.t) ## "pg_putline" "pg_putcopydata" "pg_putcopydata_async (see 07copy.t) ## "pg_cancel" "pg_ready" "pg_result" (see 08async.t) use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Data::Dumper; use Test::More; use Config; use DBI ':sql_types'; use DBD::Pg ':pg_types'; use Fcntl ':seek'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } my $superuser = is_super(); isnt ($dbh, undef, 'Connect to database for database handle method testing'); # silence notices about implicitly created and dropped objects $dbh->do('set client_min_messages=warning'); my $test_table = 'dbd_pg_test'; my $space_table = q{dbd_pg_test Table}; my $missing_table = 'dbd_pg_no_such_table'; my $test_schema = 'dbd_pg_testschema'; my $missing_schema = 'dbd_pg_no_such_schema'; my $test_table_no_pk = 'dbd_pg_test_no_pk'; my $test_table_combo_pk = 'dbd_pg_test_combo_pk'; my ($pglibversion,$pgversion) = ($dbh->{pg_lib_version},$dbh->{pg_server_version}); my ($schema,$schema2,$schema3) = ('dbd_pg_testschema', 'dbd_pg_testschema2', 'dbd_pg_testschema3'); my ($table1,$table2,$table3,$table4) = ('dbd_pg_test1','dbd_pg_test2','dbd_pg_test3','dbd_pg_test4'); my ($sequence2,$sequence3,$sequence4) = ('dbd_pg_testsequence2','dbd_pg_testsequence3','dbd_pg_testsequence4'); my ($SQL, $sth, $result, @results, $expected, $warning, $rows, $t, $info); # Quick simple "tests" $dbh->do(q{}); ## This used to break, so we keep it as a test... $SQL = q{SELECT '2529DF6AB8F79407E94445B4BC9B906714964AC8' FROM dbd_pg_test WHERE id=?}; $sth = $dbh->prepare($SQL); $sth->finish(); $sth = $dbh->prepare_cached($SQL); $sth->finish(); $t = 'Cannot prepare empty statement'; $SQL = q{}; eval { $dbh->prepare($SQL) }; like ($@, qr{^Cannot prepare empty statement}, $t); # Populate the testing table for later use $SQL = 'INSERT INTO dbd_pg_test(id,val) VALUES (?,?)'; $sth = $dbh->prepare($SQL); $sth->bind_param(1, 1, SQL_INTEGER); $sth->execute(10,'Roseapple'); $sth->execute(11,'Pineapple'); $sth->execute(12,'Kiwi'); # # Test of the "last_insert_id" database handle method # $t='DB handle method "last_insert_id" fails when no arguments are given'; $dbh->commit(); eval { $dbh->last_insert_id(undef,undef,undef,undef); }; like ($@, qr{last_insert_id.*least}, $t); $t='DB handle method "last_insert_id" fails when given a non-existent sequence'; eval { $dbh->last_insert_id(undef,undef,undef,undef,{sequence=>'dbd_pg_nonexistentsequence_test'}); }; is ($dbh->state, '42P01', $t); $t='DB handle method "last_insert_id" fails when called in a failed transaction'; eval { $dbh->last_insert_id(undef,'someschema','dbd_pg_nonexistenttable_test',undef); }; is ($dbh->state, '25P02', $t); $t='DB handle method "last_insert_id" fails when given a non-existent table'; $dbh->rollback(); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef); }; like ($@, qr{not find}, $t); $t='DB handle method "last_insert_id" fails when given an arrayref as last argument'; $dbh->rollback(); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef,[]); }; like ($@, qr{last_insert_id.*hashref}, $t); $t='DB handle method "last_insert_id" works when given an empty sequence argument'; $dbh->rollback(); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef,{sequence=>''}); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" fails when given a table with no primary key'; $dbh->rollback(); $dbh->do('CREATE TEMP TABLE dbd_pg_test_temp(a int)'); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_test_temp',undef); }; like ($@, qr{last_insert_id}, $t); my $parent = 'dbd_pg_test_parent'; my $parent2 = 'dbd_pg_test_parent2'; my $kid = 'dbd_pg_test_inherit'; $dbh->do("CREATE TABLE $schema.$parent(id SERIAL primary key)"); $dbh->do("CREATE TABLE $schema.$parent2(id2 SERIAL primary key)"); $dbh->do("CREATE TABLE $schema.$kid (foo text) INHERITS ($parent,$parent2)"); $dbh->do("INSERT INTO $parent DEFAULT VALUES"); $t='DB handle method "last_insert_id" works for a normal table'; $result = ''; eval { $result = $dbh->last_insert_id(undef,undef,$parent,undef); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" returns correct value for a normal table'; is ($result, 1, $t); $dbh->do("INSERT INTO $kid DEFAULT VALUES"); $t='DB handle method "last_insert_id" works for an inherited table'; $result = ''; eval { $result = $dbh->last_insert_id(undef,undef,$kid,undef); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" returns correct value for an inherited table'; is ($result, 2, $t); $t='DB handle method "last_insert_id" returns expected error for an inherited table with no PK'; my $parent3 = 'dbd_pg_test_parent3'; my $kid3 = 'dbd_pg_test_inherit3'; $dbh->do("CREATE TABLE $schema.$parent3 (id INTEGER)"); $dbh->do("CREATE TABLE $schema.$kid3 (foo text) INHERITS ($parent3)"); $dbh->do("INSERT INTO $parent3 DEFAULT VALUES"); eval { $result = $dbh->last_insert_id(undef,undef,$kid3,undef); }; like ($@, qr/No suitable column/, $t); $SQL = 'CREATE TEMP TABLE foobar AS SELECT * FROM pg_class LIMIT 3'; $t='DB handle method "do" returns correct count with CREATE AS SELECT'; $dbh->rollback(); $result = $dbh->do($SQL); $expected = $pgversion >= 90000 ? 3 : '0E0'; is ($result, $expected, $t); $t='DB handle method "execute" returns correct count with CREATE AS SELECT'; $dbh->rollback(); $sth = $dbh->prepare($SQL); $result = $sth->execute(); $expected = $pgversion >= 90000 ? 3 : '0E0'; is ($result, $expected, $t); $t='DB handle method "do" works properly with passed-in array with undefined entries'; $dbh->rollback(); $dbh->do('CREATE TEMP TABLE foobar (id INT, p TEXT[])'); my @aa; $aa[2] = 'apples'; eval { $dbh->do('INSERT INTO foobar (p) VALUES (?)', undef, \@aa); }; is ($@, q{}, $t); $SQL = 'SELECT * FROM foobar'; $result = $dbh->selectall_arrayref($SQL)->[0]; is_deeply ($result, [undef,[undef,undef,'apples']], $t); $t='DB handle method "last_insert_id" works when given a valid sequence and an invalid table'; $dbh->rollback(); eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef,{sequence=>'dbd_pg_testsequence'}); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" returns a numeric value'; like ($result, qr{^[0-9]+$}, $t); $t='DB handle method "last_insert_id" works when given a valid sequence and an invalid table'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef, 'dbd_pg_testsequence'); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" returns a numeric value'; like ($result, qr{^[0-9]+$}, $t); $t='DB handle method "last_insert_id" works when given a valid table'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" works when given an empty attrib'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef,''); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" works when called twice (cached) given a valid table'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef); }; is ($@, q{}, $t); $dbh->do("CREATE SCHEMA $schema2"); $dbh->do("CREATE SEQUENCE $schema2.$sequence2"); $dbh->do("CREATE SEQUENCE $schema.$sequence4"); $dbh->do("CREATE TABLE $schema2.$table2(a INTEGER PRIMARY KEY NOT NULL DEFAULT nextval('$schema2.$sequence2'))"); $dbh->do("CREATE TABLE $schema.$table2(a INTEGER PRIMARY KEY NOT NULL DEFAULT nextval('$schema.$sequence4'))"); $dbh->do("INSERT INTO $schema2.$table2 DEFAULT VALUES"); $t='DB handle method "last_insert_id" works when called with a schema not in the search path'; eval { $result = $dbh->last_insert_id(undef,$schema2,$table2,undef); }; is ($@, q{}, $t); $t='search_path respected when using last_insert_id with no cache (first table)'; $dbh->commit(); $dbh->do("SELECT setval('$schema2.$sequence2',200)"); $dbh->do("SELECT setval('$schema.$sequence4',100)"); $dbh->do("SET search_path = $schema,$schema2"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef,{pg_cache=>0}); }; is ($@, q{}, $t); is ($result, 100, $t); $t='search_path respected when using last_insert_id with no cache (second table)'; $dbh->commit(); $dbh->do("SET search_path = $schema2,$schema"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef,{pg_cache=>0}); }; is ($@, q{}, $t); is ($result, 200, $t); $t='Setting cache on (explicit) returns last result, even if search_path changes'; $dbh->do("SET search_path = $schema,$schema2"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef,{pg_cache=>1}); }; is ($@, q{}, $t); is ($result, 200, $t); $t='Setting cache on (implicit) returns last result, even if search_path changes'; $dbh->do("SET search_path = $schema,$schema2"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef); }; is ($@, q{}, $t); is ($result, 200, $t); $dbh->commit(); SKIP: { $t='DB handle method "last_insert_id" fails when the sequence name is changed and cache is used'; if ($pgversion < 80300) { $dbh->do("DROP TABLE $schema2.$table2"); $dbh->do("DROP SEQUENCE $schema2.$sequence2"); skip ('Cannot test sequence rename on pre-8.3 servers', 1); } $dbh->do("ALTER SEQUENCE $schema2.$sequence2 RENAME TO $sequence3"); $dbh->commit(); eval { $dbh->last_insert_id(undef,$schema2,$table2,undef); }; like ($@, qr{last_insert_id}, $t); $dbh->rollback(); $t='DB handle method "last_insert_id" works when the sequence name is changed and cache is turned off'; $dbh->commit(); eval { $dbh->last_insert_id(undef,$schema2,$table2,undef, {pg_cache=>0}); }; is ($@, q{}, $t); $dbh->do("DROP TABLE $schema2.$table2"); $dbh->do("DROP SEQUENCE $schema2.$sequence3"); } SKIP: { skip('Cannot test GENERATED AS IDENTITY columns on pre-10 servers', 1) if $pgversion < 100000; for my $WHEN ('BY DEFAULT', 'ALWAYS') { $t=qq{DB handle method "last_insert_id" works on GENERATED $WHEN AS IDENTITY column}; $dbh->do(qq{CREATE TABLE $schema."dbd_pg_test_identity_'$WHEN'" ( genid INTEGER PRIMARY KEY GENERATED $WHEN AS IDENTITY (START WITH 1), otheruniq INTEGER UNIQUE GENERATED $WHEN AS IDENTITY (START WITH 10), otherid INTEGER GENERATED $WHEN AS IDENTITY (START WITH 20) )}); my $returned_id = $dbh->selectrow_array(qq{INSERT INTO "dbd_pg_test_identity_'$WHEN'" DEFAULT VALUES RETURNING genid}); my $last_insert_id = eval { $dbh->last_insert_id(undef, $schema, qq{dbd_pg_test_identity_'$WHEN'}, undef, undef); }; is ($@, q{}, $t); $t=qq{DB handle method "last_insert_id" returns PK value from multiple GENERATED $WHEN AS IDENTITY columns}; is ($last_insert_id, $returned_id, $t); $dbh->do(qq{DROP TABLE $schema."dbd_pg_test_identity_'$WHEN'"}); } } $t='DB handle method "last_insert_id" works when the sequence name needs quoting'; $dbh->do(q{CREATE SEQUENCE "dbd_pg_test_'seq'"}); $dbh->do(q{CREATE TABLE "dbd_pg_test_'table'" (id integer unique default nextval($$dbd_pg_test_'seq'$$))}); $dbh->do(q{INSERT INTO "dbd_pg_test_'table'" DEFAULT VALUES}); eval { $dbh->last_insert_id(undef, undef, q{dbd_pg_test_'table'}, undef, undef) }; is ($@, q{}, $t); $dbh->do(q{DROP TABLE "dbd_pg_test_'table'"}); $dbh->do(q{DROP SEQUENCE "dbd_pg_test_'seq'"}); $dbh->do("DROP SCHEMA $schema2"); $dbh->do("DROP TABLE $table2"); $dbh->do("DROP SEQUENCE $sequence4"); # # Test of the "selectrow_array" database handle method # $t='DB handle method "selectrow_array" works'; $SQL = 'SELECT id FROM dbd_pg_test ORDER BY id'; @results = $dbh->selectrow_array($SQL); $expected = [10]; is_deeply (\@results, $expected, $t); # # Test of the "selectrow_arrayref" database handle method # $t='DB handle method "selectrow_arrayref" works'; $result = $dbh->selectrow_arrayref($SQL); is_deeply ($result, $expected, $t); $t='DB handle method "selectrow_arrayref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectrow_arrayref($sth); is_deeply ($result, $expected, $t); # # Test of the "selectrow_hashref" database handle method # $t='DB handle method "selectrow_hashref" works'; $result = $dbh->selectrow_hashref($SQL); $expected = {id => 10}; is_deeply ($result, $expected, $t); $t='DB handle method "selectrow_hashref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectrow_hashref($sth); is_deeply ($result, $expected, $t); # # Test of the "selectall_arrayref" database handle method # $t='DB handle method "selectall_arrayref" works'; $result = $dbh->selectall_arrayref($SQL); $expected = [[10],[11],[12]]; is_deeply ($result, $expected, $t); $t='DB handle method "selectall_arrayref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectall_arrayref($sth); is_deeply ($result, $expected, $t); $t='DB handle method "selectall_arrayref" works with the MaxRows attribute'; $result = $dbh->selectall_arrayref($SQL, {MaxRows => 2}); $expected = [[10],[11]]; is_deeply ($result, $expected, $t); $t='DB handle method "selectall_arrayref" works with the Slice attribute'; $SQL = 'SELECT id, val FROM dbd_pg_test ORDER BY id'; $result = $dbh->selectall_arrayref($SQL, {Slice => [1]}); $expected = [['Roseapple'],['Pineapple'],['Kiwi']]; is_deeply ($result, $expected, $t); # # Test of the "selectall_hashref" database handle method # $t='DB handle method "selectall_hashref" works'; $result = $dbh->selectall_hashref($SQL,'id'); $expected = {10=>{id =>10,val=>'Roseapple'},11=>{id=>11,val=>'Pineapple'},12=>{id=>12,val=>'Kiwi'}}; is_deeply ($result, $expected, $t); $t='DB handle method "selectall_hashref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectall_hashref($sth,'id'); is_deeply ($result, $expected, $t); # # Test of the "selectcol_arrayref" database handle method # $t='DB handle method "selectcol_arrayref" works'; $result = $dbh->selectcol_arrayref($SQL); $expected = [10,11,12]; is_deeply ($result, $expected, $t); $t='DB handle method "selectcol_arrayref" works with a prepared statement handle'; $result = $dbh->selectcol_arrayref($sth); is_deeply ($result, $expected, $t); $t='DB handle method "selectcol_arrayref" works with the Columns attribute'; $result = $dbh->selectcol_arrayref($SQL, {Columns=>[2,1]}); $expected = ['Roseapple',10,'Pineapple',11,'Kiwi',12]; is_deeply ($result, $expected, $t); $t='DB handle method "selectcol_arrayref" works with the MaxRows attribute'; $result = $dbh->selectcol_arrayref($SQL, {Columns=>[2], MaxRows => 1}); $expected = ['Roseapple']; is_deeply ($result, $expected, $t); # # Test of the "commit" and "rollback" database handle methods # { local $SIG{__WARN__} = sub { $warning = shift; }; $dbh->{AutoCommit}=0; $t='DB handle method "commit" gives no warning when AutoCommit is off'; $warning=q{}; $dbh->commit(); ok (! length $warning, $t); $t='DB handle method "rollback" gives no warning when AutoCommit is off'; $warning=q{}; $dbh->rollback(); ok (! length $warning, $t); $t='DB handle method "commit" returns true'; ok ($dbh->commit, $t); $t='DB handle method "rollback" returns true'; ok ($dbh->rollback, $t); $t='DB handle method "commit" gives a warning when AutoCommit is on'; $dbh->{AutoCommit}=1; $warning=q{}; $dbh->commit(); ok (length $warning, $t); $t='DB handle method "rollback" gives a warning when AutoCommit is on'; $warning=q{}; $dbh->rollback(); ok (length $warning, $t); ## Use deferred constraint so a commit will fail $dbh->{AutoCommit} = 0; $dbh->do("CREATE TABLE $schema.$table4 (id INTEGER PRIMARY KEY, val INTEGER)"); $dbh->do("ALTER TABLE $schema.$table4 ADD CONSTRAINT ref FOREIGN KEY (val) REFERENCES $table4(id) DEFERRABLE INITIALLY DEFERRED"); $t = 'Insert succeeds with broken foreign key because it is deferred'; eval { $dbh->do("INSERT INTO $schema.$table4 VALUES (1,2)"); }; is ($@, '', $t); $t = 'Before a failed commit, AutoCommit is false'; is ($dbh->{AutoCommit}, '', $t); $t = 'Commit fails because of a deferred foreign key'; eval { $dbh->commit(); }; like ($@, qr/ERROR/, $t); $t = 'After a failed commit, AutoCommit is still false'; is ($dbh->{AutoCommit}, '', $t); $dbh->rollback(); } # # Test of the "begin_work" database handle method # $t='DB handle method "begin_work" gives a warning when AutoCommit is on'; $dbh->{AutoCommit}=0; eval { $dbh->begin_work(); }; isnt ($@, q{}, $t); $t='DB handle method "begin_work" gives no warning when AutoCommit is off'; $dbh->{AutoCommit}=1; eval { $dbh->begin_work(); }; is ($@, q{}, $t); ok (!$dbh->{AutoCommit}, 'DB handle method "begin_work" sets AutoCommit to off'); $t='DB handle method "commit" after "begin_work" sets AutoCommit to on'; $dbh->commit(); ok ($dbh->{AutoCommit}, $t); $t='DB handle method "begin_work" gives no warning when AutoCommit is off'; $dbh->{AutoCommit}=1; eval { $dbh->begin_work(); }; is ($@, q{}, $t); $t='DB handle method "begin_work" sets AutoCommit to off'; ok (!$dbh->{AutoCommit}, $t); $t='DB handle method "rollback" after "begin_work" sets AutoCommit to on'; $dbh->rollback(); ok ($dbh->{AutoCommit}, $t); $dbh->{AutoCommit}=0; # # Test of the "get_info" database handle method # $t='DB handle method "get_info" with no arguments gives an error'; eval { $dbh->get_info(); }; isnt ($@, q{}, $t); $t='DB handle method "get_info" with undef argument returns undef'; $result = $dbh->get_info('foobar'); is ($result, undef, $t); my %get_info = ( SQL_MAX_DRIVER_CONNECTIONS => 0, SQL_DRIVER_NAME => 6, SQL_DBMS_NAME => 17, SQL_DBMS_VERSION => 18, SQL_IDENTIFIER_QUOTE_CHAR => 29, SQL_CATALOG_NAME_SEPARATOR => 41, SQL_USER_NAME => 47, # this also tests the dynamic attributes that run SQL SQL_COLLATION_SEQ => 10004, SQL_DATABASE_NAME => 16, SQL_SERVER_NAME => 13, ); for (keys %get_info) { $t=qq{DB handle method "get_info" works with a value of "$_"}; my $back = $dbh->get_info($_); ok (defined $back, $t); $t=qq{DB handle method "get_info" works with a value of "$get_info{$_}"}; my $forth = $dbh->get_info($get_info{$_}); ok (defined $forth, $t); $t=q{DB handle method "get_info" returned matching values}; is ($back, $forth, $t); } # Make sure SQL_MAX_COLUMN_NAME_LEN looks normal $t='DB handle method "get_info" returns a valid looking SQL_MAX_COLUMN_NAME_LEN string}'; my $namedatalen = $dbh->get_info('SQL_MAX_COLUMN_NAME_LEN'); cmp_ok ($namedatalen, '>=', 63, $t); # Make sure odbcversion looks normal $t='DB handle method "get_info" returns a valid looking ODBCVERSION string}'; my $odbcversion = $dbh->get_info(18); like ($odbcversion, qr{^([1-9][0-9]|[0-9][1-9])\.[0-9][0-9]\.[0-9][0-9]00$}, $t); # Make sure odbcversion looks abnormal $t='DB handle method "get_info" returns zeroes if the version cannot be parsed}'; my $oldversion = $dbh->{private_dbdpg}{version}; $dbh->{private_dbdpg}{version} = 'FOO'; $odbcversion = $dbh->get_info(18); $dbh->{private_dbdpg}{version} = $oldversion; is ($odbcversion, '00.00.0000', $t); # Testing max connections is good as this info is dynamic $t='DB handle method "get_info" returns a number for SQL_MAX_DRIVER_CONNECTIONS'; my $maxcon = $dbh->get_info('SQL_MAX_DRIVER_CONNECTIONS'); like ($maxcon, qr{^[0-9]+$}, $t); # Test the DBDVERSION $t='DB handle method "get_info" returns a number for SQL_DRIVER_VER'; $result = $dbh->get_info(7); like ($result, qr{^[0-9]{2}\.[0-9]{2}\.[0-9]{4}$}, $t); # Test the SQL_KEYWORDS $t='DB handle method "get_info" returns expected items for SQL_KEYWORDS'; $result = $dbh->get_info('SQL_KEYWORDS'); like ($result, qr{CONCURRENTLY}, $t); $t='DB handle method "get_info" returns expected items for SQL_KEYWORDS via "89"'; $result = $dbh->get_info(89); like ($result, qr{CONCURRENTLY}, $t); $t='DB handle method "get_info" returns expected result for SQL_DEFAULT_TXN_ISOLATION'; $result = $dbh->get_info('SQL_DEFAULT_TXN_ISOLATION'); ok ((2==$result or 8==$result), $t); $t='DB handle method "get_info" returns correct string for SQL_DATA_SOURCE_READ_ONLY when "on"'; $dbh->do(q{SET transaction_read_only = 'on'}); is ($dbh->get_info(25), 'Y', $t); $t='DB handle method "get_info" returns correct string for SQL_DATA_SOURCE_READ_ONLY when "off"'; ## Recent versions of Postgres are very fussy: must rollback $dbh->rollback(); $dbh->do(q{SET transaction_read_only = 'off'}); is ($dbh->get_info(25), 'N', $t); # # Test of the "table_info" database handle method # $t='DB handle method "table_info" works when called with empty arguments'; $sth = $dbh->table_info('', '', 'dbd_pg_test', ''); is ($sth->fetch->[2], 'dbd_pg_test', $t); $t='DB handle method "table_info" works when called with \'%\' arguments'; $sth = $dbh->table_info('%', '%', 'dbd_pg_test', '%'); is ($sth->fetch->[2], 'dbd_pg_test', $t); $t=q{DB handle method "table_info" works when called with a non-regex-containing schema}; $sth = $dbh->table_info( '', 'dbdpgtest', '', ''); is ($sth->rows(), 0, $t); $t=q{DB handle method "table_info" works when called with a non-regex-containing table}; $sth = $dbh->table_info( '', '', 'dbdpgtest', ''); is ($sth->rows(), 0, $t); $t=q{DB handle method "table_info" works when called with a 'TABLE' last argument}; $sth = $dbh->table_info( '', $schema, '', q{'TABLE'}); # Check required minimum fields $t='DB handle method "table_info" returns fields required by DBI'; $result = $sth->fetchall_arrayref({}); my @required = (qw(TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS)); my %missing; for my $r (@$result) { for (@required) { $missing{$_}++ if ! exists $r->{$_}; } } is_deeply (\%missing, {}, $t); ## Check some of the returned fields: $result = $result->[0]; is ($result->{TABLE_CAT}, $dbh->{pg_db}, 'DB handle method "table_info" returns proper TABLE_CAT'); is ($result->{TABLE_NAME}, 'dbd_pg_test', 'DB handle method "table_info" returns proper TABLE_NAME'); is ($result->{TABLE_TYPE}, 'TABLE', 'DB handle method "table_info" returns proper TABLE_TYPE'); $t='DB handle method "table_info" returns zero rows when given an invalid type argument'; $sth = $dbh->table_info(undef,undef,undef,'DUMMY'); $rows = $sth->rows(); is ($rows, 0, $t); $t=q{DB handle method "table_info" returns rows when given a 'VIEW' type argument}; $sth = $dbh->table_info(undef,undef,undef,'VIEW'); my $count_views = $sth->rows(); cmp_ok ($count_views, '>', 1, $t); $t=q{DB handle method "table_info" returns no rows when given a 'VIEW' type argument for the test schema}; $sth = $dbh->table_info(undef,$schema,undef,'VIEW'); is ($sth->rows, 0, $t); $t=q{DB handle method "table_info" returns one row when given a 'TABLE,VIEW' type argument for the test schema}; $sth = $dbh->table_info(undef,$schema,undef,'TABLE,VIEW'); is ($sth->rows, 1, $t); $dbh->do('CREATE VIEW dbd_pg_view AS SELECT sum(reltuples) AS tonsoftups FROM pg_class'); $t=q{DB handle method "table_info" returns no rows when given a 'VIEW' type argument for the test schema}; $sth = $dbh->table_info(undef,$schema,undef,'VIEW'); is ($sth->rows, 1, $t); $t=q{DB handle method "table_info" returns one row when given a 'TABLE,VIEW' type argument for the test schema}; $sth = $dbh->table_info(undef,$schema,undef,'TABLE,VIEW'); is ($sth->rows, 2, $t); $t=q{DB handle method "table_info" returns same rows when given a 'TABLE,VIEW,SYSTEM TABLE,SYSTEM VIEW' type argument}; $sth = $dbh->table_info(undef,$schema,undef,'TABLE,VIEW,SYSTEM TABLE,SYSTEM VIEW'); is ($sth->rows, 2, $t); $t=q{DB handle method "table_info" returns more rows when given a 'TABLE,VIEW,SYSTEM TABLE,SYSTEM VIEW' type argument}; $sth = $dbh->table_info(undef,undef,undef,'TABLE,VIEW,SYSTEM TABLE,SYSTEM VIEW'); ## Should be at least 90 system tables and views cmp_ok ($sth->rows(), '>', 90, $t); $dbh->do('CREATE TEMP TABLE dbd_pg_local_temp (i INT)'); $t=q{DB handle method "table_info" returns no 'LOCAL TEMPORARY' rows for specific schema}; $sth = $dbh->table_info(undef,$schema,undef,'LOCAL TEMPORARY'); is ($sth->rows(), 0, $t); $t=q{DB handle method "table_info" returns one 'LOCAL TEMPORARY' row for specific table}; $sth = $dbh->table_info(undef,undef,'dbd_pg_local_temp','LOCAL TEMPORARY'); is ($sth->rows(), 1, $t); $t=q{DB handle method "table_info" returns correct 'LOCAL TEMPORARY' rows across whole system}; $sth = $dbh->table_info(undef,undef,undef,'LOCAL TEMPORARY'); my $total_temp = $sth->rows(); $dbh->do('DROP TABLE dbd_pg_local_temp'); $sth = $dbh->table_info(undef,undef,undef,'LOCAL TEMPORARY'); is ($sth->rows(), $total_temp-1, $t); SKIP: { if ($pgversion < 90300) { skip ('Cannot test table_info for materialized views unless database if 9.3 or higher', 1); } $sth = $dbh->table_info(undef,undef,undef,'MATERIALIZED VIEW'); my $total_matviews = $sth->rows(); $t=q{DB handle method "table_info" returns zero 'MATERIALIZED VIEW' rows for test schema}; $sth = $dbh->table_info(undef,$schema,undef,'MATERIALIZED VIEW'); is ($sth->rows(), 0, $t); $dbh->do("CREATE MATERIALIZED VIEW $schema.dbd_pg_matview AS SELECT 123 WITH NO DATA"); $t=q{DB handle method "table_info" returns one 'MATERIALIZED VIEW' rows for test schema}; $sth = $dbh->table_info(undef,$schema,undef,'MATERIALIZED VIEW'); is ($sth->rows(), 1, $t); $t=q{DB handle method "table_info" returns expected 'MATERIALIZED VIEW' rows}; $sth = $dbh->table_info(undef,undef,undef,'MATERIALIZED VIEW'); is ($sth->rows(), $total_matviews+1, $t); } SKIP: { if ($pgversion < 90100) { skip ('Cannot test table_info for foreign tables unless database is 9.1 or higher', 1); } ## We can check for finer-grained access in more recent versions, but this is good enough: $superuser or skip ('Cannot test foreign tables unless a superuser', 1); $sth = $dbh->table_info(undef,undef,undef,'FOREIGN TABLE'); my $total_ftables = $sth->rows(); $t=q{DB handle method "table_info" returns zero 'FOREIGN TABLE' rows for test schema}; $sth = $dbh->table_info(undef,$schema,undef,'FOREIGN TABLE'); is ($sth->rows(), 0, $t); $dbh->do('DROP FOREIGN DATA WRAPPER IF EXISTS dbd_pg_testfdw CASCADE'); $dbh->do('CREATE FOREIGN DATA WRAPPER dbd_pg_testfdw'); $dbh->do('CREATE SERVER dbd_pg_testserver FOREIGN DATA WRAPPER dbd_pg_testfdw'); $dbh->do("CREATE FOREIGN TABLE $schema.dbd_pg_testforeign (c1 int) SERVER dbd_pg_testserver"); $t=q{DB handle method "table_info" returns one 'FOREIGN TABLE' rows for test schema}; $sth = $dbh->table_info(undef,$schema,undef,'FOREIGN TABLE'); is ($sth->rows(), 1, $t); $t=q{DB handle method "table_info" returns expected 'FOREIGN TABLE' rows}; $sth = $dbh->table_info(undef,undef,undef,'FOREIGN TABLE'); is ($sth->rows(), $total_ftables+1, $t); $dbh->rollback(); } # Test listing catalog names $t='DB handle method "table_info" works when called with a catalog of %'; $sth = $dbh->table_info('%', '', ''); ok ($sth, $t); # Test listing schema names $t='DB handle method "table_info" works when called with a schema of %'; $sth = $dbh->table_info('', '%', ''); ok ($sth, $t); { # Test listing table types $expected = ['LOCAL TEMPORARY', 'SYSTEM TABLE', 'SYSTEM VIEW', 'MATERIALIZED VIEW', 'SYSTEM MATERIALIZED VIEW', 'FOREIGN TABLE', 'SYSTEM FOREIGN TABLE', 'TABLE', 'VIEW',]; $t='DB handle method "table_info" works when called with a type of %'; $sth = $dbh->table_info('', '', '', '%'); ok ($sth, $t); $t='DB handle method "table_info" type list returns all expected types'; my %advertised = map { $_->[0] => 1 } @{ $sth->fetchall_arrayref([3]) }; is_deeply ([sort keys %advertised], [sort @$expected], $t); $t='DB handle method "table_info" object list returns no unadvertised types'; $sth = $dbh->table_info('', '', '%'); my %surprises = map { $_->[0] => 1 } grep { ! $advertised{$_->[0]} } @{ $sth->fetchall_arrayref([3]) }; is_deeply ([keys %surprises], [], $t) or diag('Objects of unexpected type(s) found: ' . join(', ', sort keys %surprises)); } # END test listing table types $t=q{DB handle method "table_info" works when FetchHashKeyName set to NAME_lc}; { local $dbh->{FetchHashKeyName} = 'NAME_lc'; $sth = $dbh->table_info('', $test_schema, $test_table); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{TABLE_TYPE}, 'TABLE', $t); } # # Test of the "column_info" database handle method # # Check required minimum fields $t='DB handle method "column_info" returns expected fields in correct order'; $sth = $dbh->column_info('', $test_schema, $test_table, 'score'); my $colnames = join ',', @{$sth->{NAME}}; $expected = join ',', (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 pg_type pg_constraint pg_database pg_schema pg_table pg_column pg_enum_values )); is ($colnames, $expected, $t); # Store a non-matching result $sth = $dbh->column_info('', $test_schema, $test_table, 'id2'); my $nomatch = $sth->fetchall_arrayref({})->[0]; ## Store a single column match for 'id', an INT $sth = $dbh->column_info('', $test_schema, $test_table, 'id'); my $matchid = $sth->fetchall_arrayref({})->[0]; ## Store a single column match for 'val', a TEXT $sth = $dbh->column_info('', $test_schema, $test_table, 'val'); my $matchval = $sth->fetchall_arrayref({})->[0]; ## Store a single column match for column pname, a VARCHAR(20) $sth = $dbh->column_info('', $test_schema, $test_table, 'pname'); my $matchpname = $sth->fetchall_arrayref({})->[0]; ## Store a single column match for column expo, a NUMERIC(6,2) $sth = $dbh->column_info('', $test_schema, $test_table, 'expo'); my $matchexpo = $sth->fetchall_arrayref({})->[0]; ## Check the TABLE_CAT field $t=q{DB handle method "column_info" returns correct TABLE_CAT (database name)}; is ($matchid->{TABLE_CAT}, $dbh->{pg_db}, $t); ## Check the TABLE_NAME field $t=q{DB handle method "column_info" returns correct TABLE_NAME}; is ($matchid->{TABLE_NAME}, $test_table, $t); $t=q{DB handle method "column_info" returns TABLE_NAME as undef when no table matches}; $sth = $dbh->column_info('', $test_schema, $missing_table, ''); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{TABLE_NAME}, undef, $t); $t=q{DB handle method "column_info" returns correct TABLE_NAME (with quoting)}; $dbh->do(qq{CREATE TABLE "$space_table" (id int)}); $sth = $dbh->column_info('', $test_schema, $space_table, ''); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{TABLE_NAME}, qq{"$space_table"}, $t); $t=q{DB handle method "column_info" returns correct pg_table (with quoting)}; is ($result->{pg_table}, $space_table, $t); $dbh->do(qq{DROP TABLE "$space_table"}); $t=q{DB handle method "column_info" works when table argument is undef}; $sth = $dbh->column_info('', $test_schema, undef, 'id'); $result = $sth->fetchall_arrayref({})->[0]; ok (exists $result->{BUFFER_LENGTH}, $t); $t=q{DB handle method "column_info" works when table argument is empty}; $sth = $dbh->column_info('', $test_schema, '', 'id'); $result = $sth->fetchall_arrayref({})->[0]; ok (exists $result->{BUFFER_LENGTH}, $t); $t=q{DB handle method "column_info" returns undef when table argument has non-matching search pattern}; $sth = $dbh->column_info('', $test_schema, 'dbd_pg_badtable%', ''); is ($sth->fetch, undef, $t); $t=q{DB handle method "column_info" works when table argument matches via search pattern}; $sth = $dbh->column_info('', $test_schema, "$test_table%", ''); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{pg_table}, $test_table, $t); ## These can be very expensive, so we skip unless AUTHOR_TESTING SKIP: { if (! $ENV{AUTHOR_TESTING}) { skip ('Not pulling back every column in the database unless AUTHOR_TESTING is set', 2); } $t=q{DB handle method "column_info" works when all arguments are undef}; $sth = $dbh->column_info(undef, undef, undef, undef); $result = $sth->fetchall_arrayref({})->[0]; ok (exists $result->{BUFFER_LENGTH}, $t); $t=q{DB handle method "column_info" works when all arguments are empty}; $sth = $dbh->column_info('', '', '', ''); $result = $sth->fetchall_arrayref({})->[0]; ok (exists $result->{BUFFER_LENGTH}, $t); } ## Check the TABLE_SCHEM field $t=q{DB handle method "column_info" returns correct TABLE_SCHEM}; is ($matchid->{TABLE_SCHEM}, $test_schema, $t); $t=q{DB handle method "column_info" returns TABLE_SCHEM as undef when no schema matches}; $sth = $dbh->column_info('', $missing_schema, $test_table, ''); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{TABLE_SCHEM}, undef, $t); $t=q{DB handle method "column_info" works when schema argument is undef}; $sth = $dbh->column_info('', undef, $test_table, 'id'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{TABLE_SCHEM}, $test_schema, $t); $t=q{DB handle method "column_info" works when schema argument is empty}; $sth = $dbh->column_info('', '', $test_table, 'id'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{TABLE_SCHEM}, $test_schema, $t); $t=q{DB handle method "column_info" returns undef when schema argument has non-matching search pattern}; $sth = $dbh->column_info('', 'dbd_pg_badschema%', $test_table, 'id'); is ($sth->fetch, undef, $t); $t=q{DB handle method "column_info" works when schema argument matches via search pattern}; $sth = $dbh->column_info('', "$test_schema%", $test_table, 'id'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{pg_schema}, $test_schema, $t); ## Check the COLUMN_NAME field $t=q{DB handle method "column_info" returns correct COLUMN_NAME}; $sth = $dbh->column_info('', $test_schema, $test_table, 'id'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{COLUMN_NAME}, 'id', $t); $t=q{DB handle method "column_info" returns COLUMN_NAME as undef when no column matches}; is ($nomatch->{COLUMN_NAME}, undef, $t); $t=q{DB handle method "column_info" returns correct COLUMN_NAME (with quoting)}; $sth = $dbh->column_info('', $test_schema, $test_table, 'CaseTest'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{COLUMN_NAME}, '"CaseTest"', $t); $t=q{DB handle method "column_info" returns correct pg_column (with quoting)}; is ($result->{pg_column}, 'CaseTest', $t); $t=q{DB handle method "column_info" works when column argument is undef}; $sth = $dbh->column_info('', $test_schema, $test_table, undef); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{TABLE_NAME}, $test_table, $t); $t=q{DB handle method "column_info" works when column argument is empty}; $sth = $dbh->column_info('', $test_schema, $test_table, ''); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{TABLE_NAME}, $test_table, $t); $t=q{DB handle method "column_info" returns undef when column argument has non-matching search pattern}; $sth = $dbh->column_info('', $test_schema, $test_table, 'nosuchcolumn'); is ($sth->fetch, undef, $t); $t=q{DB handle method "column_info" works when column argument matches via search pattern}; $sth = $dbh->column_info('', $test_schema, $test_table, 'id%'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{pg_column}, 'id', $t); ## Check the DATA_TYPE field (DBI specs say this is a "concise data type code") $t=q{DB handle method "column_info" returns correct DATA_TYPE}; $sth = $dbh->column_info('', $test_schema, $test_table, 'score'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{DATA_TYPE}, '6', $t); $t=q{DB handle method "column_info" returns DATA_TYPE as undef when no column matches}; is ($nomatch->{DATA_TYPE}, undef, $t); ## Check the TYPE_NAME field $t=q{DB handle method "column_info" returns correct TYPE_NAME}; is ($matchid->{TYPE_NAME}, 'integer', $t); $t=q{DB handle method "column_info" returns TYPE_NAME as undef when no column matches}; is ($nomatch->{TYPE_NAME}, undef, $t); ## Check the COLUMN_SIZE field $t=q{DB handle method "column_info" returns correct COLUMN_SIZE for int}; is ($matchid->{COLUMN_SIZE}, 4, $t); $t=q{DB handle method "column_info" returns correct COLUMN_SIZE for varchar}; is ($matchpname->{COLUMN_SIZE}, '20', $t); $t=q{DB handle method "column_info" returns correct COLUMN_SIZE for numeric}; is ($matchexpo->{COLUMN_SIZE}, '6', $t); $t=q{DB handle method "column_info" returns COLUMN_SIZE as undef when no column matches}; is ($nomatch->{COLUMN_SIZE}, undef, $t); ## Check the BUFFER_LENGTH field (always null) $t=q{DB handle method "column_info" returns BUFFER_LENGTH as undef}; is ($matchid->{BUFFER_LENGTH}, undef, $t); ## Check the DECIMAL_DIGITS field $t=q{DB handle method "column_info" returns DECIMAL_DIGITS as undef for int}; is ($matchid->{DECIMAL_DIGITS}, undef, $t); $t=q{DB handle method "column_info" returns DECIMAL_DIGITS as undef for varchar}; is ($matchpname->{DECIMAL_DIGITS}, undef, $t); $t=q{DB handle method "column_info" returns correct DECIMAL_DIGITS for numeric}; is ($matchexpo->{DECIMAL_DIGITS}, 2, $t); ## Check the NUM_PREC_RADIX field (always null) $t=q{DB handle method "column_info" returns NUM_PREC_RADIX as undef}; is ($matchexpo->{NUM_PREC_RADIX}, undef, $t); ## Check the NULLABLE field $t=q{DB handle method "column_info" returns correct NULLABLE (when not nullable)}; is ($matchid->{NULLABLE}, 0, $t); $t=q{DB handle method "column_info" returns correct NULLABLE (when nullable)}; is ($matchval->{NULLABLE}, 1, $t); $t=q{DB handle method "column_info" returns NULLABLE as undef when no column matches}; is ($nomatch->{NULLABLE}, undef, $t); ## Check the REMARKS field $t=q{DB handle method "column_info" returns REMARKS as undef if no comment}; is ($matchval->{REMARKS}, undef, $t); $t=q{DB handle method "column_info" returns correct REMARKS when there is a comment}; is ($matchid->{REMARKS}, 'Bob is your uncle', $t); $t=q{DB handle method "column_info" returns REMARKS as undef when no column matches}; is ($nomatch->{REMARKS}, undef, $t); ## Check the COLUMN_DEF field $t=q{DB handle method "column_info" returns correct COLUMN_DEF (has default)}; $sth = $dbh->column_info('', $test_schema, $test_table, 'pdate'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{COLUMN_DEF}, 'now()', $t); $t=q{DB handle method "column_info" returns COLUMN_DEF as undef (no default)}; is ($matchid->{COLUMN_DEF}, undef, $t); $t=q{DB handle method "column_info" returns COLUMN_DEF as undef when no column matches}; is ($nomatch->{COLUMN_DEF}, undef, $t); ## Check the SQL_DATA_TYPE field (always null for now) $t=q{DB handle method "column_info" returns SQL_DATA_TYPE as undef}; is ($matchid->{SQL_DATA_TYPE}, undef, $t); ## Check the SQL_DATETIME_SUB field (always null) $t=q{DB handle method "column_info" returns SQL_DATETIME_SUB as undef}; is ($matchid->{SQL_DATETIME_SUB}, undef, $t); ## Check the CHAR_OCTET_LENGTH field (always null) $t=q{DB handle method "column_info" returns CHAR_OCTET_LENGTH as undef}; is ($matchid->{CHAR_OCTET_LENGTH}, undef, $t); ## Check the ORDINAL_POSITION field $t=q{DB handle method "column_info" returns correct ORDINAL_POSITION}; is ($matchval->{ORDINAL_POSITION}, 4, $t); $t=q{DB handle method "column_info" returns ORDINAL_POSITION as undef when no column matches}; is ($nomatch->{ORDINAL_POSITION}, undef, $t); $t=q{DB handle method "column_info" returns ORDINAL_POSITION as undef after column dropped}; $dbh->do("ALTER TABLE $test_schema.$test_table DROP COLUMN val"); $sth = $dbh->column_info('', $test_schema, $test_table, 'val'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{ORDINAL_POSITION}, undef, $t); $t=q{DB handle method "column_info" returns correct ORDINAL_POSITION after column re-added}; $dbh->do("ALTER TABLE $test_schema.$test_table ADD COLUMN val TEXT"); $sth = $dbh->column_info('', $test_schema, $test_table, 'val'); $result = $sth->fetchall_arrayref({})->[0]; ok ($result->{ORDINAL_POSITION} > 4, $t); ## Check the IS_NULLABLE field $t=q{DB handle method "column_info" returns correct IS_NULLABLE (when nullable)}; is ($matchval->{IS_NULLABLE}, 'YES', $t); $t=q{DB handle method "column_info" returns correct IS_NULLABLE (when not nullable)}; is ($matchid->{IS_NULLABLE}, 'NO', $t); $t=q{DB handle method "column_info" returns IS_NULLABLE as undef when no column matches}; is ($nomatch->{IS_NULLABLE}, undef, $t); ## Check the pg_type field $t=q{DB handle method "column_info" returns correct pg_type (text)}; is ($matchval->{pg_type}, 'text', $t); $t=q{DB handle method "column_info" returns correct pg_type (text array)}; $sth = $dbh->column_info('', $test_schema, $test_table, 'testarray'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{pg_type}, 'text[]', $t); $t=q{DB handle method "column_info" returns pg_type as undef when no column matches}; is ($nomatch->{pg_type}, undef, $t); ## Check the pg_constraint field $t=q{DB handle method "column_info" returns pg_constraint as undef when no constraints}; is ($matchid->{pg_constraint}, undef, $t); $t=q{DB handle method "column_info" returns correct pg_constraint when one constraint}; $sth = $dbh->column_info('', $test_schema, $test_table, 'lii'); $result = $sth->fetchall_arrayref({})->[0]; like ($result->{pg_constraint}, qr/-777/, $t); $t=q{DB handle method "column_info" returns correct pg_constraint when two constraints (#1)}; $sth = $dbh->column_info('', $test_schema, $test_table, 'score'); $result = $sth->fetchall_arrayref({})->[0]; like ($result->{pg_constraint}, qr/888/s, $t); $t=q{DB handle method "column_info" returns correct pg_constraint when two constraints (#2)}; like ($result->{pg_constraint}, qr/999/s, $t); $t=q{DB handle method "column_info" returns pg_constraint as undef when no column matches}; is ($nomatch->{pg_constraint}, undef, $t); ## Check the pg_database field $t=q{DB handle method "column_info" returns correct pg_database}; is ($matchid->{pg_database}, $dbh->{pg_db}, $t); $t=q{DB handle method "column_info" returns pg_database as undef when no column matches}; is ($nomatch->{pg_database}, undef, $t); ## Check the pg_schema field $t=q{DB handle method "column_info" returns correct pg_schema}; is ($matchid->{pg_schema}, $test_schema, $t); $t=q{DB handle method "column_info" returns pg_schema as undef when no column matches}; is ($nomatch->{pg_schema}, undef, $t); ## Check the pg_table field $t=q{DB handle method "column_info" returns correct pg_table}; is ($matchid->{pg_table}, $test_table, $t); $t=q{DB handle method "column_info" returns pg_table as undef when no column matches}; is ($nomatch->{pg_table}, undef, $t); ## Check the pg_column field $t=q{DB handle method "column_info" returns correct pg_column}; is ($matchid->{pg_column}, 'id', $t); $t=q{DB handle method "column_info" returns pg_column as undef when no column matches}; is ($nomatch->{pg_column}, undef, $t); ## Check the pg_enum_values field $t=q{DB handle method "column_info" returns pg_enum_values as undef for non-enum column}; is ($matchid->{pg_enum_values}, undef, $t); SKIP: { if ($pgversion < 80300) { skip ('DB handle method "column_info" -> pg_enum_values requires at least Postgres 8.3', 1); } my @enumvalues = qw( foo bar baz buz ); $dbh->do( q{CREATE TYPE dbd_pg_enumerated AS ENUM ('foo', 'bar', 'baz', 'buz')} ); $dbh->do( q{CREATE TEMP TABLE dbd_pg_enum_test ( is_enum dbd_pg_enumerated NOT NULL )} ); if ($pgversion >= 90100) { $dbh->{AutoCommit} = 1; $dbh->do( q{ALTER TYPE dbd_pg_enumerated ADD VALUE 'first' BEFORE 'foo'} ); unshift @enumvalues, 'first'; } $t='DB handle method "column_info" returns correct pg_enum_values'; $sth = $dbh->column_info('', '', 'dbd_pg_enum_test', 'is_enum'); $result = $sth->fetchall_arrayref({})->[0]; is_deeply ($result->{pg_enum_values}, \@enumvalues, $t); $dbh->do('DROP TABLE dbd_pg_enum_test'); $dbh->do('DROP TYPE dbd_pg_enumerated'); } $t=q{DB handle method "column_info" returns pg_enum_values as undef when no column matches}; is ($nomatch->{pg_enum_values}, undef, $t); $t=q{DB handle method "column_info" works when FetchHashKeyName set to NAME_lc}; { local $dbh->{FetchHashKeyName} = 'NAME_lc'; $sth = $dbh->column_info('', $test_schema, $test_table, 'id'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{TABLE_NAME}, $test_table, $t); } # # Test of the "primary_key_info" database handle method # # Check required minimum fields $t='DB handle method "primary_key_info" returns expected fields in correct order'; $sth = $dbh->primary_key_info('', $test_schema, $test_table); $colnames = join ',', @{$sth->{NAME}}; $expected = join ',', (qw( TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME DATA_TYPE pg_tablespace_name pg_tablespace_location pg_schema pg_table pg_column )); is ($colnames, $expected, $t); $t=q{DB handle method "primary_key_info" returns undef when table argument is undef}; $sth = $dbh->primary_key_info('', undef, undef); is ($sth->fetch, undef, $t); $t=q{DB handle method "primary_key_info" returns undef when table argument is empty}; $sth = $dbh->primary_key_info('', '', ''); is ($sth->fetch, undef, $t); $t=q{DB handle method "primary_key_info" works when schema argument is undef}; $sth = $dbh->primary_key_info('', undef, $test_table); $result = $sth->fetch; ok (defined $result->[0], $t); $t=q{DB handle method "primary_key_info" works when schema argument is empty}; $sth = $dbh->primary_key_info('', '', $test_table); $result = $sth->fetchall_arrayref({})->[0]; ok (defined $result, $t); ## Create a second table with multiple columns $dbh->do(qq{CREATE TEMP TABLE $test_table_combo_pk(a INTEGER, "B" TEXT, CONSTRAINT combo PRIMARY KEY (a,"B"))}); $sth = $dbh->primary_key_info('', '', $test_table_combo_pk); my $multi = $sth->fetchall_arrayref({}); $sth = $dbh->primary_key_info('', '', $test_table_combo_pk, {pg_onerow => 1}); my $onerow = $sth->fetchall_arrayref({})->[0]; $sth = $dbh->primary_key_info('', '', $test_table_combo_pk, {pg_onerow => 2}); my $arrayrow = $sth->fetchall_arrayref({})->[0]; ## Create a third table with no primary key $t=q{DB handle method "primary_key_info" returns nothing for tables with no PK}; $dbh->do(qq{CREATE TEMP TABLE $test_table_no_pk(n int)}); $sth = $dbh->primary_key_info('', '', $test_table_no_pk); is_deeply ($sth->fetch, undef, $t); $t=q{DB handle method "primary_key_info" returns correct TABLE_CAT (database name)}; is ($result->{TABLE_CAT}, $dbh->{pg_db}, $t); $t=q{DB handle method "primary_key_info" returns correct TABLE_SCHEM}; is ($result->{TABLE_SCHEM}, $test_schema, $t); $t=q{DB handle method "primary_key_info" returns correct TABLE_NAME}; is ($result->{TABLE_NAME}, $test_table, $t); $t=q{DB handle method "primary_key_info" returns correct COLUMN_NAME}; is ($result->{COLUMN_NAME}, 'id', $t); $t=q{DB handle method "primary_key_info" returns correct COLUMN_NAME (multi-row pk 1)}; is ($multi->[0]{COLUMN_NAME}, 'a', $t); $t=q{DB handle method "primary_key_info" returns correct COLUMN_NAME (multi-row pk 2)}; is ($multi->[1]{COLUMN_NAME}, '"B"', $t); $t=q{DB handle method "primary_key_info" returns correct COLUMN_NAME (multi-row pk, pg_onerow=>1)}; is ($onerow->{COLUMN_NAME}, 'a, "B"', $t); $t=q{DB handle method "primary_key_info" returns correct COLUMN_NAME (multi-row pk, pg_onerow=>2)}; is_deeply ($arrayrow->{COLUMN_NAME}, ['a', '"B"'], $t); $t=q{DB handle method "primary_key_info" returns correct KEY_SEQ}; is ($result->{KEY_SEQ}, 1, $t); $t=q{DB handle method "primary_key_info" returns correct KEY_SEQ (multi-row pk 1)}; is ($multi->[0]{KEY_SEQ}, 1, $t); $t=q{DB handle method "primary_key_info" returns correct KEY_SEQ (multi-row pk 2)}; is ($multi->[1]{KEY_SEQ}, 2, $t); $t=q{DB handle method "primary_key_info" returns correct KEY_SEQ (multi-row pk, pg_onerow=>1)}; is ($onerow->{KEY_SEQ}, '1, 2', $t); $t=q{DB handle method "primary_key_info" returns correct KEY_SEQ (multi-row pk, pg_onerow=>2)}; is_deeply ($arrayrow->{KEY_SEQ}, [1,2], $t); $t=q{DB handle method "primary_key_info" returns correct PK_NAME}; is ($result->{PK_NAME}, 'dbd_pg_test_pkey', $t); $t=q{DB handle method "primary_key_info" returns correct DATA_TYPE}; is ($result->{DATA_TYPE}, 'int4', $t); $t=q{DB handle method "primary_key_info" returns correct DATA_TYPE (multi-row pk 1)}; is ($multi->[0]{DATA_TYPE}, 'int4', $t); $t=q{DB handle method "primary_key_info" returns correct DATA_TYPE (multi-row pk 2)}; is ($multi->[1]{DATA_TYPE}, 'text', $t); $t=q{DB handle method "primary_key_info" returns correct DATA_TYPE (multi-row pk, pg_onerow=>1)}; is ($onerow->{DATA_TYPE}, 'int4, text', $t); $t=q{DB handle method "primary_key_info" returns correct DATA_TYPE (multi-row pk, pg_onerow=>2)}; is_deeply ($arrayrow->{DATA_TYPE}, ['int4','text'], $t); $t=q{DB handle method "primary_key_info" returns correct pg_tablespace_name}; ## Ideally we test these better, but creating tablespaces in the test cluster is too tricky is ($result->{pg_tablespace_name}, undef, $t); $t=q{DB handle method "primary_key_info" returns correct pg_tablespace_location}; is ($result->{pg_tablespace_location}, undef, $t); $t=q{DB handle method "primary_key_info" returns correct pg_schema}; is ($result->{pg_schema}, $test_schema, $t); $t=q{DB handle method "primary_key_info" returns correct pg_table}; is ($result->{pg_table}, $test_table, $t); $t=q{DB handle method "primary_key_info" returns correct pg_column}; is ($result->{pg_column}, 'id', $t); $t=q{DB handle method "primary_key_info" returns correct pg_column (multi-row pk 1)}; is ($multi->[0]{pg_column}, 'a', $t); $t=q{DB handle method "primary_key_info" returns correct pg_column (multi-row pk 2)}; is ($multi->[1]{pg_column}, 'B', $t); $t=q{DB handle method "primary_key_info" returns correct pg_column (multi-row pk, pg_onerow=>1)}; is ($onerow->{pg_column}, 'a, B', $t); $t=q{DB handle method "primary_key_info" returns correct pg_column (multi-row pk, pg_onerow=>2)}; is_deeply ($arrayrow->{pg_column}, ['a', 'B'], $t); $t=q{DB handle method "primary_key_info" works when FetchHashKeyName set to NAME_lc}; { local $dbh->{FetchHashKeyName} = 'NAME_lc'; $sth = $dbh->primary_key_info('', $test_schema, $test_table); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{COLUMN_NAME}, 'id', $t); } # # Test of the "primary_key" database handle method # $t='DB handle method "primary_key" works'; @results = $dbh->primary_key('', $test_schema, $test_table); $expected = ['id']; is_deeply (\@results, $expected, $t); $t='DB handle method "primary_key" returns empty list for invalid table'; @results = $dbh->primary_key('', $test_schema, $missing_table); $expected = []; is_deeply (\@results, $expected, $t); # # Test of the "statistics_info" database handle method # # Arguments are $catalog, $schema, $table, $unique_only, $quick $t='DB handle method "statistics_info" returns false when table argument is undef'; $sth = $dbh->statistics_info(undef, undef, undef, undef, undef); is ($sth, undef, $t); $t='DB handle method "statistics_info" returns false when table argument is empty'; $sth = $dbh->statistics_info(undef, undef, '', undef, undef); is ($sth, undef, $t); $t='DB handle method "statistics_info" returns no rows when table does not exist'; $sth = $dbh->statistics_info(undef, '', $missing_table, undef, undef); $result = $sth->fetchall_arrayref; is_deeply ($result, [], $t); $t='DB handle method "statistics_info" returns no rows when schema does not exist'; $sth = $dbh->statistics_info(undef, $missing_schema, $test_table, undef, undef); $result = $sth->fetchall_arrayref; is_deeply ($result, [], $t); # Check required minimum fields $t='DB handle method "statistics_info" returns expected fields in correct order'; $sth = $dbh->statistics_info('','',$test_table, '', ''); $colnames = join ',', @{$sth->{NAME}}; $expected = join ',', (qw( TABLE_CAT TABLE_SCHEM TABLE_NAME NON_UNIQUE INDEX_QUALIFIER INDEX_NAME TYPE ORDINAL_POSITION COLUMN_NAME ASC_OR_DESC CARDINALITY PAGES FILTER_CONDITION pg_expression pg_is_key_column pg_null_ordering )); is ($colnames, $expected, $t); $t='DB handle method "statistics_info" returns expected fields in correct order (unique_only=true)'; $sth = $dbh->statistics_info('','',$test_table, 1, ''); $colnames = join ',', @{$sth->{NAME}}; is ($colnames, $expected, $t); my $with_oids = $pgversion < 120000 ? 'WITH OIDS' : ''; my $with_include = $pgversion >= 110000; my $hash_index_idx = 3; $hash_index_idx += 1 if $with_oids; $hash_index_idx += 2 if $with_include; my ($desc, $d) = $pgversion >= 80300 ? ('DESC', 'D') : ('', 'A'); my ($nulls_first, $nf) = $pgversion >= 80300 ? ('NULLS FIRST', 'first') : ('', 'last'); my ($nulls_last, $nl) = $pgversion >= 80300 ? ('NULLS LAST', 'last') : ('', 'last'); ## Create some tables with various indexes { local $SIG{__WARN__} = sub {}; ## Drop the third schema. ## Postgres < 8.3 doesn't have DROP SCHEMA IF EXISTS, so check manually if ($dbh->selectrow_array( 'SELECT 1 FROM pg_catalog.pg_namespace WHERE nspname = ?', undef, $schema3 )) { $dbh->do("DROP SCHEMA $schema3 CASCADE"); } $dbh->do("CREATE TABLE $table1 (a INT, b INT NOT NULL, c INT NOT NULL, ". 'CONSTRAINT dbd_pg_test1_pk PRIMARY KEY (a))'); $dbh->do("ALTER TABLE $table1 ADD CONSTRAINT dbd_pg_test1_uc1 UNIQUE (b)"); $dbh->do("CREATE UNIQUE INDEX dbd_pg_test1_index_c ON $table1(c $nulls_first)"); $dbh->do("CREATE TABLE $table2 (a INT, b INT, c INT, PRIMARY KEY(a,b), UNIQUE(b,c))"); $dbh->do("CREATE INDEX dbd_pg_test2_expr ON $table2((a+b) $desc, c $desc $nulls_last)"); $dbh->do("CREATE TABLE $table3 (a INT, b INT, c INT, PRIMARY KEY(a)) $with_oids"); $dbh->do("CREATE UNIQUE INDEX dbd_pg_test3_index_b ON $table3(b)"); $dbh->do("CREATE INDEX dbd_pg_test3_index_c ON $table3 USING hash(c)"); $dbh->do("CREATE INDEX dbd_pg_test3_oid ON $table3(oid)") if $with_oids; $dbh->do("CREATE UNIQUE INDEX dbd_pg_test3_pred ON $table3(c) WHERE c > 0 AND c < 45"); $dbh->do("CREATE UNIQUE INDEX dbd_pg_test3_incl ON $table3(b) INCLUDE (c)") if $with_include; $dbh->commit(); } my $correct_stats = { one => [ [ $dbh->{pg_db}, $schema, $table1, '0', undef, 'dbd_pg_test1_index_c', 'btree', 1, 'c', 'A', '0', '1', undef, 'c', '1', $nf ], [ $dbh->{pg_db}, $schema, $table1, '0', undef, 'dbd_pg_test1_pk', 'btree', 1, 'a', 'A', '0', '1', undef, 'a', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table1, '0', undef, 'dbd_pg_test1_uc1', 'btree', 1, 'b', 'A', '0', '1', undef, 'b', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table1, undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef, undef, undef, undef ], ], two => [ [ $dbh->{pg_db}, $schema, $table2, '0', undef, 'dbd_pg_test2_b_key', 'btree', 1, 'b', 'A', '0', '1', undef, 'b', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table2, '0', undef, 'dbd_pg_test2_b_key', 'btree', 2, 'c', 'A', '0', '1', undef, 'c', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table2, '0', undef, 'dbd_pg_test2_pkey', 'btree', 1, 'a', 'A', '0', '1', undef, 'a', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table2, '0', undef, 'dbd_pg_test2_pkey', 'btree', 2, 'b', 'A', '0', '1', undef, 'b', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table2, '1', undef, 'dbd_pg_test2_expr', 'btree', 1, undef, $d, '0', '1', undef, '(a + b)', '1', $nf ], [ $dbh->{pg_db}, $schema, $table2, '1', undef, 'dbd_pg_test2_expr', 'btree', 2, 'c', $d, '0', '1', undef, 'c', '1', $nl ], [ $dbh->{pg_db}, $schema, $table2, undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef, undef, undef, undef ], ], three => [ ($with_include ? ( [ $dbh->{pg_db}, $schema, $table3, '0', undef, 'dbd_pg_test3_incl', 'btree', 1, 'b', 'A', '0', '1', undef, 'b', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table3, '0', undef, 'dbd_pg_test3_incl', 'btree', 2, 'c', undef, '0', '1', undef, 'c', '0', undef ], ) :()), [ $dbh->{pg_db}, $schema, $table3, '0', undef, 'dbd_pg_test3_index_b', 'btree', 1, 'b', 'A', '0', '1', undef, 'b', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table3, '0', undef, 'dbd_pg_test3_pkey', 'btree', 1, 'a', 'A', '0', '1', undef, 'a', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table3, '0', undef, 'dbd_pg_test3_pred', 'btree', 1, 'c', 'A', '0', '1', '((c > 0) AND (c < 45))', 'c', '1', 'last' ], ($with_oids ? [ $dbh->{pg_db}, $schema, $table3, '1', undef, 'dbd_pg_test3_oid', 'btree', 1, 'oid', 'A', '0', '1', undef, 'oid', '1', 'last' ] : ()), [ $dbh->{pg_db}, $schema, $table3, '1', undef, 'dbd_pg_test3_index_c', 'hashed', 1, 'c', undef, '0', '4', undef, 'c', '1', undef ], [ $dbh->{pg_db}, $schema, $table3, undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef, undef, undef, undef ], ], three_uo => [ ($with_include ? ( [ $dbh->{pg_db}, $schema, $table3, '0', undef, 'dbd_pg_test3_incl', 'btree', 1, 'b', 'A', '0', '1', undef, 'b', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table3, '0', undef, 'dbd_pg_test3_incl', 'btree', 2, 'c', undef, '0', '1', undef, 'c', '0', undef ], ) :()), [ $dbh->{pg_db}, $schema, $table3, '0', undef, 'dbd_pg_test3_index_b', 'btree', 1, 'b', 'A', '0', '1', undef, 'b', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table3, '0', undef, 'dbd_pg_test3_pkey', 'btree', 1, 'a', 'A', '0', '1', undef, 'a', '1', 'last' ], [ $dbh->{pg_db}, $schema, $table3, '0', undef, 'dbd_pg_test3_pred', 'btree', 1, 'c', 'A', '0', '1', '((c > 0) AND (c < 45))', 'c', '1', 'last' ], ], }; ## Make some per-version tweaks ## Postgres 9 changed the way foreign key names are generated if ($pgversion >= 90000) { $correct_stats->{two}[0][5] = $correct_stats->{two}[1][5] = 'dbd_pg_test2_b_c_key'; } ## Postgres 14 changed unknown reltuples from 0 to -1 if ($pgversion >= 140000) { $correct_stats->{one}[3][10] = $correct_stats->{two}[6][10] = $correct_stats->{three}[6][10] = -1; } $t=qq{DB handle method "statistics_info" returns correct results for $table1}; $sth = $dbh->statistics_info(undef, $schema, $table1, undef, undef); $result = $sth->fetchall_arrayref; is_deeply ($result, $correct_stats->{one}, $t); $t=qq{DB handle method "statistics_info" returns correct results for $table2}; $sth = $dbh->statistics_info(undef,$schema, $table2, undef, undef); $result = $sth->fetchall_arrayref; is_deeply ($result, $correct_stats->{two}, $t); $t=qq{DB handle method "statistics_info" returns correct results for $table3}; $sth = $dbh->statistics_info(undef, $schema, $table3, undef, undef); $result = $sth->fetchall_arrayref; ## Too many intra-version differences to try for an exact number here: $correct_stats->{three}[$hash_index_idx][11] = $result->[$hash_index_idx][11] = 0; is_deeply ($result, $correct_stats->{three}, $t); $t=qq{DB handle method "statistics_info" returns correct results for $table3 (unique_only=true)}; $sth = $dbh->statistics_info(undef, $schema, $table3, 1, undef); $result = $sth->fetchall_arrayref; is_deeply ($result, $correct_stats->{three_uo}, $t); $t=q{DB handle method "statistics_info" works when FetchHashKeyName set to NAME_lc}; { local $dbh->{FetchHashKeyName} = 'NAME_lc'; $sth = $dbh->statistics_info('', $test_schema, $test_table, 0, 0); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{TYPE}, 'btree', $t); } # Clean everything up $dbh->do("DROP TABLE $table3"); $dbh->do("DROP TABLE $table2"); $dbh->do("DROP TABLE $table1"); ## end of statistics_info tests # # Test of the "foreign_key_info" database handle method # $t='DB handle method "foreign_key_info" returns no rows when pk and fk are undef'; $sth = $dbh->foreign_key_info(undef,undef,undef,undef,undef,undef); is ($sth->fetch, undef, $t); $t='DB handle method "foreign_key_info" returns no rows when pk and fk are empty'; $sth = $dbh->foreign_key_info(undef,undef,'',undef,undef,''); is ($sth->fetch, undef, $t); # Drop any tables that may exist my $fktables = join ',' => map { "'dbd_pg_test$_'" } (1..3); $SQL = "SELECT n.nspname||'.'||r.relname FROM pg_catalog.pg_class r, pg_catalog.pg_namespace n WHERE relkind='r' AND r.relnamespace = n.oid AND r.relname IN ($fktables)"; { local $SIG{__WARN__} = sub {}; for (@{$dbh->selectall_arrayref($SQL)}) { $dbh->do("DROP TABLE $_->[0] CASCADE"); } } ## Invalid primary table $t='DB handle method "foreign_key_info" returns no rows: bad pk / no fk'; $sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,undef); is ($sth->fetch, undef, $t); ## Invalid foreign table $t='DB handle method "foreign_key_info" returns no rows: no pk / bad fk'; $sth = $dbh->foreign_key_info(undef,undef,undef,undef,undef,'dbd_pg_test9'); is ($sth->fetch, undef, $t); ## Both primary and foreign are invalid $t='DB handle method "foreign_key_info" returns no rows: bad fk / bad fk'; $sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,'dbd_pg_test9'); is ($sth->fetch, undef, $t); ## Create a pk table # Create identical tables and relations in multiple schemas, and in the # opposite order of the search_path, so we have at least a vague chance # of testing that we respect the search_path order. $dbh->do("CREATE SCHEMA $schema3"); $dbh->do("CREATE SCHEMA $schema2"); $dbh->do("SET search_path = $schema2,$schema3"); for my $s ($schema3, $schema2) { local $SIG{__WARN__} = sub {}; $dbh->do("CREATE TABLE $s.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 $s.dbd_pg_test1 ADD CONSTRAINT dbd_pg_test1_uc1 UNIQUE (b)"); $dbh->do("CREATE UNIQUE INDEX dbd_pg_test1_index_c ON $s.dbd_pg_test1(c)"); $dbh->commit(); } ## Make sure the foreign_key_info is turning this back on internally: $dbh->{pg_expand_array} = 0; ## Good primary with no foreign keys $t='DB handle method "foreign_key_info" returns no rows: good pk (but unreferenced)'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); is ($sth->fetch, undef, $t); ## Create a simple foreign key table for my $s ($schema3, $schema2) { local $SIG{__WARN__} = sub {}; $dbh->do("CREATE TABLE $s.dbd_pg_test2 (f1 INT PRIMARY KEY, f2 INT NOT NULL, f3 INT NOT NULL)"); $dbh->do("ALTER TABLE $s.dbd_pg_test2 ADD CONSTRAINT dbd_pg_test2_fk1 FOREIGN KEY(f2) REFERENCES $s.dbd_pg_test1(a)"); $dbh->commit(); } ## Bad primary with good foreign $t='DB handle method "foreign_key_info" returns no rows: bad pk / good fk'; $sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,$table2); is ($sth->fetch, undef, $t); ## Good primary, good foreign, bad schemas $t='DB handle method "foreign_key_info" returns no rows: good pk / good fk / bad pk schema'; my $testschema = 'dbd_pg_test_badschema11'; $sth = $dbh->foreign_key_info(undef,$testschema,$table1,undef,undef,$table2); is ($sth->fetch, undef, $t); $t='DB handle method "foreign_key_info" returns no rows: good pk / good fk / bad fk schema'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,$testschema,$table2); is ($sth->fetch, undef, $t); ## Good primary $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); $result = $sth->fetchall_arrayref({}); # Check required minimum fields $t='DB handle method "foreign_key_info" returns fields required by DBI'; $result = $sth->fetchall_arrayref({}); @required = (qw(UK_TABLE_CAT UK_TABLE_SCHEM UK_TABLE_NAME PK_COLUMN_NAME FK_TABLE_CAT FK_TABLE_SCHEM FK_TABLE_NAME FK_COLUMN_NAME ORDINAL_POSITION UPDATE_RULE DELETE_RULE FK_NAME UK_NAME DEFERABILITY UNIQUE_OR_PRIMARY UK_DATA_TYPE FK_DATA_TYPE)); undef %missing; for my $r (@$result) { for (@required) { $missing{$_}++ if ! exists $r->{$_}; } } is_deeply (\%missing, {}, $t); $t='Calling foreign_key_info does not change pg_expand_array'; is ($dbh->{pg_expand_array}, 0, $t); ## Good primary $t='DB handle method "foreign_key_info" works for good pk'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); $result = $sth->fetchall_arrayref(); my $fk1 = [ $dbh->{pg_db}, ## Catalog $schema2, ## Schema $table1, ## Table 'a', ## Column $dbh->{pg_db}, ## FK Catalog $schema2, ## FK Schema $table2, ## FK Table 'f2', ## FK Table 1, ## Ordinal position 3, ## Update rule 3, ## Delete rule 'dbd_pg_test2_fk1', ## FK name 'dbd_pg_test1_pk', ## UK name '7', ## deferability 'PRIMARY', ## unique or primary 'int4', ## uk data type 'int4' ## fk data type ]; $expected = [$fk1]; is_deeply ($result, $expected, $t); ## Same with explicit table $t='DB handle method "foreign_key_info" works for good pk / good fk'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $result = $sth->fetchall_arrayref(); is_deeply ($result, $expected, $t); ## Foreign table only $t='DB handle method "foreign_key_info" works for good fk'; $sth = $dbh->foreign_key_info(undef,undef,undef,undef,undef,$table2); $result = $sth->fetchall_arrayref(); is_deeply ($result, $expected, $t); ## Add a foreign key to an explicit unique constraint $t='DB handle method "foreign_key_info" works for good pk / explicit fk'; { local $SIG{__WARN__} = sub {}; $dbh->do('ALTER TABLE dbd_pg_test2 ADD CONSTRAINT dbd_pg_test2_fk2 FOREIGN KEY (f3) '. 'REFERENCES dbd_pg_test1(b) ON DELETE SET NULL ON UPDATE CASCADE'); } $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); $result = $sth->fetchall_arrayref(); my $fk2 = [ $dbh->{pg_db}, $schema2, $table1, 'b', $dbh->{pg_db}, $schema2, $table2, 'f3', '1', '0', ## cascade '2', ## set null 'dbd_pg_test2_fk2', 'dbd_pg_test1_uc1', '7', 'UNIQUE', 'int4', 'int4' ]; $expected = [$fk1,$fk2]; is_deeply ($result, $expected, $t); ## Add a foreign key to an implicit unique constraint (a unique index on a column) $t='DB handle method "foreign_key_info" works for good pk / implicit fk'; { local $SIG{__WARN__} = sub {}; $dbh->do('ALTER TABLE dbd_pg_test2 ADD CONSTRAINT dbd_pg_test2_aafk3 FOREIGN KEY (f3) '. 'REFERENCES dbd_pg_test1(c) ON DELETE RESTRICT ON UPDATE SET DEFAULT'); } $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); $result = $sth->fetchall_arrayref(); my $fk3 = [ $dbh->{pg_db}, $schema2, $table1, 'c', $dbh->{pg_db}, $schema2, $table2, 'f3', '1', '4', ## set default '1', ## restrict 'dbd_pg_test2_aafk3', undef, ## plain indexes have no named constraint '7', 'UNIQUE', 'int4', 'int4' ]; $expected = [$fk3,$fk1,$fk2]; is_deeply ($result, $expected, $t); ## Create another foreign key table to point to the first (primary) table $t='DB handle method "foreign_key_info" works for multiple foreign keys'; for my $s ($schema3, $schema2) { local $SIG{__WARN__} = sub {}; $dbh->do("CREATE TABLE $s.dbd_pg_test3 (ff1 INT NOT NULL)"); $dbh->do("ALTER TABLE $s.dbd_pg_test3 ADD CONSTRAINT dbd_pg_test3_fk1 FOREIGN KEY(ff1) REFERENCES $s.dbd_pg_test1(a)"); $dbh->commit(); } $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); $result = $sth->fetchall_arrayref(); my $fk4 = [ $dbh->{pg_db}, $schema2, $table1, 'a', $dbh->{pg_db}, $schema2, $table3, 'ff1', '1', '3', '3', 'dbd_pg_test3_fk1', 'dbd_pg_test1_pk', '7', 'PRIMARY', 'int4', 'int4' ]; $expected = [$fk3,$fk1,$fk2,$fk4]; is_deeply ($result, $expected, $t); ## Test that explicit naming two tables brings back only those tables $t='DB handle method "foreign_key_info" works for good pk / good fk (only)'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table3); $result = $sth->fetchall_arrayref(); $expected = [$fk4]; is_deeply ($result, $expected, $t); ## Multi-column madness $t='DB handle method "foreign_key_info" works for multi-column keys'; { local $SIG{__WARN__} = sub {}; $dbh->do('ALTER TABLE dbd_pg_test1 ADD CONSTRAINT dbd_pg_test1_uc2 UNIQUE (b,c,a)'); $dbh->do('ALTER TABLE dbd_pg_test2 ADD CONSTRAINT dbd_pg_test2_fk4 ' . 'FOREIGN KEY (f1,f3,f2) REFERENCES dbd_pg_test1(c,a,b)'); } $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $result = $sth->fetchall_arrayref(); ## "dbd_pg_test2_fk4" FOREIGN KEY (f1, f3, f2) REFERENCES dbd_pg_test1(c, a, b) my $fk5 = [ $dbh->{pg_db}, $schema2, $table1, 'c', $dbh->{pg_db}, $schema2, $table2, 'f1', '1', '3', '3', 'dbd_pg_test2_fk4', 'dbd_pg_test1_uc2', '7', 'UNIQUE', 'int4', 'int4' ]; # For the rest of the multi-column, only change: # primary column name [3] # foreign column name [7] # ordinal position [8] my @fk6 = @$fk5; my $fk6r = \@fk6; $fk6r->[3] = 'a'; $fk6r->[7] = 'f3'; $fk6r->[8] = 2; my @fk7 = @$fk5; my $fk7r = \@fk7; $fk7r->[3] = 'b'; $fk7r->[7] = 'f2'; $fk7r->[8] = 3; $expected = [$fk3,$fk1,$fk2,$fk5,$fk6r,$fk7r]; is_deeply ($result, $expected, $t); $t='DB handle method "foreign_key_info" works with FetchHashKeyName NAME_lc'; $dbh->{FetchHashKeyName} = 'NAME_lc'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $sth->execute(); $result = $sth->fetchrow_hashref(); $sth->finish(); ok (exists $result->{'fk_table_name'}, $t); $t='DB handle method "foreign_key_info" works with FetchHashKeyName NAME_uc'; $dbh->{FetchHashKeyName} = 'NAME_uc'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $sth->execute(); $result = $sth->fetchrow_hashref(); ok (exists $result->{'FK_TABLE_NAME'}, $t); ## nospellcheck $t='DB handle method "foreign_key_info" works with FetchHashKeyName NAME'; $dbh->{FetchHashKeyName} = 'NAME'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $sth->execute(); $result = $sth->fetchrow_hashref(); ok (exists $result->{'FK_TABLE_NAME'}, $t); ## nospellcheck # Clean everything up for my $s ($schema3, $schema2) { $dbh->do("DROP TABLE $s.$table1, $s.$table2, $s.$table3"); } $dbh->do("DROP SCHEMA $schema2"); $dbh->do("DROP SCHEMA $schema3"); $dbh->do("SET search_path = $schema"); # # Test of the "tables" database handle method # $t='DB handle method "tables" returns empty list when no matching rows'; @results = $dbh->tables('', '', 'dbd_nosuch_table', ''); is_deeply (\@results, [], $t); $t='DB handle method "tables" works'; @results = $dbh->tables('', '', 'dbd_pg_test', ''); is ($results[0], 'dbd_pg_testschema.dbd_pg_test', $t); $t='DB handle method "tables" works with a "pg_foobar" attribute'; @results = $dbh->tables('', '', 'dbd_pg_test', '', {pg_foobar => 1}); is ($results[0], 'dbd_pg_testschema.dbd_pg_test', $t); $t='DB handle method "tables" works with a "pg_noprefix" attribute'; @results = $dbh->tables('', '', 'dbd_pg_test', '', {pg_noprefix => 1}); is ($results[0], 'dbd_pg_test', $t); $t='DB handle method "tables" works with type=\'%\''; @results = $dbh->tables('', '', 'dbd_pg_test', '%'); like ($results[0], qr/dbd_pg_test/, $t); # # Test of the "type_info_all" database handle method # $result = $dbh->type_info_all(); # Quick check that the structure looks correct $t='DB handle method "type_info_all" returns a valid structure'; my $bad_result=q{}; if (ref $result eq 'ARRAY') { my $index = $result->[0]; if (ref $index ne 'HASH') { $bad_result = 'First element in array not a hash ref'; } else { for (qw(TYPE_NAME DATA_TYPE CASE_SENSITIVE)) { $bad_result = "Field $_ missing" if !exists $index->{$_}; } } } else { $bad_result = 'Array reference not returned'; } diag "type_info_all problem: $bad_result" if $bad_result; ok (!$bad_result, $t); # # Test of the "type_info" database handle method # # Check required minimum fields $t='DB handle method "type_info" returns fields required by DBI'; $result = $dbh->type_info(4); @required = (qw(TYPE_NAME DATA_TYPE COLUMN_SIZE LITERAL_PREFIX LITERAL_SUFFIX CREATE_PARAMS NULLABLE CASE_SENSITIVE SEARCHABLE UNSIGNED_ATTRIBUTE FIXED_PREC_SCALE AUTO_UNIQUE_VALUE LOCAL_TYPE_NAME MINIMUM_SCALE MAXIMUM_SCALE SQL_DATA_TYPE SQL_DATETIME_SUB NUM_PREC_RADIX INTERVAL_PRECISION)); undef %missing; for (@required) { $missing{$_}++ if ! exists $result->{$_}; } is_deeply (\%missing, {}, $t); # # Test of the "quote" database handle method # my %quotetests = ( q{0} => q{'0'}, q{Ain't misbehaving } => q{'Ain''t misbehaving '}, NULL => q{'NULL'}, "" => q{''}, ## no critic ); for (keys %quotetests) { $t=qq{DB handle method "quote" works with a value of "$_"}; $result = $dbh->quote($_); is ($result, $quotetests{$_}, $t); } ## Test timestamp - should quote as a string $t='DB handle method "quote" work on timestamp'; my $tstype = 93; my $test_time = '2008001-01-28 11:12:13'; is ($dbh->quote( $test_time, $tstype ), qq{'$test_time'}, $t); $t='DB handle method "quote" works with an undefined value'; my $foo; { no warnings;## Perl does not like undef args is ($dbh->quote($foo), q{NULL}, $t); } $t='DB handle method "quote" works with integer data type for simple digit'; is ($dbh->quote(1, 4), 1, $t); $t='DB handle method "quote" works with integer data type for simple digits'; is ($dbh->quote(123, 4), 123, $t); $t='DB handle method "quote" works with integer data type for space then digit'; is ($dbh->quote(' 123', 4), ' 123', $t); $t='DB handle method "quote" works with integer data type for space and plus then digit'; is ($dbh->quote(' + 123', 4), ' + 123', $t); $t='DB handle method "quote" works with integer data type for space and minus then digit'; is ($dbh->quote(' -123', 4), ' -123', $t); $t='DB handle method "quote" fails with integer data type for digit followed by a plus'; eval { $dbh->quote('1+1', 4); }; like ($@, qr{Invalid integer}, $t); $t='DB handle method "quote" fails with integer data type for digit followed by a minus'; eval { $dbh->quote('1--', 4); }; like ($@, qr{Invalid integer}, $t); $t='DB handle method "quote" fails with integer data type for digit followed by space'; eval { $dbh->quote('123 456', 4); }; like ($@, qr{Invalid integer}, $t); $t='DB handle method "quote" fails with integer data type for a non digit'; eval { $dbh->quote('12z45', 4); }; like ($@, qr{Invalid integer}, $t); ## Test bytea quoting my $scs = $dbh->{pg_standard_conforming_strings}; for my $byteval (1 .. 255) { my $byte = chr($byteval); $result = $dbh->quote($byte, { pg_type => PG_BYTEA }); if ($byteval < 32 or $byteval >= 127) { $expected = $scs ? sprintf q{E'\\\\%03o'}, $byteval : sprintf q{'\\\\%03o'}, $byteval; } else { $expected = $scs ? sprintf q{E'%s'}, $byte : sprintf q{'%s'}, $byte; } if ($byte eq '\\') { $expected =~ s{\\}{\\\\\\\\}; } elsif ($byte eq q{'}) { $expected = $scs ? q{E''''} : q{''''}; } $t = qq{Byte value $byteval quotes to $expected}; is ($result, $expected, $t); } ## Various backslash tests $t='DB handle method "quote" works properly with backslashes'; my $E = $pgversion >= 80100 ? q{E} : q{}; is ($dbh->quote('foo\\bar'), qq{${E}'foo\\\\bar'}, $t); $t='DB handle method "quote" works properly without backslashes'; is ($dbh->quote('foobar'), q{'foobar'}, $t); # # Test various quote types # ## Invalid type arguments $t='DB handle method "quote" throws exception on non-reference type argument'; eval { $dbh->quote('abc', 'def'); }; like ($@, qr{hashref}, $t); $t='DB handle method "quote" throws exception on arrayref type argument'; eval { $dbh->quote('abc', ['arraytest']); }; like ($@, qr{hashref}, $t); SKIP: { eval { require Test::Warn; }; if ($@) { skip ('Need Test::Warn for some tests', 1); } $t='DB handle method "quote" allows an empty hashref'; Test::Warn::warning_like ( sub { $dbh->quote('abc', {}); }, qr/UNKNOWN/, $t); } ## Points $t='DB handle method "quote" works with type PG_POINT'; eval { $result = $dbh->quote(q{123,456}, { pg_type => PG_POINT }); }; is ($@, q{}, $t); $t='DB handle method "quote" returns correct value for type PG_POINT'; is ($result, q{'123,456'}, $t); $t='DB handle method "quote" fails with invalid PG_POINT string'; eval { $result = $dbh->quote(q{[123,456]}, { pg_type => PG_POINT }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_POINT string'; eval { $result = $dbh->quote(q{A123,456}, { pg_type => PG_POINT }); }; like ($@, qr{Invalid input for geometric type}, $t); ## Lines and line segments $t='DB handle method "quote" works with valid PG_LINE string'; eval { $result = $dbh->quote(q{123,456}, { pg_type => PG_LINE }); }; is ($@, q{}, $t); $t='DB handle method "quote" fails with invalid PG_LINE string'; eval { $result = $dbh->quote(q{[123,456]}, { pg_type => PG_LINE }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_LINE string'; eval { $result = $dbh->quote(q{<123,456}, { pg_type => PG_LINE }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_LSEG string'; eval { $result = $dbh->quote(q{[123,456]}, { pg_type => PG_LSEG }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_LSEG string'; eval { $result = $dbh->quote(q{[123,456}, { pg_type => PG_LSEG }); }; like ($@, qr{Invalid input for geometric type}, $t); ## Boxes $t='DB handle method "quote" works with valid PG_BOX string'; eval { $result = $dbh->quote(q{1,2,3,4}, { pg_type => PG_BOX }); }; is ($@, q{}, $t); $t='DB handle method "quote" fails with invalid PG_BOX string'; eval { $result = $dbh->quote(q{[1,2,3,4]}, { pg_type => PG_BOX }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_BOX string'; eval { $result = $dbh->quote(q{1,2,3,4,cheese}, { pg_type => PG_BOX }); }; like ($@, qr{Invalid input for geometric type}, $t); ## Paths - can have optional square brackets $t='DB handle method "quote" works with valid PG_PATH string'; eval { $result = $dbh->quote(q{[(1,2),(3,4)]}, { pg_type => PG_PATH }); }; is ($@, q{}, $t); $t='DB handle method "quote" returns correct value for type PG_PATH'; is ($result, q{'[(1,2),(3,4)]'}, $t); $t='DB handle method "quote" fails with invalid PG_PATH string'; eval { $result = $dbh->quote(q{<(1,2),(3,4)>}, { pg_type => PG_PATH }); }; like ($@, qr{Invalid input for path type}, $t); $t='DB handle method "quote" fails with invalid PG_PATH string'; eval { $result = $dbh->quote(q{<1,2,3,4>}, { pg_type => PG_PATH }); }; like ($@, qr{Invalid input for path type}, $t); ## Polygons $t='DB handle method "quote" works with valid PG_POLYGON string'; eval { $result = $dbh->quote(q{1,2,3,4}, { pg_type => PG_POLYGON }); }; is ($@, q{}, $t); $t='DB handle method "quote" fails with invalid PG_POLYGON string'; eval { $result = $dbh->quote(q{[1,2,3,4]}, { pg_type => PG_POLYGON }); }; like ($@, qr{Invalid input for geometric type}, $t); $t='DB handle method "quote" fails with invalid PG_POLYGON string'; eval { $result = $dbh->quote(q{1,2,3,4,cheese}, { pg_type => PG_POLYGON }); }; like ($@, qr{Invalid input for geometric type}, $t); ## Circles - can have optional angle brackets $t='DB handle method "quote" works with valid PG_CIRCLE string'; eval { $result = $dbh->quote(q{<(1,2,3)>}, { pg_type => PG_CIRCLE }); }; is ($@, q{}, $t); $t='DB handle method "quote" returns correct value for type PG_CIRCLE'; is ($result, q{'<(1,2,3)>'}, $t); $t='DB handle method "quote" fails with invalid PG_CIRCLE string'; eval { $result = $dbh->quote(q{[(1,2,3)]}, { pg_type => PG_CIRCLE }); }; like ($@, qr{Invalid input for circle type}, $t); $t='DB handle method "quote" fails with invalid PG_CIRCLE string'; eval { $result = $dbh->quote(q{1,2,3,4,H}, { pg_type => PG_CIRCLE }); }; like ($@, qr{Invalid input for circle type}, $t); # # Test of the "quote_identifier" database handle method # %quotetests = ( q{0} => q{"0"}, q{Ain't misbehaving } => q{"Ain't misbehaving "}, NULL => q{"NULL"}, "" => q{""}, ## no critic ); for (keys %quotetests) { $t=qq{DB handle method "quote_identifier" works with a value of "$_"}; $result = $dbh->quote_identifier($_); is ($result, $quotetests{$_}, $t); } $t='DB handle method "quote_identifier" works with an undefined value'; is ($dbh->quote_identifier(undef), q{}, $t); $t='DB handle method "quote_identifier" works with schemas'; is ($dbh->quote_identifier( undef, 'Her schema', 'My table' ), q{"Her schema"."My table"}, $t); # # Test of the "table_attributes" database handle method (deprecated) # # Because this function is deprecated and really just calling the column_info() # and primary_key() methods, we will do minimal testing. $t='DB handle method "table_attributes" returns the expected fields'; $result = $dbh->func('dbd_pg_test', 'table_attributes'); $result = $result->[0]; @required = (qw(NAME TYPE SIZE NULLABLE DEFAULT CONSTRAINT PRIMARY_KEY REMARKS)); undef %missing; for (@required) { $missing{$_}++ if ! exists $result->{$_}; } is_deeply (\%missing, {}, $t); # # Test of the "pg_lo_*" database handle methods # $t='DB handle method "pg_lo_creat" returns a valid descriptor for reading'; $dbh->{AutoCommit}=1; $dbh->{AutoCommit}=0; ## Catch error where not in begin my ($R,$W) = ($dbh->{pg_INV_READ}, $dbh->{pg_INV_WRITE}); my $object; $t='DB handle method "pg_lo_creat" works with old-school dbh->func() method'; $object = $dbh->func($W, 'pg_lo_creat'); like ($object, qr/^[0-9]+$/o, $t); isnt ($object, 0, $t); $t='DB handle method "pg_lo_creat" works with deprecated dbh->func(...lo_creat) method'; $object = $dbh->func($W, 'lo_creat'); like ($object, qr/^[0-9]+$/o, $t); isnt ($object, 0, $t); $t='DB handle method "pg_lo_creat" returns a valid descriptor for writing'; $object = $dbh->pg_lo_creat($W); like ($object, qr/^[0-9]+$/o, $t); isnt ($object, 0, $t); $t='DB handle method "pg_lo_open" returns a valid descriptor for writing'; my $handle = $dbh->pg_lo_open($object, $W); like ($handle, qr/^[0-9]+$/o, $t); isnt ($object, -1, $t); $t='DB handle method "pg_lo_lseek" works when writing'; $result = $dbh->pg_lo_lseek($handle, 0, SEEK_SET); is ($result, 0, $t); isnt ($object, -1, $t); $t='DB handle method "pg_lo_write" works'; my $buf = 'tangelo mulberry passionfruit raspberry plantain' x 500; $result = $dbh->pg_lo_write($handle, $buf, length($buf)); is ($result, length($buf), $t); cmp_ok ($object, '>', 0, $t); $t='DB handle method "pg_lo_tell" works when writing'; $result = $dbh->pg_lo_tell($handle); is ($result, length($buf), $t); $t='DB handle method "pg_lo_lseek(SEEK_END)" works when writing'; $result = $dbh->pg_lo_lseek($handle, 0, SEEK_END); is ($result, length($buf), $t); isnt ($object, -1, $t); $t='DB handle method "pg_lo_tell" works after seek when writing'; $result = $dbh->pg_lo_tell($handle); is ($result, length($buf), $t); $t='DB handle method "pg_lo_close" works after write'; $result = $dbh->pg_lo_close($handle); ok ($result, $t); # Reopen for reading $t='DB handle method "pg_lo_open" returns a valid descriptor for reading'; $handle = $dbh->pg_lo_open($object, $R); like ($handle, qr/^[0-9]+$/o, $t); cmp_ok ($handle, 'eq', 0, $t); $t='DB handle method "pg_lo_lseek(SEEK_SET)" works when reading'; $result = $dbh->pg_lo_lseek($handle, 11, SEEK_SET); is ($result, 11, $t); $t='DB handle method "pg_lo_tell" works'; my $tell_result = $dbh->pg_lo_tell($handle); is ($tell_result, $result, $t); $t='DB handle method "pg_lo_lseek(SEEK_CUR)" forward works when reading'; $result = $dbh->pg_lo_lseek($handle, 11, SEEK_CUR); is ($result, 22, $t); $t='DB handle method "pg_lo_tell" works'; $tell_result = $dbh->pg_lo_tell($handle); is ($tell_result, $result, $t); $t='DB handle method "pg_lo_lseek(SEEK_CUR)" backward works when reading'; $result = $dbh->pg_lo_lseek($handle, -10, SEEK_CUR); is ($result, 12, $t); $t='DB handle method "pg_lo_tell" works'; $tell_result = $dbh->pg_lo_tell($handle); is ($tell_result, $result, $t); $t='DB handle method "pg_lo_lseek(SEEK_END)" works when reading'; $result = $dbh->pg_lo_lseek($handle, -11, SEEK_END); is ($result, length($buf)-11, $t); $t='DB handle method "pg_lo_tell" works'; $tell_result = $dbh->pg_lo_tell($handle); is ($tell_result, $result, $t); $t='DB handle method "pg_lo_read" reads back the same data that was written'; $dbh->pg_lo_lseek($handle, 0, SEEK_SET); my ($buf2,$data) = ('',''); while ($dbh->pg_lo_read($handle, $data, 513)) { $buf2 .= $data; } is (length($buf), length($buf2), $t); $t='DB handle method "pg_lo_close" works after read'; $result = $dbh->pg_lo_close($handle); ok ($result, $t); $dbh->commit; SKIP: { if ($pglibversion < 80300 or $pgversion < 80300) { skip ('Postgres version 8.3 or greater needed for pg_lo_truncate tests', 1); } $t='DB handle method "pg_lo_truncate" fails if opened in read mode only'; $handle = $dbh->pg_lo_open($object, $R); $result = $dbh->pg_lo_truncate($handle, 4); is ($result, undef, $t); $dbh->rollback(); $t='DB handle method "pg_lo_truncate" works if opened in read/write mode'; $handle = $dbh->pg_lo_open($object, $W); $result = $dbh->pg_lo_truncate($handle, 44); is ($result, 0, $t); $t='DB handle method "pg_lo_truncate" truncates to expected size'; $dbh->pg_lo_lseek($handle, 0, SEEK_SET); ($buf2,$data) = ('',''); while ($dbh->pg_lo_read($handle, $data, 100)) { $buf2 .= $data; } is (length($buf2), 44, $t); $t='DB handle method "pg_lo_truncate(INT_MAX)" works'; my $INT_MAX = (1<<31)-1; $result = $dbh->pg_lo_truncate($handle, $INT_MAX); is ($result, 0, $t); $t='DB handle method "pg_lo_seek(SEEK_END)" after "pg_lo_truncate(INT_MAX)" works'; $result = $dbh->pg_lo_lseek($handle, 0, SEEK_END); is ($result, $INT_MAX, $t); $t='DB handle method "pg_lo_tell" after "pg_lo_truncate(INT_MAX)" works'; $result = $dbh->pg_lo_tell($handle); is ($result, $INT_MAX, $t); SKIP: { if ($Config{ivsize} < 8 or $pgversion < 90300 or $pglibversion < 90300) { skip 'Cannot test 64-bit offsets for largeobject functions without 64-bit integers and Postgres 9.3 or higher', 1; } # large objects are stored in chunks of BLOCKSZ/4 with an # integer chunk number column. only chunks with data in them # are stored, so this doesn't actually require 4TiB of space my $BLOCK_SIZE = $dbh->selectrow_array('show block_size'); my $LO_MAX = $INT_MAX * $BLOCK_SIZE / 4; $t='DB handle method "pg_lo_truncate(LO_MAX) works'; $result = $dbh->pg_lo_truncate($handle, $LO_MAX); is ($result, 0, $t); $t='DB handle method "pg_lo_seek(SEEK_END)" after "pg_lo_truncate(LO_MAX) works'; $result = $dbh->pg_lo_lseek($handle, 0, SEEK_END); is ($result, $LO_MAX, $t); $t='DB handle method "pg_lo_tell" after "pg_lo_truncate(LO_MAX)" works'; $result = $dbh->pg_lo_tell($handle); is ($result, $LO_MAX, $t); $t='DB handle method "pg_lo_lseek(SEEK_END)" to start works'; $result = $dbh->pg_lo_lseek($handle, -$LO_MAX, SEEK_END); is ($result, 0, $t); } } $t='DB handle method "pg_lo_unlink" works'; $result = $dbh->pg_lo_unlink($object); is ($result, 1, $t); $t='DB handle method "pg_lo_unlink" fails when called second time'; $result = $dbh->pg_lo_unlink($object); ok (!$result, $t); $dbh->rollback(); SKIP: { $superuser or skip ('Cannot run largeobject tests unless run as Postgres superuser', 1); SKIP: { eval { require File::Temp; }; $@ and skip ('Must have File::Temp to test pg_lo_import* and pg_lo_export', 1); $t='DB handle method "pg_lo_import" works'; my ($fh,$filename) = File::Temp::tmpnam(); print {$fh} "abc\ndef"; close $fh or warn 'Failed to close temporary file'; $handle = $dbh->pg_lo_import($filename); my $objid = $handle; ok ($handle, $t); $t='DB handle method "pg_lo_import" inserts correct data'; $SQL = "SELECT data FROM pg_largeobject where loid = $handle"; $info = $dbh->selectall_arrayref($SQL)->[0][0]; is_deeply ($info, "abc\ndef", $t); $dbh->commit(); SKIP: { if ($pglibversion < 80400) { skip ('Cannot test pg_lo_import_with_oid unless compiled against 8.4 or better server', 1); } if ($pgversion < 80100) { skip ('Cannot test pg_lo_import_with_oid against old versions of Postgres', 1); } $t='DB handle method "pg_lo_import_with_oid" works with high number'; my $highnumber = 345167; $dbh->pg_lo_unlink($highnumber); $dbh->commit(); my $thandle; SKIP: { skip ('Known bug: pg_log_import_with_oid throws an error. See RT #90448', 1); $thandle = $dbh->pg_lo_import_with_oid($filename, $highnumber); is ($thandle, $highnumber, $t); ok ($thandle, $t); $t='DB handle method "pg_lo_import_with_oid" inserts correct data'; $SQL = "SELECT data FROM pg_largeobject where loid = $thandle"; $info = $dbh->selectall_arrayref($SQL)->[0][0]; is_deeply ($info, "abc\ndef", $t); } $t='DB handle method "pg_lo_import_with_oid" fails when given already used number'; eval { $thandle = $dbh->pg_lo_import_with_oid($filename, $objid); }; is ($thandle, undef, $t); $dbh->rollback(); $t='DB handle method "pg_lo_import_with_oid" falls back to lo_import when number is 0'; eval { $thandle = $dbh->pg_lo_import_with_oid($filename, 0); }; ok ($thandle, $t); $dbh->rollback(); } unlink $filename; $t='DB handle method "pg_lo_open" works after "pg_lo_insert"'; $handle = $dbh->pg_lo_open($handle, $R); like ($handle, qr/^[0-9]+$/o, $t); $t='DB handle method "pg_lo_read" returns correct data after "pg_lo_import"'; $data = ''; $result = $dbh->pg_lo_read($handle, $data, 100); is ($result, 7, $t); is ($data, "abc\ndef", $t); $t='DB handle method "pg_lo_export" works'; ($fh,$filename) = File::Temp::tmpnam(); $result = $dbh->pg_lo_export($objid, $filename); ok (-e $filename, $t); seek($fh,0,1); seek($fh,0,0); $result = read $fh, $data, 10; is ($result, 7, $t); is ($data, "abc\ndef", $t); close $fh or warn 'Could not close tempfile'; unlink $filename; $dbh->pg_lo_unlink($objid); } ## Same pg_lo_* tests, but with AutoCommit on $dbh->{AutoCommit}=1; $t='DB handle method "pg_lo_creat" fails when AutoCommit on'; eval { $dbh->pg_lo_creat($W); }; like ($@, qr{pg_lo_creat when AutoCommit is on}, $t); $t='DB handle method "pg_lo_open" fails with AutoCommit on'; eval { $dbh->pg_lo_open($object, $W); }; like ($@, qr{pg_lo_open when AutoCommit is on}, $t); $t='DB handle method "pg_lo_read" fails with AutoCommit on'; eval { $dbh->pg_lo_read($object, $data, 0); }; like ($@, qr{pg_lo_read when AutoCommit is on}, $t); $t='DB handle method "pg_lo_lseek" fails with AutoCommit on'; eval { $dbh->pg_lo_lseek($handle, 0, SEEK_SET); }; like ($@, qr{pg_lo_lseek when AutoCommit is on}, $t); $t='DB handle method "pg_lo_write" fails with AutoCommit on'; $buf = 'tangelo mulberry passionfruit raspberry plantain' x 500; eval { $dbh->pg_lo_write($handle, $buf, length($buf)); }; like ($@, qr{pg_lo_write when AutoCommit is on}, $t); $t='DB handle method "pg_lo_close" fails with AutoCommit on'; eval { $dbh->pg_lo_close($handle); }; like ($@, qr{pg_lo_close when AutoCommit is on}, $t); $t='DB handle method "pg_lo_tell" fails with AutoCommit on'; eval { $dbh->pg_lo_tell($handle); }; like ($@, qr{pg_lo_tell when AutoCommit is on}, $t); $t='DB handle method "pg_lo_unlink" fails with AutoCommit on'; eval { $dbh->pg_lo_unlink($object); }; like ($@, qr{pg_lo_unlink when AutoCommit is on}, $t); SKIP: { eval { require File::Temp; }; $@ and skip ('Must have File::Temp to test pg_lo_import and pg_lo_export', 1); $t='DB handle method "pg_lo_import" works (AutoCommit on)'; my ($fh,$filename) = File::Temp::tmpnam(); print {$fh} "abc\ndef"; close $fh or warn 'Failed to close temporary file'; $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $t='DB handle method "pg_lo_import" inserts correct data (AutoCommit on, begin_work not called)'; $SQL = 'SELECT data FROM pg_largeobject where loid = ?'; $sth = $dbh->prepare($SQL); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, "abc\ndef", $t); # cleanup last lo $dbh->{AutoCommit} = 0; $dbh->pg_lo_unlink($handle); $dbh->{AutoCommit} = 1; $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, no command)'; $dbh->begin_work(); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, "abc\ndef", $t); $dbh->rollback(); $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, no command, rollback)'; $dbh->begin_work(); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $dbh->rollback(); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, undef, $t); $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, second command)'; $dbh->begin_work(); $dbh->do('SELECT 123'); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, "abc\ndef", $t); $dbh->rollback(); $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, second command, rollback)'; $dbh->begin_work(); $dbh->do('SELECT 123'); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $dbh->rollback(); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, undef, $t); $t='DB handle method "pg_lo_import" works (AutoCommit not on, no command)'; $dbh->{AutoCommit} = 0; $dbh->commit(); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, "abc\ndef", $t); $t='DB handle method "pg_lo_import" works (AutoCommit not on, second command)'; $dbh->rollback(); $dbh->do('SELECT 123'); $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, "abc\ndef", $t); unlink $filename; $dbh->{AutoCommit} = 1; my $objid = $handle; $t='DB handle method "pg_lo_export" works (AutoCommit on)'; ($fh,$filename) = File::Temp::tmpnam(); $result = $dbh->pg_lo_export($objid, $filename); ok (-e $filename, $t); seek($fh,0,1); seek($fh,0,0); $result = read $fh, $data, 10; is ($result, 7, $t); is ($data, "abc\ndef", $t); close $fh or warn 'Could not close tempfile'; unlink $filename; # cleanup last lo $dbh->{AutoCommit} = 0; $dbh->pg_lo_unlink($handle); $dbh->{AutoCommit} = 1; } $dbh->{AutoCommit} = 0; } # # Test of the "pg_notifies" database handle method # $t='DB handle method "pg_notifies" does not throw an error'; eval { $dbh->func('pg_notifies'); }; is ($@, q{}, $t); $t='DB handle method "pg_notifies" (func) returns the correct values'; my $notify_name = 'dbdpg_notify_test'; my $pid = $dbh->selectall_arrayref('SELECT pg_backend_pid()')->[0][0]; $dbh->do("LISTEN $notify_name"); $dbh->do("NOTIFY $notify_name"); $dbh->commit(); $info = $dbh->func('pg_notifies'); is_deeply ($info, [$notify_name, $pid, ''], $t); $t='DB handle method "pg_notifies" returns the correct values'; $dbh->do("NOTIFY $notify_name"); $dbh->commit(); $info = $dbh->pg_notifies; is_deeply ($info, [$notify_name, $pid, ''], $t); $t='DB handle method "pg_notifies" returns correct string length'; my $name = $info->[0]; is (length($name), 17, $t); $dbh->do("NOTIFY $notify_name"); $dbh->commit(); $info = $dbh->pg_notifies; is (length($info->[0]), 17, $t); SKIP: { $t='DB handle method "pg_notifies" returns correct string length for recycled var'; if ($pgversion < 90000) { skip ('Cannot test notification payloads on pre-9.0 servers', 1); } $dbh->do("LISTEN abc$notify_name"); $dbh->do(qq{NOTIFY abc$notify_name, 'Just some simple payload text'}); $dbh->commit(); $info = $dbh->pg_notifies; $name = $info->[0]; is (length($name), 17+3, $t); $name = $info->[2]; is (length($name), 29, $t); $dbh->do(qq{NOTIFY abc$notify_name, 'A shorter payload'}); $dbh->commit(); $info = $dbh->pg_notifies; is (length($info->[0]), 17+3, $t); $name = $info->[2]; is (length($name), 17, $t); } # # Test of the "getfd" database handle method # $t='DB handle method "getfd" returns a number'; $result = $dbh->func('getfd'); like ($result, qr/^[0-9]+$/, $t); # # Test of the "state" database handle method # $t='DB handle method "state" returns an empty string on success'; $result = $dbh->state(); is ($result, q{}, $t); $t='DB handle method "state" returns a five-character code on error'; eval { $dbh->do('SELECT dbdpg_throws_an_error'); }; $result = $dbh->state(); like ($result, qr/^[A-Z0-9]{5}$/, $t); $dbh->rollback(); # # Test of the "private_attribute_info" database handle method # SKIP: { if ($DBI::VERSION < 1.54) { skip ('DBI must be at least version 1.54 to test private_attribute_info', 1); } $t='DB handle method "private_attribute_info" returns at least one record'; my $private = $dbh->private_attribute_info(); my ($valid,$invalid) = (0,0); for my $name (keys %$private) { $name =~ /^pg_\w+/ ? $valid++ : $invalid++; } ok ($valid >= 1, $t); $t='DB handle method "private_attribute_info" returns only internal names'; is ($invalid, 0, $t); } # # Test of the "clone" database handle method # $t='Database handle method "clone" does not throw an error'; my $dbh2; eval { $dbh2 = $dbh->clone(); }; is ($@, q{}, $t); $t='Database handle method "clone" returns a valid database handle'; eval { $dbh2->do('SELECT 123'); }; is ($@, q{}, $t); $dbh2->disconnect(); # # Test of the "ping" and "pg_ping" database handle methods # my $mtvar; ## This is an implicit test of getcopydata: please leave this var undefined SKIP: { if ($pgversion < 80300) { skip ('Cannot test pg_ping via COPY on pre-8.3 servers', 1); } for my $type (qw/ ping pg_ping /) { $t=qq{DB handle method "$type" returns 1 on an idle connection}; $dbh->commit(); is ($dbh->$type(), 1, $t); $dbh->{PrintError} = 1; $t=qq{DB handle method "$type" returns 1 on an idle connection (PrintError on)}; $dbh->commit(); is ($dbh->$type(), 1, $t); $dbh->{PrintError} = 0; $t=qq{DB handle method "$type" returns 2 when in COPY IN state}; $dbh->do('COPY dbd_pg_test(id,pname) TO STDOUT'); $dbh->pg_getcopydata($mtvar); is ($dbh->$type(), 2, $t); ## the ping messes up the copy state, so all we can do is rollback $dbh->rollback(); $t=qq{DB handle method "$type" returns 2 when in COPY IN state}; $dbh->do('COPY dbd_pg_test(id,pname) FROM STDIN'); $dbh->pg_putcopydata("123\tfoobar\n"); is ($dbh->$type(), 2, $t); $dbh->rollback(); $t=qq{DB handle method "$type" returns 3 for a good connection inside a transaction}; $dbh->do('SELECT 123'); is ($dbh->$type(), 3, $t); $t=qq{DB handle method "$type" returns a 4 when inside a failed transaction}; eval { $dbh->do('DBD::Pg creating an invalid command for testing'); }; is ($dbh->$type(), 4, $t); $dbh->rollback(); my $val = $type eq 'ping' ? 0 : -1; $t=qq{DB handle method "type" fails (returns $val) on a disconnected handle}; $dbh->disconnect(); is ($dbh->$type(), $val, $t); $t='Able to reconnect to the database after disconnect'; $dbh = connect_database({nosetup => 1}); isnt ($dbh, undef, $t); SKIP: { skip 'Cannot safely reopen sockets on Win32', 1 if $^O =~ /Win32/; $val = $type eq 'ping' ? 0 : -3; $t=qq{DB handle method "$type" returns $val after a lost network connection (outside transaction)}; socket_fail($dbh); is ($dbh->$type(), $val, $t); ## Reconnect, and try the same thing but inside a transaction $val = $type eq 'ping' ? 0 : -3; $t=qq{DB handle method "$type" returns $val after a lost network connection (inside transaction)}; $dbh = connect_database({nosetup => 1}); $dbh->do(q{SELECT 'DBD::Pg testing'}); socket_fail($dbh); is ($dbh->$type(), $val, $t); $type eq 'ping' and $dbh = connect_database({nosetup => 1}); } } } # # Test of the "pg_type_info" database handle method # $t=q{DB handle method "pg_type_info" returns 23 for type 4}; is ($dbh->pg_type_info(23), 4, $t); $dbh->{PrintError} = 1; $t=q{DB handle method "pg_type_info" returns 12 for type 123 (PrintError on)}; is ($dbh->pg_type_info(123), 12, $t); $dbh->{PrintError} = 0; # # Test async connect # ASYNC_CONNECT: { my ($dsn, $user) = get_test_settings(); my ($rc); sub test_connect { return DBI->connect($dsn, $user, $ENV{DBI_PASS}, { RaiseError => 0, PrintError => 0, pg_async_connect => $_[0]}); } # # test sync connect when pfg_async_connect is false # $dbh = test_connect(0); if (!$dbh) { fail('failed to create dbh for sync connect test'); last; } $rc = $dbh->ping(); ok (1 == $rc, 'pg_async_connect false connects synchronously'); $dbh->disconnect(); # # test async connect # $dbh = test_connect(1); if (!$dbh) { fail ('failed to create async_connect dbh'); last; } while ($rc = $dbh->pg_continue_connect(), $rc > 0) { my ($rin, $win, $ref); if ($rc > 2) { fail ('pg_continue_connect return value > 0 but neither 1 nor 2'); last ASYNC_CONNECT; } $ref = (1 == $rc) ? \$rin : \$win; vec($$ref, $$dbh{pg_socket}, 1) = 1; $rc = select($rin, $win, undef, undef); } ok (0 == $rc || -2 == $rc, 'pg_continue_connect loop ended with success or failure return value'); # # test pg_continue_connect ret value when connected # $rc = $dbh->pg_continue_connect(); ok (-1 == $rc, 'pg_continue_connect returned -1 when async connect not in progress'); } done_testing(); exit; sub socket_fail { my $ldbh = shift; $ldbh->{InactiveDestroy} = 1; my $fd = $ldbh->{pg_socket} or die 'Could not determine socket'; open(DBH_PG_FH, '<&='.$fd) or die "Could not open socket: $!"; ## no critic close DBH_PG_FH or die "Could not close socket: $!"; return; } DBD-Pg-3.20.2/t/02attribs.t0000644000175000017500000015641215174665134013454 0ustar greggreg#!perl ## Test all handle attributes: database, statement, and generic ("any") use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Data::Dumper; use Test::More; use DBI ':sql_types'; use DBD::Pg qw/ :pg_types :async /; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my (undef,undef,$dbh) = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 293; isnt ($dbh, undef, 'Connect to database for handle attributes testing'); my $pgversion = $dbh->{pg_server_version}; my $pglibversion = $dbh->{pg_lib_version}; =begin comment d = database handle specific s = statement handle specific b = both database and statement handle 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_skip_deallocate d pg_db d pg_user d pg_pass d pg_port d pg_default_port d pg_options d pg_socket d pg_pid d pg_standard_conforming strings d pg_enable_utf8 d Warn d pg_prepare_now - tested in 03smethod.t d pg_server_prepare - tested in 03smethod.t d pg_switch_prepared - tested in 03smethod.t d pg_prepare_now - tested in 03smethod.t d pg_placeholder_dollaronly - tested in 12placeholders.t s NUM_OF_FIELDS, NUM_OF_PARAMS s NAME, NAME_lc, NAME_uc, NAME_hash, NAME_lc_hash, NAME_uc_hash s TYPE, PRECISION, SCALE, NULLABLE s CursorName s Database s ParamValues s ParamTypes s RowsInCache s pg_size s pg_type s pg_oid_status s pg_cmd_status b pg_async_status a Active a Executed a Kids a ActiveKids a CachedKids a Type a ChildHandles a CompatMode a PrintError a RaiseError a HandleError a HandleSetErr a ErrCount a ShowErrorStatement a TraceLevel a FetchHashKeyName a ChopBlanks a LongReadLen a LongTruncOk a TaintIn a TaintOut a Taint a Profile (not tested) a ReadOnly d AutoInactiveDestroy (must be the last one tested) d InactiveDestroy (must be the last one tested) =cut my ($attrib,$SQL,$sth,$warning,$result,$expected,$t); # Get the DSN and user from the test file, if it exists my ($testdsn, $testuser) = get_test_settings(); # # Test of the database handle attribute "Statement" # $SQL = 'SELECT 123'; $sth = $dbh->prepare($SQL); $sth->finish(); $t='DB handle attribute "Statement" returns the last prepared query'; $attrib = $dbh->{Statement}; is ($attrib, $SQL, $t); # # Test of bogus database/statement handle attributes # ## DBI switched from error to warning in 1.43 $t='Error or warning when setting an invalid database handle attribute'; $warning=q{}; eval { local $SIG{__WARN__} = sub { $warning = shift; }; $dbh->{CrazyDiamond}=1; }; isnt ($warning, q{}, $t); $t='Setting a private attribute on a database handle does not throw an error'; eval { $dbh->{private_dbdpg_CrazyDiamond}=1; }; is ($@, q{}, $t); $sth = $dbh->prepare('SELECT 123'); $t='Error or warning when setting an invalid statement handle attribute'; $warning=q{}; eval { local $SIG{__WARN__} = sub { $warning = shift; }; $sth->{CrazyDiamond}=1; }; isnt ($warning, q{}, $t); $t='Setting a private attribute on a statement handle does not throw an error'; eval { $sth->{private_dbdpg_CrazyDiamond}=1; }; is ($@, q{}, $t); # # Test of the database handle attribute "AutoCommit" # $t='Commit after deleting all rows from dbd_pg_test'; $dbh->do('DELETE FROM dbd_pg_test'); ok ($dbh->commit(), $t); $t='Connect to database with second database handle, AutoCommit on'; my $dbh2 = connect_database({AutoCommit => 1}); isnt ($dbh2, undef, $t); $t='Insert a row into the database with first database handle'; ok ($dbh->do(q{INSERT INTO dbd_pg_test (id, pname, val) VALUES (1, 'Coconut', 'Mango')}), $t); $t='Second database handle cannot see insert from first'; my $rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 1}))[0]; is ($rows, 0, $t); $t='Insert a row into the database with second database handle'; ok ($dbh->do(q{INSERT INTO dbd_pg_test (id, pname, val) VALUES (2, 'Grapefruit', 'Pomegranate')}), $t); $t='First database handle can see insert from second'; $rows = ($dbh->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 2}))[0]; cmp_ok ($rows, '==', 1, $t); ok ($dbh->commit, 'Commit transaction with first database handle'); $t='Second database handle can see insert from first'; $rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 1}))[0]; is ($rows, 1, $t); ok ($dbh2->disconnect(), 'Disconnect with second database handle'); # # Test of the database handle attribute "Driver" # $t='$dbh->{Driver}{Name} returns correct value of "Pg"'; $attrib = $dbh->{Driver}->{Name}; is ($attrib, 'Pg', $t); # # Test of the database handle attribute "Name" # SKIP: { $t='DB handle attribute "Name" returns same value as DBI_DSN'; if (! length $testdsn or $testdsn !~ /^dbi:Pg:(.+)/) { skip (q{Cannot test DB handle attribute "Name" invalid DBI_DSN}, 1); } $expected = $1 || $ENV{PGDATABASE}; defined $expected and length $expected or skip ('Cannot test unless database name known', 1); $attrib = $dbh->{Name}; $expected =~ s/(db|database)=/dbname=/; is ($attrib, $expected, $t); } # # Test of the database handle attribute "RowCacheSize" # $t='DB handle attribute "RowCacheSize" returns undef'; $attrib = $dbh->{RowCacheSize}; is ($attrib, undef, $t); $t='Setting DB handle attribute "RowCacheSize" has no effect'; $dbh->{RowCacheSize} = 42; $attrib = $dbh->{RowCacheSize}; is ($attrib, undef, $t); # # Test of the database handle attribute "Username" # $t='DB handle attribute "Username" returns the same value as DBI_USER'; SKIP: { if (! length $testuser) { skip ('Cannot test $dbh->{Username} unless DBI_USER is set', 1); } $attrib = $dbh->{Username}; is ($attrib, $testuser, $t); } # # Test of the "PrintWarn" database handle attribute # $t='DB handle attribute "PrintWarn" defaults to on'; my $value = $dbh->{PrintWarn}; is ($value, 1, $t); { local $SIG{__WARN__} = sub { $warning .= shift; }; $dbh->do(q{SET client_min_messages = 'DEBUG1'}); $t='DB handle attribute "PrintWarn" works when on'; $warning = q{}; eval { $dbh->do('CREATE TEMP TABLE dbd_pg_test_temp(id INT PRIMARY KEY)'); }; is ($@, q{}, $t); $t='DB handle attribute "PrintWarn" shows warnings when on'; like ($warning, qr{dbd_pg_test_temp}, $t); $t='DB handle attribute "PrintWarn" works when on'; $dbh->rollback(); $dbh->{PrintWarn}=0; $warning = q{}; eval { $dbh->do('CREATE TEMP TABLE dbd_pg_test_temp(id INT PRIMARY KEY)'); }; is ($@, q{}, $t); $t='DB handle attribute "PrintWarn" shows warnings when on'; is ($warning, q{}, $t); $dbh->{PrintWarn}=1; $dbh->rollback(); } # # Test of the database handle attributes "pg_INV_WRITE" and "pg_INV_READ" # (these are used by the lo_* database handle methods) # $t='Database handle attribute "pg_INV_WRITE" returns a number'; like ($dbh->{pg_INV_WRITE}, qr/^[0-9]+$/, $t); $t='Database handle attribute "pg_INV_READ" returns a number'; like ($dbh->{pg_INV_READ}, qr/^[0-9]+$/, $t); # # Test of the database handle attribute "pg_protocol" # $t='Database handle attribute "pg_protocol" returns a number'; like ($dbh->{pg_protocol}, qr/^[0-9]+$/, $t); # # Test of the database handle attribute "pg_errorlevel" # $t='Database handle attribute "pg_errorlevel" returns the default (1)'; is ($dbh->{pg_errorlevel}, 1, $t); $t='Database handle attribute "pg_errorlevel" defaults to 1 if invalid'; $dbh->{pg_errorlevel} = 3; is ($dbh->{pg_errorlevel}, 1, $t); # # Test of the database handle attribute "pg_bool_tf" # $t='DB handle method "pg_bool_tf" starts as 0'; $result = $dbh->{pg_bool_tf}=0; is ($result, 0, $t); $t=q{DB handle method "pg_bool_tf" returns '1' for true when on}; $sth = $dbh->prepare('SELECT ?::bool'); $sth->bind_param(1,1,SQL_BOOLEAN); $sth->execute(); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, '1', $t); $t=q{DB handle method "pg_bool_tf" returns '0' for false when on}; $sth->execute(0); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, '0', $t); $t=q{DB handle method "pg_bool_tf" returns 't' for true when on}; $dbh->{pg_bool_tf}=1; $sth->execute(1); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, 't', $t); $t=q{DB handle method "pg_bool_tf" returns 'f' for true when on}; $sth->execute(0); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, 'f', $t); # # Test of the database handle attribute "pg_skip_deallocate" # $t='DB handle method "pg_skip_deallocate" starts as 0'; $result = $dbh->{pg_skip_deallocate}; is ($result, 0, $t); $t=q{DB handle method "pg_skip_deallocate" deallocates prepare statements when off}; ## pg_prepared_statements added in 8.2, so we don't bother with a skip block $SQL = 'SELECT count(*) from pg_prepared_statements'; my $tempsth = $dbh->prepare('select * FROM pg_class WHERE reltuples = 42', {pg_prepare_now => 1}); my $initial_count = $dbh->selectall_arrayref($SQL)->[0][0]; $tempsth = $dbh->prepare('select * FROM pg_class WHERE relpages = 42', {pg_prepare_now => 0}); my $new_count = $dbh->selectall_arrayref($SQL)->[0][0]; is ($new_count, $initial_count-1, $t); $t=q{DB handle method "pg_skip_deallocate" returns '1' for true when enabled}; $dbh->{pg_skip_deallocate} = 1; $result = $dbh->{pg_skip_deallocate}; is ($result, 1, $t); $t=q{DB handle method "pg_skip_deallocate" deallocates prepare statements when off}; $tempsth = $dbh->prepare('select * FROM pg_class WHERE reltuples = 42', {pg_prepare_now => 1}); $initial_count = $dbh->selectall_arrayref($SQL)->[0][0]; $tempsth = $dbh->prepare('select * FROM pg_class WHERE relpages = 42', {pg_prepare_now => 0}); $new_count = $dbh->selectall_arrayref($SQL)->[0][0]; is ($new_count, $initial_count, $t); $dbh->{pg_skip_deallocate} = 0; ## Test of all the informational pg_* database handle attributes $t='DB handle attribute "pg_db" returns at least one character'; $result = $dbh->{pg_protocol}; like ($result, qr/^[0-9]+$/, $t); $t='DB handle attribute "pg_db" returns at least one character'; $result = $dbh->{pg_db}; ok (length $result, $t); $t='DB handle attribute "pg_user" returns a value'; $result = $dbh->{pg_user}; ok (defined $result, $t); $t='DB handle attribute "pg_pass" returns a value'; $result = $dbh->{pg_pass}; ok (defined $result, $t); $t='DB handle attribute "pg_port" returns a number'; $result = $dbh->{pg_port}; like ($result, qr/^[0-9]+$/, $t); $t='DB handle attribute "pg_default_port" returns a number'; $result = $dbh->{pg_default_port}; like ($result, qr/^[0-9]+$/, $t); $t='DB handle attribute "pg_options" returns a value'; $result = $dbh->{pg_options}; ok (defined $result, $t); $t='DB handle attribute "pg_socket" returns a value'; $result = $dbh->{pg_socket}; like ($result, qr/^[0-9]+$/, $t); $t='DB handle attribute "pg_pid" returns a value'; $result = $dbh->{pg_pid}; like ($result, qr/^[0-9]+$/, $t); $t='Using INSERT returns correct number of rows affected'; $SQL = q{INSERT INTO dbd_pg_test (id) VALUES (444),(445),(446)}; is ($dbh->do($SQL), '3', $t); $t='Using UPDATE returns correct number of rows affected'; $SQL = q{UPDATE dbd_pg_test SET pname = 'update_test' WHERE id IN (444,445,446)}; is ($dbh->do($SQL), '3', $t); SKIP: { if ($pglibversion < 150000 or $pgversion < 150000) { skip ('Cannot test MERGE return value on pre 15 servers', 1); } $t='Using MERGE returns correct number of rows affected'; $SQL = q{MERGE into dbd_pg_test d using (select 1) as f on (d.id between 444 and 446) when matched then update set pname=''}; is ($dbh->do($SQL), '3', $t); } $t='Using DELETE returns correct number of rows affected'; $SQL = q{DELETE from dbd_pg_test WHERE id IN (444,445,446)}; is ($dbh->do($SQL), '3', $t); SKIP: { if ($pgversion < 80200 or $pgversion >= 19000) { skip ('Cannot test standard_conforming_strings on this version of Postgres', 3); } $t='DB handle attribute "pg_standard_conforming_strings" returns a valid value'; my $oldscs = $dbh->{pg_standard_conforming_strings}; like ($oldscs, qr/^on|off$/, $t); $t='DB handle attribute "pg_standard_conforming_strings" returns correct value'; $dbh->do('SET standard_conforming_strings = on'); $result = $dbh->{pg_standard_conforming_strings}; is ($result, 'on', $t); $t='DB handle attribute "pg_standard_conforming_strings" returns correct value'; $dbh->do('SET standard_conforming_strings = off'); $result = $dbh->{pg_standard_conforming_strings}; $dbh->do("SET standard_conforming_strings = $oldscs"); is ($result, 'off', $t); } # Attempt to test whether or not we can get unicode out of the database SKIP: { eval { require Encode; }; skip ('Encode module is needed for unicode tests', 5) if $@; my $server_encoding = $dbh->selectall_arrayref('SHOW server_encoding')->[0][0]; skip ('Cannot reliably test unicode without a UTF8 database', 5) if $server_encoding ne 'UTF8'; $SQL = 'SELECT pname FROM dbd_pg_test WHERE id = ?'; $sth = $dbh->prepare($SQL); $sth->execute(1); local $dbh->{pg_enable_utf8} = 1; $t='Quote method returns correct utf-8 characters'; my $utf8_str = chr(0x100).'dam'; # LATIN CAPITAL LETTER A WITH MACRON is ($dbh->quote( $utf8_str ), "'$utf8_str'", $t); $t='Able to insert unicode character into the database'; $SQL = "INSERT INTO dbd_pg_test (id, pname, val) VALUES (40, '$utf8_str', 'Orange')"; is ($dbh->do($SQL), '1', $t); $t='Able to read unicode (utf8) data from the database'; $sth->execute(40); my $name = $sth->fetchrow_array(); ok (Encode::is_utf8($name), $t); $t='Unicode (utf8) data returned from database is not corrupted'; is ($name, $utf8_str, $t); $t='ASCII text returned from database does have utf8 bit set'; $sth->finish(); $sth->execute(1); my $name2 = $sth->fetchrow_array(); ok (Encode::is_utf8($name2), $t); $sth->finish(); } # # Use the handle attribute "Warn" to check inheritance # undef $sth; $t='Attribute "Warn" attribute set on by default'; ok ($dbh->{Warn}, $t); $t='Statement handle inherits the "Warn" attribute'; $SQL = 'SELECT 123'; $sth = $dbh->prepare($SQL); $sth->finish(); ok ($sth->{Warn}, $t); $t='Able to turn off the "Warn" attribute in the database handle'; $dbh->{Warn} = 0; ok (! $dbh->{Warn}, $t); # # Test of the the following statement handle attributes: # NUM_OF_PARAMS, NUM_OF_FIELDS # NAME, NAME_lc, NAME_uc, NAME_hash, NAME_lc_hash, NAME_uc_hash # TYPE, PRECISION, SCALE, NULLABLE # ## First, all pre-execute checks: $t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with no placeholders'; $sth = $dbh->prepare('SELECT 123'); is ($sth->{'NUM_OF_PARAMS'}, 0, $t); $t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with three placeholders'; $sth = $dbh->prepare('SELECT 123 FROM pg_class WHERE relname=? AND reltuples=? and relpages=?'); is ($sth->{'NUM_OF_PARAMS'}, 3, $t); $t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with one placeholder'; $sth = $dbh->prepare('SELECT 123 AS "Sheep", CAST(id AS float) FROM dbd_pg_test WHERE id=?'); is ($sth->{'NUM_OF_PARAMS'}, 1, $t); $t='Statement handle attribute "NUM_OF_FIELDS" returns undef before execute'; is ($sth->{'NUM_OF_FIELDS'}, undef, $t); $t='Statement handle attribute "NAME" returns undef before execute'; is ($sth->{'NAME'}, undef, $t); $t='Statement handle attribute "NAME_lc" returns undef before execute'; is ($sth->{'NAME_lc'}, undef, $t); $t='Statement handle attribute "NAME_uc" returns undef before execute'; is ($sth->{'NAME_uc'}, undef, $t); $t='Statement handle attribute "NAME_hash" returns undef before execute'; is ($sth->{'NAME_hash'}, undef, $t); $t='Statement handle attribute "NAME_lc_hash" returns undef before execute'; is ($sth->{'NAME_lc_hash'}, undef, $t); $t='Statement handle attribute "NAME_uc_hash" returns undef before execute'; is ($sth->{'NAME_uc_hash'}, undef, $t); $t='Statement handle attribute "TYPE" returns undef before execute'; is ($sth->{'TYPE'}, undef, $t); $t='Statement handle attribute "PRECISION" returns undef before execute'; is ($sth->{'PRECISION'}, undef, $t); $t='Statement handle attribute "SCALE" returns undef before execute'; is ($sth->{'SCALE'}, undef, $t); $t='Statement handle attribute "NULLABLE" returns undef before execute'; is ($sth->{'NULLABLE'}, undef, $t); ## Now, some post-execute checks: $t='Statement handle attribute "NUM_OF_PARAMS" works correctly after execute'; $sth->execute(12); is ($sth->{'NUM_OF_PARAMS'}, 1, $t); $t='Statement handle attribute "NUM_OF_FIELDS" works correctly for SELECT statements'; is ($sth->{'NUM_OF_FIELDS'}, 2, $t); $t='Statement handle attribute "NAME" works correctly for SELECT statements'; my $colnames = ['Sheep', 'id']; my $actual = $sth->{'NAME'}; is_deeply ($actual, $colnames, $t); $t='Statement handle attribute "NAME" returns correct string lengths'; is (length($actual->[0]), 5, $t); is (length($actual->[1]), 2, $t); my $expected_length = 5; for my $x (@$actual) { is (length($x), $expected_length, $t); $expected_length -= 3; } $t='Statement handle attribute "NAME_lc" works correctly for SELECT statements'; $colnames = ['sheep', 'id']; is_deeply ($sth->{'NAME_lc'}, $colnames, $t); $t='Statement handle attribute "NAME_uc" works correctly for SELECT statements'; $colnames = ['SHEEP', 'ID']; is_deeply ($sth->{'NAME_uc'}, $colnames, $t); $t='Statement handle attribute "NAME_hash" works correctly for SELECT statements'; $colnames = {'Sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_lc_hash" works correctly for SELECT statements'; $colnames = {'sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_lc_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_uc_hash" works correctly for SELECT statements'; $colnames = {'SHEEP' => 0, ID => 1}; is_deeply ($sth->{'NAME_uc_hash'}, $colnames, $t); $t='Statement handle attribute "TYPE" works correctly for SELECT statements'; $colnames = [4, 6]; is_deeply ($sth->{'TYPE'}, $colnames, $t); $t='Statement handle attribute "PRECISION" works correctly'; $colnames = [4, 8]; is_deeply ($sth->{'PRECISION'}, $colnames, $t); $t='Statement handle attribute "SCALE" works correctly'; $colnames = [undef,undef]; is_deeply ($sth->{'SCALE'}, $colnames, $t); $t='Statement handle attribute "NULLABLE" works correctly'; $colnames = [2,2]; is_deeply ($sth->{NULLABLE}, $colnames, $t); ## Post-finish tasks: $sth->finish(); $t='Statement handle attribute "NUM_OF_PARAMS" works correctly after finish'; is ($sth->{'NUM_OF_PARAMS'}, 1, $t); $t='Statement handle attribute "NUM_OF_FIELDS" works correctly after finish'; is ($sth->{'NUM_OF_FIELDS'}, 2, $t); $t='Statement handle attribute "NAME" returns values after finish'; $colnames = ['Sheep', 'id']; is_deeply ($sth->{'NAME'}, $colnames, $t); $t='Statement handle attribute "NAME_lc" returns values after finish'; $colnames = ['sheep', 'id']; is_deeply ($sth->{'NAME_lc'}, $colnames, $t); $t='Statement handle attribute "NAME_uc" returns values after finish'; $colnames = ['SHEEP', 'ID']; is_deeply ($sth->{'NAME_uc'}, $colnames, $t); $t='Statement handle attribute "NAME_hash" works correctly after finish'; $colnames = {'Sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_lc_hash" works correctly after finish'; $colnames = {'sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_lc_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_uc_hash" works correctly after finish'; $colnames = {'SHEEP' => 0, ID => 1}; is_deeply ($sth->{'NAME_uc_hash'}, $colnames, $t); $t='Statement handle attribute "TYPE" works correctly after finish'; $colnames = [4, 6]; is_deeply ($sth->{'TYPE'}, $colnames, $t); $t='Statement handle attribute "PRECISION" works correctly after finish'; $colnames = [4, 8]; is_deeply ($sth->{'PRECISION'}, $colnames, $t); $t='Statement handle attribute "SCALE" works correctly after finish'; $colnames = [undef,undef]; is_deeply ($sth->{'SCALE'}, $colnames, $t); $t='Statement handle attribute "NULLABLE" works correctly after finish'; $colnames = [2,2]; is_deeply ($sth->{NULLABLE}, $colnames, $t); ## Test UPDATE queries $t='Statement handle attribute "NUM_OF_FIELDS" returns undef for updates'; $sth = $dbh->prepare('UPDATE dbd_pg_test SET id = 99 WHERE id = ?'); $sth->execute(1); is_deeply ($sth->{'NUM_OF_FIELDS'}, undef, $t); $t='Statement handle attribute "NAME" returns empty arrayref for updates'; is_deeply ($sth->{'NAME'}, [], $t); $t='Statement handle attribute "NAME_lc" returns empty arrayref for updates'; is_deeply ($sth->{'NAME_lc'}, [], $t); $t='Statement handle attribute "NAME_uc" returns empty arrayref for updates'; is_deeply ($sth->{'NAME_uc'}, [], $t); $t='Statement handle attribute "NAME_hash" returns empty hashref for updates'; is_deeply ($sth->{'NAME_hash'}, {}, $t); $t='Statement handle attribute "NAME_uc_hash" returns empty hashref for updates'; is_deeply ($sth->{'NAME_lc_hash'}, {}, $t); $t='Statement handle attribute "NAME_uc_hash" returns empty hashref for updates'; is_deeply ($sth->{'NAME_uc_hash'}, {}, $t); $t='Statement handle attribute "TYPE" returns empty arrayref for updates'; is_deeply ($sth->{'TYPE'}, [], $t); $t='Statement handle attribute "PRECISION" returns empty arrayref for updates'; is_deeply ($sth->{'PRECISION'}, [], $t); $t='Statement handle attribute "SCALE" returns empty arrayref for updates'; is_deeply ($sth->{'SCALE'}, [], $t); $t='Statement handle attribute "NULLABLE" returns empty arrayref for updates'; is_deeply ($sth->{'NULLABLE'}, [], $t); $dbh->do('UPDATE dbd_pg_test SET id = 1 WHERE id = 99'); ## Test UPDATE,INSERT, and DELETE with RETURNING SKIP: { if ($pgversion < 80200) { skip ('Cannot test RETURNING clause on pre 8.2 servers', 33); } $t='Statement handle attribute "NUM_OF_FIELDS" returns correct value for RETURNING updates'; $sth = $dbh->prepare('UPDATE dbd_pg_test SET id = 99 WHERE id = ? RETURNING id, expo, "CaseTest"'); $sth->execute(1); is_deeply ($sth->{'NUM_OF_FIELDS'}, 3, $t); $t='Statement handle attribute "NAME" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME'}, ['id','expo','CaseTest'], $t); $t='Statement handle attribute "NAME_lc" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_lc'}, ['id','expo','casetest'], $t); $t='Statement handle attribute "NAME_uc" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_uc'}, ['ID','EXPO','CASETEST'], $t); $t='Statement handle attribute "NAME_hash" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_hash'}, {id=>0, expo=>1, CaseTest=>2}, $t); $t='Statement handle attribute "NAME_lc_hash" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_lc_hash'}, {id=>0, expo=>1, casetest=>2}, $t); $t='Statement handle attribute "NAME_uc_hash" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_uc_hash'}, {ID=>0, EXPO=>1, CASETEST=>2}, $t); $t='Statement handle attribute "TYPE" returns correct info for RETURNING updates'; is_deeply ($sth->{'TYPE'}, [4,2,16], $t); $t='Statement handle attribute "PRECISION" returns correct info for RETURNING updates'; is_deeply ($sth->{'PRECISION'}, [4,6,1], $t); $t='Statement handle attribute "SCALE3" returns correct info for RETURNING updates'; is_deeply ($sth->{'SCALE'}, [undef,2,undef], $t); $t='Statement handle attribute "NULLABLE4" returns correct values for updates'; is_deeply ($sth->{'NULLABLE'}, [0,1,1], $t); $dbh->do('UPDATE dbd_pg_test SET id = 1 WHERE id = 99'); $t='Statement handle attribute "NUM_OF_FIELDS" returns correct value for RETURNING inserts'; $sth = $dbh->prepare('INSERT INTO dbd_pg_test(id) VALUES(?) RETURNING id, lii, expo, "CaseTest"'); $sth->execute(88); is_deeply ($sth->{'NUM_OF_FIELDS'}, 4, $t); $t='Statement handle attribute "NAME" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME'}, ['id','lii','expo','CaseTest'], $t); $t='Statement handle attribute "NAME_lc" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_lc'}, ['id','lii','expo','casetest'], $t); $t='Statement handle attribute "NAME_uc" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_uc'}, ['ID','LII','EXPO','CASETEST'], $t); $t='Statement handle attribute "NAME_hash" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_hash'}, {id=>0, lii=>1, expo=>2, CaseTest=>3}, $t); $t='Statement handle attribute "NAME_lc_hash" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_lc_hash'}, {id=>0, lii=>1, expo=>2, casetest=>3}, $t); $t='Statement handle attribute "NAME_uc_hash" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_uc_hash'}, {ID=>0, LII=>1, EXPO=>2, CASETEST=>3}, $t); $t='Statement handle attribute "TYPE" returns correct info for RETURNING inserts'; is_deeply ($sth->{'TYPE'}, [4,4,2,16], $t); $t='Statement handle attribute "PRECISION" returns correct info for RETURNING inserts'; is_deeply ($sth->{'PRECISION'}, [4,4,6,1], $t); $t='Statement handle attribute "SCALE" returns correct info for RETURNING inserts'; is_deeply ($sth->{'SCALE'}, [undef,undef,2,undef], $t); $t='Statement handle attribute "NULLABLE" returns empty arrayref for inserts'; is_deeply ($sth->{'NULLABLE'}, [0,0,1,1], $t); $t='Statement handle attribute "NUM_OF_FIELDS" returns correct value for RETURNING updates'; $sth = $dbh->prepare('DELETE FROM dbd_pg_test WHERE id = 88 RETURNING id, lii, expo, "CaseTest"'); $sth->execute(); is_deeply ($sth->{'NUM_OF_FIELDS'}, 4, $t); $t='Statement handle attribute "NAME" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME'}, ['id','lii','expo','CaseTest'], $t); $t='Statement handle attribute "NAME_lc" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME_lc'}, ['id','lii','expo','casetest'], $t); $t='Statement handle attribute "NAME_uc" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME_uc'}, ['ID','LII','EXPO','CASETEST'], $t); $t='Statement handle attribute "NAME_hash" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME_hash'}, {id=>0, lii=>1, expo=>2, CaseTest=>3}, $t); $t='Statement handle attribute "NAME_lc_hash" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME_lc_hash'}, {id=>0, lii=>1, expo=>2, casetest=>3}, $t); $t='Statement handle attribute "NAME_uc_hash" returns correct info for RETURNING deletes'; is_deeply ($sth->{'NAME_uc_hash'}, {ID=>0, LII=>1, EXPO=>2, CASETEST=>3}, $t); $t='Statement handle attribute "TYPE" returns correct info for RETURNING deletes'; is_deeply ($sth->{'TYPE'}, [4,4,2,16], $t); $t='Statement handle attribute "PRECISION" returns correct info for RETURNING deletes'; is_deeply ($sth->{'PRECISION'}, [4,4,6,1], $t); $t='Statement handle attribute "SCALE" returns correct info for RETURNING deletes'; is_deeply ($sth->{'SCALE'}, [undef,undef,2,undef], $t); $t='Statement handle attribute "NULLABLE" returns empty arrayref for deletes'; is_deeply ($sth->{'NULLABLE'}, [0,0,1,1], $t); } $t='Statement handle attribute "NUM_OF_FIELDS" returns correct value for SHOW commands'; $sth = $dbh->prepare('SHOW random_page_cost'); $sth->execute(); is_deeply ($sth->{'NUM_OF_FIELDS'}, 1, $t); $t='Statement handle attribute "NAME" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME'}, ['random_page_cost'], $t); $t='Statement handle attribute "NAME_lc" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME_lc'}, ['random_page_cost'], $t); $t='Statement handle attribute "NAME_uc" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME_uc'}, ['RANDOM_PAGE_COST'], $t); $t='Statement handle attribute "NAME_hash" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME_hash'}, {random_page_cost=>0}, $t); $t='Statement handle attribute "NAME_lc_hash" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME_lc_hash'}, {random_page_cost=>0}, $t); $t='Statement handle attribute "NAME_uc_hash" returns correct info for SHOW commands'; is_deeply ($sth->{'NAME_uc_hash'}, {RANDOM_PAGE_COST=>0}, $t); $t='Statement handle attribute "TYPE" returns correct info for SHOW commands'; is_deeply ($sth->{'TYPE'}, [-1], $t); $t='Statement handle attribute "PRECISION" returns correct info for SHOW commands'; is_deeply ($sth->{'PRECISION'}, [undef], $t); $t='Statement handle attribute "SCALE" returns correct info for SHOW commands'; is_deeply ($sth->{'SCALE'}, [undef], $t); $t='Statement handle attribute "NULLABLE" returns "unknown" (2) for SHOW commands'; is_deeply ($sth->{'NULLABLE'}, [2], $t); # # Test of the statement handle attribute "CursorName" # $t='Statement handle attribute "CursorName" returns undef'; $attrib = $sth->{CursorName}; is ($attrib, undef, $t); # # Test of the statement handle attribute "Database" # $t='Statement handle attribute "Database" matches the database handle'; $attrib = $sth->{Database}; is ($attrib, $dbh, $t); # # Test of the statement handle attribute "ParamValues" # $t='Statement handle attribute "ParamValues" works before execute'; $sth = $dbh->prepare('SELECT id FROM dbd_pg_test WHERE id=? AND val=? AND pname=?'); $sth->bind_param(1, 99); $sth->bind_param(2, undef); $sth->bind_param(3, 'Sparky'); $attrib = $sth->{ParamValues}; $expected = {1 => '99', 2 => undef, 3 => 'Sparky'}; is_deeply ($attrib, $expected, $t); $t='Statement handle attribute "ParamValues" works after execute'; $sth->execute(); $attrib = $sth->{ParamValues}; is_deeply ($attrib, $expected, $t); $t='Statement handle attribute "ParamValues" works with NULL-embedded strings'; my $tvalue = "aaa\000bbb"; # binary data with \0 $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id, val, pname) VALUES (?, ?, "")'); $sth->bind_param(1, 1234); $sth->bind_param(2, $tvalue, {pg_type => PG_BYTEA}); $attrib = $sth->{ParamValues}; is ($attrib->{2}, $tvalue); # # Test of the statement handle attribute "ParamTypes" # $t='Statement handle attribute "ParamTypes" works before execute'; $sth = $dbh->prepare('SELECT id FROM dbd_pg_test WHERE id=? AND val=? AND lii=?'); $sth->bind_param(1, 1, SQL_INTEGER); $sth->bind_param(2, 'TMW', SQL_VARCHAR); $attrib = $sth->{ParamTypes}; $expected = {1 => {TYPE => SQL_INTEGER}, 2 => {TYPE => SQL_VARCHAR}, 3 => undef}; is_deeply ($attrib, $expected, $t); $t='Statement handle attributes "ParamValues" and "ParamTypes" can be passed back to bind_param'; eval { my $vals = $sth->{ParamValues}; my $types = $sth->{ParamTypes}; $sth->bind_param($_, $vals->{$_}, $types->{$_} ) for keys %$types; }; is( $@, q{}, $t); $t='Statement handle attribute "ParamTypes" works before execute with named placeholders'; $sth = $dbh->prepare('SELECT id FROM dbd_pg_test WHERE id=:foobar AND val=:foobar2 AND lii=:foobar3'); $sth->bind_param(':foobar', 1, {pg_type => PG_INT4}); $sth->bind_param(':foobar2', 'TMW', {pg_type => PG_TEXT}); $attrib = $sth->{ParamTypes}; $expected = {':foobar' => {TYPE => SQL_INTEGER}, ':foobar2' => {TYPE => SQL_LONGVARCHAR}, ':foobar3' => undef}; is_deeply ($attrib, $expected, $t); $t='Statement handle attributes "ParamValues" and "ParamTypes" can be passed back to bind_param'; eval { my $vals = $sth->{ParamValues}; my $types = $sth->{ParamTypes}; $sth->bind_param($_, $vals->{$_}, $types->{$_} ) for keys %$types; }; is( $@, q{}, $t); $t='Statement handle attribute "ParamTypes" works after execute'; $sth->bind_param(':foobar3', 3, {pg_type => PG_INT2}); $sth->execute(); $attrib = $sth->{ParamTypes}; $expected->{':foobar3'} = {TYPE => SQL_SMALLINT}; is_deeply ($attrib, $expected, $t); $t='Statement handle attribute "ParamTypes" returns correct values'; $sth->bind_param(':foobar2', 3, {pg_type => PG_CIRCLE}); $attrib = $sth->{ParamTypes}{':foobar2'}; $expected = {pg_type => PG_CIRCLE}; is_deeply ($attrib, $expected, $t); # # Test of the statement handle attribute "RowsInCache" # $t='Statement handle attribute "RowsInCache" returns undef'; $attrib = $sth->{RowsInCache}; is ($attrib, undef, $t); # # Test of the statement handle attribute "pg_size" # $t='Statement handle attribute "pg_size" works'; $SQL = q{SELECT id, pname, val, score, Fixed, pdate, "CaseTest" FROM dbd_pg_test}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->{pg_size}; $expected = [qw(4 -1 -1 8 -1 8 1)]; is_deeply ($result, $expected, $t); # # Test of the statement handle attribute "pg_type" # $t='Statement handle attribute "pg_type" works'; $sth->execute(); $result = $sth->{pg_type}; $expected = [qw(int4 varchar text float8 bpchar timestamp bool)]; is_deeply ($result, $expected, $t); $sth->finish(); # # Test of the statement handle attribute "pg_oid_status" # $t='Statement handle attribute "pg_oid_status" returned a numeric value after insert'; $SQL = q{INSERT INTO dbd_pg_test (id, val) VALUES (?, 'lemon')}; $sth = $dbh->prepare($SQL); $sth->bind_param('$1','',SQL_INTEGER); $sth->execute(500); $result = $sth->{pg_oid_status}; like ($result, qr/^[0-9]+$/, $t); # # Test of the statement handle attribute "pg_cmd_status" # ## INSERT DELETE UPDATE SELECT for ( q{INSERT INTO dbd_pg_test (id,val) VALUES (400, 'lime')}, q{DELETE FROM dbd_pg_test WHERE id=1}, q{UPDATE dbd_pg_test SET id=2 WHERE id=2}, q{SELECT * FROM dbd_pg_test}, ) { $expected = substr($_,0,6); $t=qq{Statement handle attribute "pg_cmd_status" works for '$expected'}; $sth = $dbh->prepare($_); $sth->execute(); $result = $sth->{pg_cmd_status}; $sth->finish(); like ($result, qr/^$expected/, $t); } # # Test of the datbase and statement handle attribute "pg_async_status" # $t=q{Statement handle attribute "pg_async_status" returns a 0 as default value}; is ($sth->{pg_async_status}, 0, $t); $t=q{Database handle attribute "pg_async_status" returns a 0 as default value}; is ($dbh->{pg_async_status}, 0, $t); $t=q{Statement handle attribute "pg_async_status" returns a 0 after a normal prepare}; $sth = $dbh->prepare('SELECT 123'); is ($sth->{pg_async_status}, 0, $t); $t=q{Database handle attribute "pg_async_status" returns a 0 after a normal prepare}; is ($dbh->{pg_async_status}, 0, $t); $t=q{Statement handle attribute "pg_async_status" returns a 0 after a normal execute}; $sth->execute(); is ($sth->{pg_async_status}, 0, $t); $t=q{Database handle attribute "pg_async_status" returns a 0 after a normal execute}; is ($sth->{pg_async_status}, 0, $t); $t=q{Statement handle attribute "pg_async_status" returns a 0 after an asynchronous prepare}; $sth = $dbh->prepare('SELECT 123', { pg_async => PG_ASYNC }); is ($sth->{pg_async_status}, 0, $t); $t=q{Database handle attribute "pg_async_status" returns a 0 after an asynchronous prepare}; is ($dbh->{pg_async_status}, 0, $t); $sth->execute(); $t=q{Statement handle attribute "pg_async_status" returns a 1 after an asynchronous execute}; is ($sth->{pg_async_status}, 1, $t); $t=q{Database handle attribute "pg_async_status" returns a 1 after an asynchronous execute}; is ($dbh->{pg_async_status}, 1, $t); $t=q{Statement handle attribute "pg_async_status" returns a 0 after a cancel}; $dbh->pg_cancel(); is ($sth->{pg_async_status}, 0, $t); $t=q{Database handle attribute "pg_async_status" returns a 0 after a cancel}; is ($dbh->{pg_async_status}, 0, $t); sleep 3; # # Test of the handle attribute "Active" # $t='Database handle attribute "Active" is true while connected'; $attrib = $dbh->{Active}; is ($attrib, 1, $t); $sth = $dbh->prepare('SELECT 123 UNION SELECT 456'); $attrib = $sth->{Active}; is ($attrib, '', $t); $t='Statement handle attribute "Active" is true after SELECT'; $sth->execute(); $attrib = $sth->{Active}; is ($attrib, 1, $t); $t='Statement handle attribute "Active" is true when rows remaining'; $sth->fetchrow_arrayref(); $attrib = $sth->{Active}; is ($attrib, 1, $t); $t='Statement handle attribute "Active" is false after finish called'; $sth->finish(); $attrib = $sth->{Active}; is ($attrib, '', $t); # # Test of the handle attribute "Executed" # my $dbh3 = connect_database({quickreturn => 1}); $dbh3->{AutoCommit} = 0; $t='Database handle attribute "Executed" begins false'; is ($dbh3->{Executed}, '', $t); $t='Database handle attribute "Executed" stays false after prepare()'; $sth = $dbh3->prepare('SELECT 12345'); is ($dbh3->{Executed}, '', $t); $t='Statement handle attribute "Executed" begins false'; is ($sth->{Executed}, '', $t); $t='Statement handle attribute "Executed" is true after execute()'; $sth->execute(); is ($sth->{Executed}, 1, $t); $t='Database handle attribute "Executed" is true after execute()'; is ($dbh3->{Executed}, 1, $t); $t='Statement handle attribute "Executed" is true after finish()'; $sth->finish(); is ($sth->{Executed}, 1, $t); $t='Database handle attribute "Executed" is true after finish()'; is ($dbh3->{Executed}, 1, $t); $t='Database handle attribute "Executed" is false after commit()'; $dbh3->commit(); is ($dbh3->{Executed}, '', $t); $t='Statement handle attribute "Executed" is true after commit()'; is ($sth->{Executed}, 1, $t); $t='Database handle attribute "Executed" is true after do()'; $dbh3->do('SELECT 1234'); is ($dbh3->{Executed}, 1, $t); $t='Database handle attribute "Executed" is false after rollback()'; $dbh3->commit(); is ($dbh3->{Executed}, '', $t); $t='Statement handle attribute "Executed" is true after rollback()'; is ($sth->{Executed}, 1, $t); # # Test of the handle attribute "Kids" # $t='Database handle attribute "Kids" is set properly'; $attrib = $dbh3->{Kids}; is ($attrib, 1, $t); $t='Database handle attribute "Kids" works'; my $sth2 = $dbh3->prepare('SELECT 234'); $attrib = $dbh3->{Kids}; is ($attrib, 2, $t); $t='Statement handle attribute "Kids" is zero'; $attrib = $sth2->{Kids}; is ($attrib, 0, $t); # # Test of the handle attribute "ActiveKids" # $t='Database handle attribute "ActiveKids" is set properly'; $attrib = $dbh3->{ActiveKids}; is ($attrib, 0, $t); $t='Database handle attribute "ActiveKids" works'; $sth2 = $dbh3->prepare('SELECT 234'); $sth2->execute(); $attrib = $dbh3->{ActiveKids}; is ($attrib, 1, $t); $t='Statement handle attribute "ActiveKids" is zero'; $attrib = $sth2->{ActiveKids}; is ($attrib, 0, $t); $sth2->finish(); # # Test of the handle attribute "CachedKids" # $t='Database handle attribute "CachedKids" is set properly'; $attrib = $dbh3->{CachedKids}; is (keys %$attrib, 0, $t); my $sth4 = $dbh3->prepare_cached('select 1'); $attrib = $dbh3->{CachedKids}; is (keys %$attrib, 1, $t); $sth4->finish(); $dbh3->disconnect(); # # Test of the handle attribute "Type" # $t='Database handle attribute "Type" is set properly'; $attrib = $dbh->{Type}; is ($attrib, 'db', $t); $t='Statement handle attribute "Type" is set properly'; $sth = $dbh->prepare('SELECT 1'); $attrib = $sth->{Type}; is ($attrib, 'st', $t); # # Test of the handle attribute "ChildHandles" # Need a separate connection to keep the output size down # my $dbh4 = connect_database({quickreturn => 2}); $t='Database handle attribute "ChildHandles" is an empty list on startup'; $attrib = $dbh4->{ChildHandles}; is_deeply ($attrib, [], $t); $t='Statement handle attribute "ChildHandles" is an empty list on creation'; { my $sth5 = $dbh4->prepare('SELECT 1'); $attrib = $sth5->{ChildHandles}; is_deeply ($attrib, [], $t); $t='Database handle attribute "ChildHandles" contains newly created statement handle'; $attrib = $dbh4->{ChildHandles}; is_deeply ($attrib, [$sth5], $t); $sth4->finish(); } ## sth5 now out of scope $t='Database handle attribute "ChildHandles" has undef for destroyed statement handle'; $attrib = $dbh4->{ChildHandles}; is_deeply ($attrib, [undef], $t); $dbh4->disconnect(); # # Test of the handle attribute "CompatMode" # $t='Database handle attribute "CompatMode" is set properly'; $attrib = $dbh->{CompatMode}; ok (!$attrib, $t); # # Test of the handle attribute PrintError # $t='Database handle attribute "PrintError" is set properly'; $attrib = $dbh->{PrintError}; is ($attrib, '', $t); # Make sure that warnings are sent back to the client $SQL = 'Testing the DBD::Pg modules error handling -?-'; $dbh->do(q{SET client_min_messages = 'NOTICE'}); $warning = ''; local $SIG{__WARN__} = sub { $warning = shift; }; $dbh->{RaiseError} = 0; $t='Warning thrown when database handle attribute "PrintError" is on'; $dbh->{PrintError} = 1; $sth = $dbh->prepare($SQL); $sth->execute(); isnt ($warning, undef, $t); $t='No warning thrown when database handle attribute "PrintError" is off'; undef $warning; $dbh->{PrintError} = 0; $sth = $dbh->prepare($SQL); $sth->execute(); is ($warning, undef, $t); ## Special case in which errors are not sent to the client! SKIP: { $t = q{When client_min_messages is FATAL, we do our best to alert the caller it's a Bad Idea}; $dbh->do(q{SET client_min_messages = 'FATAL'}); skip 'This version of PostgreSQL caps client_min_messages to ERROR', 1 unless $dbh->selectrow_array('SHOW client_min_messages') eq 'fatal'; $dbh->{RaiseError} = 0; $dbh->{AutoCommit} = 1; eval { $dbh->do('SELECT 1 FROM nonesuh'); }; my $errorstring = $dbh->errstr; like ($errorstring, qr/Perhaps client_min_messages/, $t); } $dbh->rollback(); $dbh->do(q{SET client_min_message = 'NOTICE'}); $dbh->{RaiseError} = 1; $dbh->{AutoCommit} = 0; # # Test of the handle attribute RaiseError # $t='No error produced when database handle attribute "RaiseError" is off'; $dbh->{RaiseError} = 0; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; is ($@, q{}, $t); $t='Error produced when database handle attribute "RaiseError" is off'; $dbh->{RaiseError} = 1; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; isnt ($@, q{}, $t); # # Test of the handle attribute HandleError # $t='Database handle attribute "HandleError" is set properly'; $attrib = $dbh->{HandleError}; ok (!$attrib, $t); $t='Database handle attribute "HandleError" works'; undef $warning; $dbh->{HandleError} = sub { $warning = shift; }; $sth = $dbh->prepare($SQL); $sth->execute(); ok ($warning, $t); $t='Database handle attribute "HandleError" modifies error messages'; undef $warning; $dbh->{HandleError} = sub { $_[0] = "Slonik $_[0]"; 0; }; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; like ($@, qr/^Slonik/, $t); $dbh->{HandleError}= undef; $dbh->rollback(); # # Test of the handle attribute HandleSetErr # $t='Database handle attribute "HandleSetErr" is set properly'; $attrib = $dbh->{HandleSetErr}; ok (!$attrib, $t); $t='Database handle attribute "HandleSetErr" works as expected'; undef $warning; $dbh->{HandleSetErr} = sub { #my ($h,$err,$errstr,$state,$method) = @_; $_[1] = 42; $_[2] = 'ERRSTR'; $_[3] = '33133'; return; }; eval {$sth = $dbh->last_insert_id('cat', 'schema', 'table', 'col', ['notahashref']); }; ## Changing the state does not work yet. like ($@, qr{ERRSTR}, $t); is ($dbh->errstr, 'ERRSTR', $t); ## nospellcheck is ($dbh->err, '42', $t); $dbh->{HandleSetErr} = 0; my $x = $dbh->errstr; $t='Database handle method "errstr" gives correct string length'; is (length($x), 6, $t); $dbh->rollback(); eval { $dbh->do('SELECT 1/0'); }; $x = $dbh->errstr; ok (length($x) > 6, $t); $dbh->rollback(); # # Test of the handle attribute "ErrCount" # $t='Database handle attribute "ErrCount" starts out at 0'; $dbh4 = connect_database({quickreturn => 2}); is ($dbh4->{ErrCount}, 0, $t); $t='Database handle attribute "ErrCount" is incremented with set_err()'; eval {$sth = $dbh4->last_insert_id('cat', 'schema', 'table', 'col', ['notahashref']); }; is ($dbh4->{ErrCount}, 1, $t); $dbh4->disconnect(); # # Test of the handle attribute "ShowErrorStatement" # $t='Database handle attribute "ShowErrorStatement" starts out false'; is ($dbh->{ShowErrorStatement}, '', $t); $t='Database handle attribute "ShowErrorStatement" has no effect if not set'; $SQL = 'Testing the ShowErrorStatement attribute'; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; unlike ($@, qr{for Statement "Testing}, $t); $t='Database handle attribute "ShowErrorStatement" adds statement to errors'; $dbh->{ShowErrorStatement} = 1; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; like ($@, qr{for Statement "Testing}, $t); $t='Database handle attribute "ShowErrorStatement" adds statement and placeholders to errors via execute() with null args'; $SQL = q{SELECT 'Another ShowErrorStatement Test' FROM pg_class WHERE relname = ? AND reltuples = ?}; eval { $sth = $dbh->prepare($SQL); $sth->execute(123); }; like ($@, qr{with ParamValues}, $t); $t='Statement handle attribute "ShowErrorStatement" adds statement and placeholders to errors via execute()'; $SQL = q{SELECT 'Another ShowErrorStatement Test' FROM pg_class WHERE relname = ? AND reltuples = ?}; eval { $sth = $dbh->prepare($SQL); $sth->execute(123,456); }; like ($@, qr{with ParamValues: 1='123', 2='456'}, $t); $t='Database handle attribute "ShowErrorStatement" adds statement and placeholders to errors via do()'; $SQL = q{SELECT 'Another ShowErrorStatement Test' FROM pg_class WHERE relname = ? AND reltuples = ?}; eval { $dbh->do($SQL, {}, 123, 456); }; like ($@, qr{with ParamValues: 1='123', 2='456'}, $t); $dbh->commit(); # # Test of the handle attribute TraceLevel # $t='Database handle attribute "TraceLevel" returns a number'; $attrib = $dbh->{TraceLevel}; like ($attrib, qr/^[0-9]$/, $t); # # Test of the handle attribute FetchHashKeyName # # The default is mixed case ("NAME"); $t='Database handle attribute "FetchHashKeyName" is set properly'; $attrib = $dbh->{FetchHashKeyName}; is ($attrib, 'NAME', $t); $t='Database handle attribute "FetchHashKeyName" works with the default value of NAME'; $SQL = q{SELECT "CaseTest" FROM dbd_pg_test}; $sth = $dbh->prepare($SQL); $sth->execute(); my ($colname) = keys %{$sth->fetchrow_hashref()}; $sth->finish(); is ($colname, 'CaseTest', $t); $t='Database handle attribute "FetchHashKeyName" can be changed'; $dbh->{FetchHashKeyName} = 'NAME_lc'; $attrib = $dbh->{FetchHashKeyName}; is ($attrib, 'NAME_lc', $t); $t='Database handle attribute "FetchHashKeyName" works with a value of NAME_lc'; $sth = $dbh->prepare($SQL); $sth->execute(); ($colname) = keys %{$sth->fetchrow_hashref()}; is ($colname, 'casetest', $t); $sth->finish(); $t='Database handle attribute "FetchHashKeyName" works with a value of NAME_uc'; $dbh->{FetchHashKeyName} = 'NAME_uc'; $sth = $dbh->prepare($SQL); $sth->execute(); ($colname) = keys %{$sth->fetchrow_hashref()}; $sth->finish(); $dbh->{FetchHashKeyName} = 'NAME'; is ($colname, 'CASETEST', $t); # # Test of the handle attribute ChopBlanks # $t='Database handle attribute "ChopBlanks" is set properly'; $attrib = $dbh->{ChopBlanks}; ok (!$attrib, $t); $dbh->do('DELETE FROM dbd_pg_test'); $dbh->do(q{INSERT INTO dbd_pg_test (id, fixed, val) VALUES (3, ' Fig', ' Raspberry ')}); $t='Database handle attribute "ChopBlanks" = 0 returns correct value for fixed-length column'; $dbh->{ChopBlanks} = 0; my ($val) = $dbh->selectall_arrayref(q{SELECT fixed FROM dbd_pg_test WHERE id = 3})->[0][0]; is ($val, ' Fig ', $t); $t='Database handle attribute "ChopBlanks" = 0 returns correct value for variable-length column'; ($val) = $dbh->selectrow_array(q{SELECT val FROM dbd_pg_test WHERE id = 3}); is ($val, ' Raspberry ', $t); $t='Database handle attribute "ChopBlanks" = 1 returns correct value for fixed-length column'; $dbh->{ChopBlanks}=1; ($val) = $dbh->selectall_arrayref(q{SELECT fixed FROM dbd_pg_test WHERE id = 3})->[0][0]; is ($val, ' Fig', $t); $t='Database handle attribute "ChopBlanks" = 1 returns correct value for variable-length column'; ($val) = $dbh->selectrow_array(q{SELECT val FROM dbd_pg_test WHERE id = 3}); $dbh->do('DELETE from dbd_pg_test'); is ($val, ' Raspberry ', $t); # # Test of the handle attribute LongReadLen # $t='Handle attribute "LongReadLen" has been set properly'; $attrib = $dbh->{LongReadLen}; ok ($attrib, $t); # # Test of the handle attribute LongTruncOk # $t='Handle attribute "LongTruncOk" has been set properly'; $attrib = $dbh->{LongTruncOk}; ok (!$attrib, $t); # # Test of the handle attribute TaintIn # $t='Handle attribute "TaintIn" has been set properly'; $attrib = $dbh->{TaintIn}; is ($attrib, '', $t); # # Test of the handle attribute TaintOut # $t='Handle attribute "TaintOut" has been set properly'; $attrib = $dbh->{TaintOut}; is ($attrib, '', $t); # # Test of the handle attribute Taint # $t='Handle attribute "Taint" has been set properly'; $attrib = $dbh->{Taint}; is ($attrib, '', $t); $t='The value of handle attribute "Taint" can be changed'; $dbh->{Taint}=1; $attrib = $dbh->{Taint}; is ($attrib, 1, $t); $t='Changing handle attribute "Taint" changes "TaintIn"'; $attrib = $dbh->{TaintIn}; is ($attrib, 1, $t); $t='Changing handle attribute "Taint" changes "TaintOut"'; $attrib = $dbh->{TaintOut}; is ($attrib, 1, $t); # # Not tested: handle attribute Profile # # # Test of the database handle attribute "ReadOnly" # SKIP: { if ($DBI::VERSION < 1.55) { skip ('DBI must be at least version 1.55 to test DB attribute "ReadOnly"', 8); } $t='Database handle attribute "ReadOnly" starts out undefined'; $dbh->commit(); ## This fails on some boxes, so we pull back all information to display why my ($helpconnect2, $connerror2); ($helpconnect2, $connerror2, $dbh4) = connect_database(); if (! defined $dbh4) { die "Database connection failed: helpconnect is $helpconnect2, error is $connerror2\n"; } $dbh4->trace(0); is ($dbh4->{ReadOnly}, undef, $t); $t='Database handle attribute "ReadOnly" allows SELECT queries to work when on'; $dbh4->{ReadOnly} = 1; $result = $dbh4->selectall_arrayref('SELECT 12345')->[0][0]; is ($result, 12345, $t); $t='Database handle attribute "ReadOnly" prevents INSERT queries from working when on'; $SQL = 'INSERT INTO dbd_pg_test (id) VALUES (50)'; eval { $dbh4->do($SQL); }; is($dbh4->state, '25006', $t); $dbh4->rollback(); $sth = $dbh4->prepare($SQL); eval { $sth->execute(); }; is($dbh4->state, '25006', $t); $dbh4->rollback(); $t='Database handle attribute "ReadOnly" allows INSERT queries when switched off'; $dbh4->{ReadOnly} = 0; eval { $dbh4->do($SQL); }; is ($@, q{}, $t); $dbh4->rollback(); $t='Database handle attribute "ReadOnly" allows INSERT queries when switched off'; $dbh4->{ReadOnly} = 0; eval { $dbh4->do($SQL); }; is ($@, q{}, $t); $dbh4->rollback(); $dbh4->{ReadOnly} = 1; $dbh4->{AutoCommit} = 1; $t='Database handle attribute "ReadOnly" has no effect if AutoCommit is on'; eval { $dbh4->do($SQL); }; is ($@, q{}, $t); my $delete = 'DELETE FROM dbd_pg_test WHERE id = 50'; $dbh4->do($delete); $sth = $dbh4->prepare($SQL); eval { $sth->execute(); }; is ($@, q{}, $t); $dbh4->disconnect(); } # # Test of the database handle attribute InactiveDestroy # This one must be the last test performed! # $t='Database handle attribute "InactiveDestroy" is set properly'; $attrib = $dbh->{InactiveDestroy}; ok (!$attrib, $t); # Disconnect in preparation for the fork tests ok ($dbh->disconnect(), 'Disconnect from database'); $t='Database handle attribute "Active" is false after disconnect'; $attrib = $dbh->{Active}; is ($attrib, '', $t); SKIP: { skip ('Cannot test database handle "AutoInactiveDestroy" on a non-forking system', 8) if $^O =~ /Win/; require Test::Simple; skip ('Test::Simple version 0.47 or better required for testing of attribute "AutoInactiveDestroy"', 8) if $Test::Simple::VERSION < 0.47; # Test of forking. Hang on to your hats my $answer = 42; $SQL = "SELECT $answer FROM dbd_pg_test WHERE id > ? LIMIT 1"; for my $destroy (0,1) { $dbh = connect_database({nosetup => 1, AutoCommit => 1 }); $dbh->{'AutoInactiveDestroy'} = $destroy; $dbh->{'pg_server_prepare'} = 1; $sth = $dbh->prepare($SQL); $sth->execute(1); $sth->finish(); # Desired flow: parent test, child test, child kill, parent test if (fork) { $t=qq{Parent in fork test is working properly ("AutoInactiveDestroy" = $destroy)}; $sth->execute(1); $val = $sth->fetchall_arrayref()->[0][0]; is ($val, $answer, $t); # Let the child exit first select(undef,undef,undef,0.3); } else { # Child select(undef,undef,undef,0.1); # Age before beauty exit; ## Calls disconnect via DESTROY unless AutoInactiveDestroy set } if ($destroy) { $t=qq{Ping works after the child has exited ("AutoInactiveDestroy" = $destroy)}; ok ($dbh->ping(), $t); $t='Successful ping returns a SQLSTATE code of 00000 (empty string)'; my $state = $dbh->state(); is ($state, '', $t); $t='Statement handle works after forking'; $sth->execute(1); $val = $sth->fetchall_arrayref()->[0][0]; is ($val, $answer, $t); } else { $t=qq{Ping fails after the child has exited ("AutoInactiveDestroy" = $destroy)}; is ( $dbh->ping(), 0, $t); $t=qq{pg_ping gives an error code of -2 after the child has exited ("AutoInactiveDestroy" = $destroy)}; is ( $dbh->pg_ping(), -2, $t); ok ($dbh->disconnect(), 'Disconnect from database'); } } } # Disconnect in preparation for the fork tests ok ($dbh->disconnect(), 'Disconnect from database'); $t='Database handle attribute "Active" is false after disconnect'; $attrib = $dbh->{Active}; is ($attrib, '', $t); SKIP: { skip ('Cannot test database handle "InactiveDestroy" on a non-forking system', 7) if $^O =~ /Win/; require Test::Simple; skip ('Test::Simple version 0.47 or better required for testing of attribute "InactiveDestroy"', 7) if $Test::Simple::VERSION < 0.47; # Test of forking. Hang on to your hats my $answer = 42; $SQL = "SELECT $answer FROM dbd_pg_test WHERE id > ? LIMIT 1"; for my $destroy (0,1) { local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /DESTROY failed: no connection/ }; # shut up destroy warning $dbh = connect_database({nosetup => 1, AutoCommit => 1}); $sth = $dbh->prepare($SQL); $sth->execute(1); $sth->finish(); # Desired flow: parent test, child test, child kill, parent test if (fork) { $t=qq{Parent in fork test is working properly ("InactiveDestroy" = $destroy)}; $sth->execute(1); $val = $sth->fetchall_arrayref()->[0][0]; is ($val, $answer, $t); # Let the child exit first select(undef,undef,undef,0.5); } else { # Child $dbh->{InactiveDestroy} = $destroy; select(undef,undef,undef,0.1); # Age before beauty exit; ## Calls disconnect via DESTROY unless InactiveDestroy set } if ($destroy) { $t=qq{Ping works after the child has exited ("InactiveDestroy" = $destroy)}; ok ($dbh->ping(), $t); $t='Successful ping returns a SQLSTATE code of 00000 (empty string)'; my $state = $dbh->state(); is ($state, '', $t); $t='Statement handle works after forking'; $sth->execute(1); $val = $sth->fetchall_arrayref()->[0][0]; is ($val, $answer, $t); } else { $t=qq{Ping fails after the child has exited ("InactiveDestroy" = $destroy)}; is ( $dbh->ping(), 0, $t); $t=qq{pg_ping gives an error code of -2 after the child has exited ("InactiveDestroy" = $destroy)}; is ( $dbh->pg_ping(), -2,$t); } } } cleanup_database($dbh,'test'); $dbh->disconnect(); DBD-Pg-3.20.2/t/10_pg_error_field.t0000644000175000017500000001141215166170753015111 0ustar greggreg#!perl ## Test of $dbh->pg_error_field use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Test::More; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } my $t='Connect to database for pg_error_field testing'; isnt ($dbh, undef, $t); $t = 'Call to pg_error_field gives a usage error if no specific field given'; eval { $dbh->pg_error_field; }; like ($@, qr{Usage: }, $t); $t = 'Call to pg_error_field gives an error if a null field is given'; eval { no warnings; $dbh->pg_error_field(undef); }; like ($@, qr{Invalid error field}, $t); eval { $dbh->pg_error_field(''); }; like ($@, qr{Invalid error field}, $t); my $test_table = 'dbdpg_error_field_test'; my $fields = qq{ pg_diag_severity_nonlocalized | 100001 | undef | ERROR | ERROR | ERROR | ERROR pg_diag_severity | 70400 | undef | ERROR | ERROR | ERROR | ERROR pg_diag_sqlstate,state | 70400 | undef | 22012 | 42703 | 23514 | undef pg_diag_message_primary | 70400 | undef | division by zero | column "foobar" does not exist | violates check constraint "rainbow" | undef pg_diag_message_detail,detail | 90200 | undef | undef | undef | Failing row contains | undef pg_diag_message_hint,hint | 70400 | undef | undef | undef | undef | undef pg_diag_statement_position | 80200 | undef | undef | 8 | undef | undef pg_diag_internal_position | 70400 | undef | undef | undef | undef | undef pg_diag_internal_query | 70400 | undef | undef | undef | undef | undef pg_diag_context | 70400 | undef | undef | undef | undef | undef pg_diag_schema_name,schema | 90300 | undef | undef | undef | dbd_pg_testschema | undef pg_diag_table_name,table | 90300 | undef | undef | undef | $test_table | undef pg_diag_column_name,column | 90300 | undef | undef | undef | undef | undef pg_diag_datatype_name,datatype,type | 90300 | undef | undef | undef | undef | undef pg_diag_constraint_name,constraint | 90400 | undef | undef | undef | rainbow | undef pg_diag_source_file | 70400 | undef | \\.c\\z | parse_ | execMain.c | undef pg_diag_source_line | 70400 | undef | number | number | number | undef pg_diag_source_function | 70400 | undef | int4div | Column | ExecConstraints | undef }; $dbh->do("CREATE TABLE $test_table (id int, constraint rainbow check(id < 10) )"); $dbh->commit(); my $pgversion = $dbh->{pg_server_version}; for my $loop (1..5) { if (2==$loop) { eval { $dbh->do('SELECT 1/0'); }; } if (3==$loop) { eval { $dbh->do('SELECT foobar FROM pg_class'); }; } if (4==$loop) { eval { $dbh->do("INSERT INTO $test_table VALUES (123)"); }; } if (5==$loop) { my $sth = $dbh->prepare("INSERT INTO $test_table VALUES (?)"); eval { $sth->execute(234); }; } for (split /\n/ => $fields) { next unless /pg/; my ($lfields,$minversion,@error) = split /\s+\|\s+/; next if $pgversion < $minversion; for my $field (split /,/ => $lfields) { my $expected = $error[5==$loop ? 3 : $loop-1]; $expected = undef if $expected eq 'undef'; if (defined $expected) { $expected = ($expected eq 'number') ? qr/^[0-9]+$/ : qr/$expected/i; } my $field_copy = "[$field]"; # force perl to copy the string contents $t = "(query $loop) Calling pg_error_field returns expected value for field $field"; my $actual = $dbh->pg_error_field($field); defined $expected ? like ($actual, $expected, $t) : is($actual, undef, $t); is "[$field]", $field_copy, "(query $loop) Calling pg_error_field does not modify its argument: $field"; $field = uc $field; $t = "(query $loop) Calling pg_error_field returns expected value for field $field"; $actual = $dbh->pg_error_field($field); defined $expected ? like ($actual, $expected, $t) : is($actual, undef, $t); if ($field =~ s/PG_DIAG_//) { $t = "(query $loop) Calling pg_error_field returns expected value for field $field"; $actual = $dbh->pg_error_field($field); defined $expected ? like ($actual, $expected, $t) : is($actual, undef, $t); } } } $dbh->rollback(); } $dbh->do("DROP TABLE $test_table"); $dbh->commit(); $dbh->disconnect(); done_testing(); DBD-Pg-3.20.2/t/20savepoints.t0000644000175000017500000000316315116315266014163 0ustar greggreg#!perl ## Test savepoint functionality use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Test::More; use DBI ':sql_types'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 3; isnt ($dbh, undef, 'Connect to database for savepoint testing'); my $t; my $str = 'Savepoint Test'; my $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id,pname) VALUES (?,?)'); ## Create 500 without a savepoint $sth->execute(500,$str); ## Create 501 inside a savepoint and roll it back $dbh->pg_savepoint('dbd_pg_test_savepoint'); $sth->execute(501,$str); $dbh->pg_rollback_to('dbd_pg_test_savepoint'); $dbh->pg_rollback_to('dbd_pg_test_savepoint'); ## Yes, we call it twice ## Create 502 after the rollback: $sth->execute(502,$str); $dbh->commit; $t='Only row 500 and 502 should be committed'; my $ids = $dbh->selectcol_arrayref('SELECT id FROM dbd_pg_test WHERE pname = ?',undef,$str); ok (eq_set($ids, [500, 502]), $t); ## Create 503, then release the savepoint $dbh->pg_savepoint('dbd_pg_test_savepoint'); $sth->execute(503,$str); $dbh->pg_release('dbd_pg_test_savepoint'); ## Create 504 outside of any savepoint $sth->execute(504,$str); $dbh->commit; $t='Implicit rollback on deallocate should rollback to last savepoint'; $ids = $dbh->selectcol_arrayref('SELECT id FROM dbd_pg_test WHERE pname = ?',undef,$str); ok (eq_set($ids, [500, 502, 503, 504]), $t); $dbh->do('DELETE FROM dbd_pg_test'); $dbh->commit(); cleanup_database($dbh,'test'); $dbh->disconnect(); DBD-Pg-3.20.2/t/99cleanup.t0000644000175000017500000000147715116315266013445 0ustar greggreg#!perl ## Cleanup all database objects we may have created ## Shutdown the test database if we created one ## Remove the entire directory if it was created as a tempdir use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Test::More tests => 1; if ($ENV{DBDPG_NOCLEANUP}) { pass (q{No cleaning up because ENV 'DBDPG_NOCLEANUP' is set}); exit; } require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database({nosetup => 1, nocreate => 1, norestart => 1}); SKIP: { if (! $dbh) { skip ('Connection to database failed, cannot cleanup', 1); } isnt ($dbh, undef, 'Connect to database for cleanup'); cleanup_database($dbh); } $dbh->disconnect() if defined $dbh and ref $dbh; shutdown_test_database(); unlink 'README.testdatabase'; DBD-Pg-3.20.2/t/00_signature.t0000644000175000017500000000154415116315266014127 0ustar greggreg#!perl ## Test that our SIGNATURE file is valid - requires TEST_SIGNATURE env use 5.008001; use strict; use warnings; use Test::More; select(($|=1,select(STDERR),$|=1)[1]); if (!$ENV{TEST_SIGNATURE}) { plan skip_all => 'Set the environment variable TEST_SIGNATURE to enable this test'; } plan tests => 1; SKIP: { if (!eval { require Module::Signature; 1 }) { skip ('Must have Module::Signature to test SIGNATURE file', 1); } elsif ( !-e 'SIGNATURE' ) { fail ('SIGNATURE file was not found'); } elsif ( ! -s 'SIGNATURE') { fail ('SIGNATURE file was empty'); } else { my $ret = Module::Signature::verify(skip=>1); if ($ret eq Module::Signature::SIGNATURE_OK()) { pass ('Valid SIGNATURE file'); } else { fail ('Invalid SIGNATURE file'); } } } DBD-Pg-3.20.2/t/07copy.t0000644000175000017500000002506015166170753012754 0ustar greggreg#!perl ## Test the COPY functionality use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Data::Dumper; use DBD::Pg ':async'; use Test::More; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if ($dbh) { plan tests => 62; } else { plan skip_all => 'Connection to database failed, cannot continue testing'; } ok (defined $dbh, 'Connect to database for COPY testing'); my ($result,$expected,@data,$t); my $table = 'dbd_pg_test4'; $dbh->do(qq{CREATE TABLE $table(id2 integer, val2 text)}); $dbh->commit(); my $pgversion = $dbh->{pg_server_version}; # # Test of the pg_putline and pg_endcopy methods # ## pg_putline should fail unless we are in a COPY IN state $t='pg_putline fails when issued without a preceding COPY command'; eval { $dbh->pg_putline("12\tMulberry"); }; ok ($@, $t); $t='putline returned a value of 1 for success'; $dbh->do("COPY $table FROM STDIN"); $result = $dbh->pg_putline("12\tMulberry\n"); is ($result, 1, $t); $t='putline returned a value of 1 for success'; $result = $dbh->pg_putline("13\tStrawberry\n"); is ($result, 1, $t); $t='putline returned a value of 1 for success'; $result = $dbh->pg_putline("14\tBlueberry\n"); is ($result, 1, $t); ## Commands are not allowed while in a COPY IN state $t='do() fails while in a COPY IN state'; eval { $dbh->do(q{SELECT 'dbdpg_copytest'}); }; ok ($@, $t); ## pg_getline is not allowed as we are in a COPY_IN state $t='pg_getline fails while in a COPY IN state'; $data[0] = ''; eval { $dbh->pg_getline($data[0], 100); }; ok ($@, $t); $t='pg_endcopy returned a 1'; $result = $dbh->pg_endcopy(); is ($result, 1, $t); ## Make sure we can issue normal commands again $dbh->do(q{SELECT 'dbdpg_copytest'}); ## Make sure we are out of the COPY IN state and pg_putline no longer works $t='pg_putline fails when issued after pg_endcopy called'; eval { $dbh->pg_putline("16\tBlackberry"); }; ok ($@, $t); ## Check that our lines were inserted properly $t='putline inserted values correctly'; $expected = [[12 => 'Mulberry'],[13 => 'Strawberry'],[14 => 'Blueberry']]; $result = $dbh->selectall_arrayref("SELECT id2,val2 FROM $table ORDER BY id2"); is_deeply ($result, $expected, $t); # pg_endcopy should not work because we are no longer in a COPY state $t='pg_endcopy fails when called twice after COPY IN'; eval { $dbh->pg_endcopy; }; ok ($@, $t); $dbh->commit(); # # Test of the pg_getline method # ## pg_getline should fail unless we are in a COPY OUT state $t='pg_getline fails when issued without a preceding COPY command'; eval { $dbh->pg_getline($data[0], 100); }; ok ($@, $t); $t='pg_getline returns a 1'; $dbh->do("COPY $table TO STDOUT"); my $buffer = ''; $result = $dbh->pg_getline($data[0], 100); is ($result, 1, $t); ## Commands are not allowed while in a COPY OUT state $t='do() fails while in a COPY OUT state'; eval { $dbh->do(q{SELECT 'dbdpg_copytest'}); }; ok ($@, $t); ## pg_putline is not allowed as we are in a COPY OUT state $t='pg_putline fails while in a COPY OUT state'; eval { $dbh->pg_putline("99\tBogusberry"); }; ok ($@, $t); $t='pg_getline returned a 1'; $data[1]=$data[2]=$data[3]=''; $result = $dbh->pg_getline($data[1], 100); is ($result, 1, $t); $t='pg_getline returned a 1'; $result = $dbh->pg_getline($data[2], 100); is ($result, 1, $t); $t='pg_getline returns empty on final call'; $result = $dbh->pg_getline($data[3], 100); is ($result, '', $t); $t='getline returned all rows successfully'; $result = \@data; $expected = ["12\tMulberry\n","13\tStrawberry\n","14\tBlueberry\n",'']; is_deeply ($result, $expected, $t); ## Make sure we can issue normal commands again $dbh->do(q{SELECT 'dbdpg_copytest'}); ## Make sure we are out of the COPY OUT state and pg_getline no longer works $t='pg_getline fails when issued after pg_endcopy called'; eval { $data[5]=''; $dbh->pg_getline($data[5], 100); }; ok ($@, $t); ## pg_endcopy should fail because we are no longer in a COPY state $t='pg_endcopy fails when called twice after COPY OUT'; eval { $dbh->pg_endcopy; }; ok ($@, $t); ## ## Test the new COPY methods ## $dbh->do("DELETE FROM $table"); $t='pg_putcopydata fails if not after a COPY FROM statement'; eval { $dbh->pg_putcopydata("pizza\tpie"); }; like ($@, qr{COPY FROM command}, $t); $t='pg_getcopydata fails if not after a COPY TO statement'; eval { $dbh->pg_getcopydata($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='pg_getcopydata_async fails if not after a COPY TO statement'; eval { $dbh->pg_getcopydata_async($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='pg_putcopyend warns but does not die if not after a COPY statement'; eval { require Test::Warn; }; if ($@) { pass ('Skipping Test::Warn test'); } else { Test::Warn::warning_like (sub { $dbh->pg_putcopyend(); }, qr/until a COPY/, $t); } $t='pg_getcopydata does not work if we are using COPY .. TO'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); eval { $dbh->pg_getcopydata($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='pg_putcopydata does not work if we are using COPY .. FROM'; $dbh->rollback(); $dbh->do("COPY $table TO STDOUT"); eval { $dbh->pg_putcopydata("pizza\tpie"); }; like ($@, qr{COPY FROM command}, $t); $t='pg_putcopydata works and returns a 1 on success'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); $result = $dbh->pg_putcopydata("15\tBlueberry"); is ($result, 1, $t); $t='pg_putcopydata works on second call'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); $result = $dbh->pg_putcopydata("16\tMoreBlueberries"); is ($result, 1, $t); $t='pg_putcopydata fails with invalid data'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); eval { $dbh->pg_putcopydata(); }; ok ($@, $t); $t='Calling pg_getcopydata gives an error when in the middle of COPY .. TO'; eval { $dbh->pg_getcopydata($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='Calling do() gives an error when in the middle of COPY .. FROM'; eval { $dbh->do('SELECT 123'); }; like ($@, qr{call pg_putcopyend}, $t); $t='pg_putcopydata works after a rude non-COPY attempt'; eval { $result = $dbh->pg_putcopydata("17\tMoreBlueberries"); }; is ($@, q{}, $t); is ($result, 1, $t); $t='pg_putcopyend works and returns a 1'; eval { $result = $dbh->pg_putcopyend(); }; is ($@, q{}, $t); is ($result, 1, $t); $t='pg_putcopydata fails after pg_putcopyend is called'; $dbh->commit(); eval { $result = $dbh->pg_putcopydata('root'); }; like ($@, qr{COPY FROM command}, $t); $t='Normal queries work after pg_putcopyend is called'; eval { $dbh->do('SELECT 123'); }; is ($@, q{}, $t); $t='Data from pg_putcopydata was entered correctly'; $result = $dbh->selectall_arrayref("SELECT id2,val2 FROM $table ORDER BY id2"); $expected = [['12','Mulberry'],['13','Strawberry'],[14,'Blueberry'],[17,'MoreBlueberries']]; is_deeply ($result, $expected, $t); $t='pg_getcopydata fails when argument is not a variable'; $dbh->do("COPY $table TO STDOUT"); eval { $dbh->pg_getcopydata('wrongo'); }; like ($@, qr{read-only}, $t); $t='pg_getcopydata works and returns the length of the string'; $data[0] = 'old'; eval { $dbh->pg_getcopydata($data[0]); }; is ($@, q{}, $t); is ($data[0], "13\tStrawberry\n", $t); $t='pg_getcopydata works when argument is a reference'; eval { $dbh->pg_getcopydata(\$data[0]); }; is ($@, q{}, $t); is ($data[0], "14\tBlueberry\n", $t); $t='Calling do() gives an error when in the middle of COPY .. TO'; eval { $dbh->do('SELECT 234'); }; like ($@, qr{pg_getcopydata}, $t); $t='Calling pg_putcopydata gives an errors when in the middle of COPY .. FROM'; eval { $dbh->pg_putcopydata('pie'); }; like ($@, qr{COPY FROM command}, $t); $t='pg_getcopydata returns 0 when no more data'; $dbh->pg_getcopydata(\$data[0]); eval { $result = $dbh->pg_getcopydata(\$data[0]); }; is ($@, q{}, $t); is ($data[0], '', $t); is ($result, -1, $t); $t='Normal queries work after pg_getcopydata runs out'; eval { $dbh->do('SELECT 234'); }; is ($@, q{}, $t); $t='Async queries work after COPY OUT'; $dbh->do('CREATE TEMP TABLE foobar AS SELECT 123::INTEGER AS x'); $dbh->do('COPY foobar TO STDOUT'); 1 while ($dbh->pg_getcopydata($buffer) >= 0); eval { $dbh->do('SELECT 111', { pg_async => PG_ASYNC} ); }; is ($@, q{}, $t); $dbh->pg_result(); $t='Async queries work after COPY IN'; $dbh->do('COPY foobar FROM STDIN'); $dbh->pg_putcopydata(456); $dbh->pg_putcopyend(); eval { $dbh->do('SELECT 222', { pg_async => PG_ASYNC} ); }; is ($@, q{}, $t); $dbh->pg_result(); SKIP: { $pgversion < 80200 and skip ('Server version 8.2 or greater needed for test', 1); $t='pg_getcopydata works when pulling from an empty table into an empty var'; $dbh->do(q{COPY (SELECT 1 FROM pg_class LIMIT 0) TO STDOUT}); eval { my $newvar; $dbh->pg_getcopydata($newvar); }; is ($@, q{}, $t); } # # Make sure rollback and commit reset our internal copystate tracking # $t='commit resets COPY state'; $dbh->do("COPY $table TO STDOUT"); $dbh->commit(); eval { $dbh->do(q{SELECT 'dbdpg_copytest'}); }; ok (!$@, $t); $t='rollback resets COPY state'; $dbh->do("COPY $table TO STDOUT"); $dbh->rollback(); eval { $dbh->do(q{SELECT 'dbdpg_copytest'}); }; ok (!$@, $t); # # Keep old-style calls around for backwards compatibility # $t=q{old-style dbh->func('text', 'putline') still works}; $dbh->do("COPY $table FROM STDIN"); $result = $dbh->func("13\tOlive\n", 'putline'); is ($result, 1, $t); $t=q{old-style dbh->func(var, length, 'getline') still works}; $dbh->pg_endcopy; $dbh->do("COPY $table TO STDOUT"); $result = $dbh->func($data[0], 100, 'getline'); is ($result, 1, $t); 1 while ($result = $dbh->func($data[0], 100, 'getline')); # Test binary copy mode $dbh->do('CREATE TEMP TABLE binarycopy AS SELECT 1::INTEGER AS x'); $dbh->do('COPY binarycopy TO STDOUT BINARY'); my $copydata; my $length = $dbh->pg_getcopydata($copydata); while ($dbh->pg_getcopydata(my $tmp) >= 0) { $copydata .= $tmp; } ok (!utf8::is_utf8($copydata), 'pg_getcopydata clears UTF-8 flag on binary copy result'); $expected = "PGCOPY\n\377\r\n\0"; is (substr($copydata, 0, 11), $expected, 'pg_getcopydata preserves binary copy header signature'); cmp_ok ($length, '>=', 19, 'pg_getcopydata returns sane length of binary copy'); $dbh->do('COPY binarycopy FROM STDIN BINARY'); eval { $dbh->pg_putcopydata($copydata); $dbh->pg_putcopyend; }; is $@, '', 'pg_putcopydata in binary mode works' or diag $copydata; $t=q{COPY in binary mode round trips}; is_deeply ($dbh->selectall_arrayref('SELECT * FROM binarycopy'), [[1],[1]], $t); ## nospellcheck $dbh->do("DROP TABLE $table"); $dbh->commit(); cleanup_database($dbh,'test'); $dbh->disconnect; DBD-Pg-3.20.2/t/09arrays.t0000644000175000017500000003623215173231074013300 0ustar greggreg#!perl ## Test arrays use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Test::More; use Data::Dumper; use DBI ':sql_types'; use DBD::Pg ':pg_types'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 206; isnt ($dbh, undef, 'Connect to database for array testing'); my ($sth,$result,$t); my $pgversion = $dbh->{pg_server_version}; my $SQL = q{DELETE FROM dbd_pg_test WHERE pname = 'Array Testing'}; my $cleararray = $dbh->prepare($SQL); $SQL = q{INSERT INTO dbd_pg_test(id,pname,testarray) VALUES (99,'Array Testing',?)}; my $addarray = $dbh->prepare($SQL); $SQL = q{INSERT INTO dbd_pg_test(id,pname,testarray2) VALUES (99,'Array Testing',?)}; my $addarray_int = $dbh->prepare($SQL); $SQL = q{INSERT INTO dbd_pg_test(id,pname,testarray3) VALUES (99,'Array Testing',?)}; my $addarray_bool = $dbh->prepare($SQL); $SQL = q{SELECT testarray FROM dbd_pg_test WHERE pname= 'Array Testing'}; my $getarray = $dbh->prepare($SQL); $SQL = q{SELECT testarray2 FROM dbd_pg_test WHERE pname= 'Array Testing'}; my $getarray_int = $dbh->prepare($SQL); $SQL = q{SELECT testarray3 FROM dbd_pg_test WHERE pname= 'Array Testing'}; my $getarray_bool = $dbh->prepare($SQL); $t='Array quoting allows direct insertion into statements'; $SQL = q{INSERT INTO dbd_pg_test (id,testarray) VALUES }; my $quoteid = $dbh->quote(123); my $quotearr = $dbh->quote([q{Quote's Test}]); $SQL .= qq{($quoteid, $quotearr)}; eval { $dbh->do($SQL); }; is ($@, q{}, $t); $dbh->rollback(); ## Input (eval-able Perl) ## Expected (ERROR or raw PostgreSQL output) ## Name of test my $array_tests = q![''] {""} Empty array [['']] {{""}} Empty array with two levels [[['']]] {{{""}}} Empty array with three levels [[''],['']] {{""},{""}} Two empty arrays [[[''],[''],['']]] {{{""},{""},{""}}} Three empty arrays at second level [[],[[]]] ERROR: must be of equal size Unbalanced empty arrays {} ERROR: Cannot bind a reference Bare hashref [{}] ERROR: only scalars and other arrays Hashref at top level [1,2,{3,4},5] ERROR: only scalars and other arrays Hidden hashref [[1,2],[3]] ERROR: must be of equal size Unbalanced array [[1,2],[3,4,5]] ERROR: must be of equal size Unbalanced array [[1,2],[]] ERROR: must be of equal size Unbalanced array [[],[3]] ERROR: must be of equal size Unbalanced array [123] {123} Simple 1-D numeric array ['abc'] {abc} Simple 1-D text array ['a','b,c'] {a,"b,c"} Text array with commas and quotes ['a','b,}'] {a,"b,}"} Text array with commas, escaped closing brace ['a','b,]'] {a,"b,]"} Text array with commas, escaped closing bracket [1,2] {1,2} Simple 1-D numeric array [[1]] {{1}} Simple 2-D numeric array [[1,2]] {{1,2}} Simple 2-D numeric array [[[1]]] {{{1}}} Simple 3-D numeric array [[["alpha",2],[23,"pop"]]] {{{alpha,2},{23,pop}}} 3-D mixed array [[[1,2,3],[4,5,"6"],["seven","8","9"]]] {{{1,2,3},{4,5,6},{seven,8,9}}} 3-D mixed array [q{O'RLY?}] {O'RLY?} Simple single quote [q{O"RLY?}] {"O\"RLY?"} Simple double quote [[q{O"RLY?}],[q|'Ya' - "really"|],[123]] {{"O\"RLY?"},{"'Ya' - \"really\""},{123}} Many quotes ["Single\\\\Backslash"] {"Single\\\\Backslash"} Single backslash testing ["Double\\\\\\\\Backslash"] {"Double\\\\\\\\Backslash"} Double backslash testing [["Test\\\nRun","Quite \"so\""],["back\\\\\\\\slashes are a \"pa\\\\in\"",123] ] {{"Test\\\nRun","Quite \"so\""},{"back\\\\\\\\slashes are a \"pa\\\\in\"",123}} Escape party - backslash+newline, two + one [undef] {NULL} NEED 80200: Simple undef test [[undef]] {{NULL}} NEED 80200: Simple undef test [[1,2],[undef,3],["four",undef],[undef,undef]] {{1,2},{NULL,3},{four,NULL},{NULL,NULL}} NEED 80200: Multiple undef test !; ## Note: We silently allow things like this: [[[]],[]] sub safe_getarray { my $ret = eval { $getarray->execute(); $getarray->fetchall_arrayref()->[0][0]; }; return $@ || $ret; } for my $test (split /\n\n/ => $array_tests) { next unless $test =~ /\w/; my ($input,$expected,$msg) = split /\n/ => $test; my $perl_input = eval $input; if ($msg =~ s/NEED ([0-9]+):\s*//) { my $ver = $1; if ($pgversion < $ver) { my ($major, $minor, $patch) = $ver =~ /\A([0-9]{1,2})([0-9]{2})([0-9]{2})\z/; $_ += 0 for $major, $minor, $patch; SKIP: { my $count = $expected =~ /error:/ ? 2 : 5; skip ("$msg requires PostgreSQL $major.$minor.$patch or newer", $count); } next; } } # INSERT via bind values $dbh->rollback; eval { $addarray->execute($perl_input); }; if ($expected =~ /error:\s+(.+)/i) { like ($@, qr{$1}, "[bind] Array insert error : $msg : $input"); } else { is ($@, q{}, "[bind] Array insert success : $msg : $input"); $t="[bind][!expand] Correct array inserted: $msg : $input"; $dbh->{pg_expand_array} = 0; is (safe_getarray, $expected, $t); $t="[bind][expand] Correct array inserted: $msg : $input"; $dbh->{pg_expand_array} = 1; is_deeply (safe_getarray, $perl_input, $t); } # INSERT via `quote' and dynamic SQL $dbh->rollback; eval { $quotearr = $dbh->quote($perl_input); $SQL = qq{INSERT INTO dbd_pg_test(id,pname,testarray) VALUES (99,'Array Testing',$quotearr)}; $dbh->do($SQL); }; if ($expected =~ /error:\s+(.+)/i) { my $errmsg = $1; $errmsg =~ s/bind/quote/; like ($@, qr{$errmsg}, "[quote] Array insert error : $msg : $input"); } else { is ($@, q{}, "[quote] Array insert success : $msg : $input"); # No need to recheck !expand case. $t="[quote][expand] Correct array inserted: $msg : $input"; is_deeply (safe_getarray, $perl_input, $t); } if ($msg =~ /STOP/) { warn "Exiting for DEBUGGING. Result is:\n"; warn Dumper $result; cleanup_database($dbh,'test'); $dbh->disconnect; exit; } } ## Test of no-item and empty string arrays $t=q{String array with no items returns empty array}; $cleararray->execute(); $addarray->execute('{}'); $getarray->execute(); $result = $getarray->fetchall_arrayref(); is_deeply ($result, [[[]]], $t); $t=q{String array with empty string returns empty string}; $cleararray->execute(); $addarray->execute('{""}'); $getarray->execute(); $result = $getarray->fetchall_arrayref(); is_deeply ($result, [[['']]], $t); ## Test non-string array variants $t=q{Integer array with no items returns empty array}; $cleararray->execute(); $addarray_int->execute('{}'); $getarray_int->execute(); $result = $getarray_int->fetchall_arrayref(); is_deeply ($result, [[[]]], $t); $t=q{Boolean array with no items returns empty array}; $cleararray->execute(); $addarray_bool->execute('{}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[]]], $t); $t=q{Boolean array gets created and returned correctly}; $cleararray->execute(); $addarray_bool->execute('{1}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[1]]], $t); $cleararray->execute(); $addarray_bool->execute('{0}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[0]]], $t); $cleararray->execute(); $addarray_bool->execute('{t}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[1]]], $t); $cleararray->execute(); $addarray_bool->execute('{f}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[0]]], $t); $cleararray->execute(); $addarray_bool->execute('{f,t,f,0,1,1}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[0,1,0,0,1,1]]], $t); ## Test of read-only undef sections SKIP: { skip 'Cannot test NULL arrays unless version 8.2 or better', 1 if $pgversion < 80200; $t = 'Modification of undefined parts of array are allowed'; $cleararray->execute(); $addarray_bool->execute('{f,t,null,0,NULL,NuLl}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref()->[0][0]; $result->[2] = 22; is_deeply ($result, [0,1,22,0,undef,undef], $t); } ## Pure string to array conversion testing my $array_tests_out = q!1 [1] Simple test of single array element 1,2 [1,2] Simple test of multiple array elements 1,2,3 [1,2,3] Simple test of multiple array elements 'a','b' ['a','b'] Array with text items 0.1,2.4 [0.1,2.4] Array with numeric items 'My"lrd','b','c' ['My"lrd','b','c'] Array with escaped items [1] [[1]] Multi-level integer array [[1,2]] [[[1,2]]] Multi-level integer array [[1],[2]] [[[1],[2]]] Multi-level integer array [[1],[2],[3]] [[[1],[2],[3]]] Multi-level integer array [[[1]],[[2]],[[3]]] [[[[1]],[[2]],[[3]]]] Multi-level integer array 'abc',NULL ['abc',undef] NEED 80200: Array with a null ['abc','NULL',NULL,NULL,123::text] [['abc','NULL',undef,undef,'123']] NEED 80200: Array with many nulls and a quoted int ['abc',''] [['abc','']] Final item is empty 1,NULL [1,undef] NEED 80200: Last item is NULL NULL [undef] NEED 80200: Only item is NULL NULL,NULL [undef,undef] NEED 80200: Two NULL items only NULL,NULL,NULL [undef,undef,undef] NEED 80200: Three NULL items only [123,NULL,456] [[123,undef,456]] NEED 80200: Middle item is NULL NULL,'abc' [undef,'abc'] NEED 80200: First item is NULL 'a','NULL' ['a',"NULL"] NEED 80200: Fake NULL is text [[[[[1,2,3]]]]] [[[[[[1,2,3]]]]]] Deep nesting [[[[[1],[2],[3]]]]] [[[[[[1],[2],[3]]]]]] Deep nesting [[[[[1]]],[[[2]]],[[[3]]]]] [[[[[[1]]],[[[2]]],[[[3]]]]]] Deep nesting [[[[[1]],[[2]],[[3]]]]] [[[[[[1]],[[2]],[[3]]]]]] Deep nesting 1::bool [1] NEED 80200: Test of boolean type 1::bool,0::bool,'true'::boolean [1,0,1] NEED 80200: Test of boolean types 1::oid [1] Test of oid type - should not quote 1::text ['1'] Text number should quote 1,2,3 [1,2,3] Unspecified int should not quote 1::int [1] Integer number should quote '(1,2),(4,5)'::box,'(5,3),(4,5)' ['(4,5),(1,2)','(5,5),(4,3)'] Type 'box' works !; $Data::Dumper::Indent = 0; for my $test (split /\n\n/ => $array_tests_out) { next unless $test =~ /\w/; my ($input,$expected,$msg) = split /\n/ => $test; my $qexpected = $expected; if ($expected =~ s/\s*quote:\s*(.+)//) { $qexpected = $1; } if ($msg =~ s/NEED ([0-9]+):\s*//) { my $ver = $1; if ($pgversion < $ver) { my ($major, $minor, $patch) = $ver =~ /\A([0-9]{1,2})([0-9]{2})([0-9]{2})\z/; $_ += 0 for $major, $minor, $patch; SKIP: { skip ("$msg requires PostgreSQL $major.$minor.$patch or newer", 1); } next; } } $t="Array test $msg : $input"; $SQL = qq{SELECT ARRAY[$input]}; $result = ''; eval { $result = $dbh->selectall_arrayref($SQL)->[0][0]; }; if ($result =~ /error:\s+(.+)/i) { like ($@, qr{$1}, "Array failed : $msg : $input"); } else { $expected = eval $expected; ## is_deeply does not handle type differences is ( (Dumper $result), (Dumper $expected), $t); } } ## Check utf-8 in and out of the database SKIP: { eval { require Encode; }; skip ('Encode module is needed for unicode tests', 14) if $@; my $server_encoding = $dbh->selectall_arrayref('SHOW server_encoding')->[0][0]; skip ('Cannot reliably test unicode without a UTF8 database', 14) if $server_encoding ne 'UTF8'; $t='String should be UTF-8'; local $dbh->{pg_enable_utf8} = 1; my $utf8_str = chr(0x100).'dam'; # LATIN CAPITAL LETTER A WITH MACRON ok (Encode::is_utf8( $utf8_str ), $t); $t='quote() handles utf8'; my $quoted = $dbh->quote($utf8_str); is ($quoted, qq{'$utf8_str'}, $t); $t='Quoted string should be UTF-8'; ok (Encode::is_utf8( $quoted ), $t); $t='quote() handles utf8 inside array'; $quoted = $dbh->quote([$utf8_str, $utf8_str]); is ($quoted, qq!'{"$utf8_str","$utf8_str"}'!, $t); $t='Quoted array of strings should be UTF-8'; ok (Encode::is_utf8( $quoted ), $t); $t='Inserting utf-8 into an array via quoted do() works'; $dbh->do('DELETE FROM dbd_pg_test'); $SQL = qq{INSERT INTO dbd_pg_test (id, testarray, val) VALUES (1, $quoted, 'one')}; eval { $dbh->do($SQL); }; is ($@, q{}, $t); $t='Retrieving an array containing utf-8 works'; $SQL = q{SELECT id, testarray, val FROM dbd_pg_test WHERE id = 1}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->fetchall_arrayref()->[0]; my $expected = [1,[$utf8_str,$utf8_str],'one']; is_deeply ($result, $expected, $t); $t='Selected string should be UTF-8'; ok (Encode::is_utf8( $result->[1][0] ), $t); $t='Selected string should be UTF-8'; ok (Encode::is_utf8( $result->[1][1] ), $t); $t='Inserting utf-8 into an array via prepare and arrayref works'; $dbh->do('DELETE FROM dbd_pg_test'); $SQL = q{INSERT INTO dbd_pg_test (id, testarray, val) VALUES (?, ?, 'one')}; $sth = $dbh->prepare($SQL); eval { $sth->execute(1,['Bob',$utf8_str]); }; is ($@, q{}, $t); local $dbh->{pg_enable_utf8} = 1; $t='Retrieving an array containing utf-8 works'; $SQL = q{SELECT id, testarray, val FROM dbd_pg_test WHERE id = 1}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->fetchall_arrayref()->[0]; $expected = [1,['Bob',$utf8_str],'one']; is_deeply ($result, $expected, $t); $t='Selected ASCII string should be UTF-8'; ok (Encode::is_utf8( $result->[1][0] ), $t); $t='Selected string should be UTF-8'; ok (Encode::is_utf8( $result->[1][1] ), $t); $t='Non utf-8 inside an array is not return as utf-8'; $dbh->do('DELETE FROM dbd_pg_test'); $SQL = q{INSERT INTO dbd_pg_test (id, testarray, val) VALUES (1, '{"noutfhere"}', 'one')}; $dbh->do($SQL); $SQL = q{SELECT testarray FROM dbd_pg_test WHERE id = 1}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->fetchall_arrayref()->[0][0]; ok (!Encode::is_utf8($result), $t); $sth->finish(); } ## Quick test of empty arrays my $expected = $pgversion >= 80300 ? [[[]]] : [[undef]]; $t=q{Empty int array is returned properly}; $result = $dbh->selectall_arrayref(q{SELECT array(SELECT 12345::int WHERE 1=0)::int[]}); is_deeply ($result, $expected, $t); $t=q{Empty text array is returned properly}; $result = $dbh->selectall_arrayref(q{SELECT array(SELECT 'empty'::text WHERE 1=0)::text[]}); is_deeply ($result, $expected, $t); $t=q{String lengths of returned arrays are correct}; my @numbers = ('one', 'two', 'three'); $result = $dbh->selectall_arrayref(q{SELECT array['one','two','three']}); for my $col (@{$result->[0][0]}) { is (length($col), length(shift @numbers), $t); } SKIP: { my $fancytime; eval { require Time::Piece; $fancytime = Time::Piece->localtime;}; if ($@) { skip ('Need Time::Piece for some tests', 2); } isa_ok($fancytime, 'Time::Piece'); $t=q{Objects send to be bound are unwrapped properly (e.g. Time::Piece)}; $dbh->do('SELECT ?::timestamptz', undef, $fancytime); pass ($t); } cleanup_database($dbh,'test'); $dbh->disconnect; DBD-Pg-3.20.2/t/08async.t0000644000175000017500000005005015173036242013105 0ustar greggreg#!perl ## Test asynchronous queries use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Test::More; use Time::HiRes qw/sleep/; use DBD::Pg ':async'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database({AutoCommit => 1}); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } ## Second handle with errors suppressed for expected-failure tests my $dbh_noerr = connect_database({AutoCommit => 1}); if (! $dbh_noerr) { plan skip_all => 'Second connection to database failed, cannot continue testing'; } $dbh_noerr->{RaiseError} = 0; $dbh_noerr->{PrintError} = 0; plan tests => 128; isnt ($dbh, undef, 'Connect to database for async testing'); my ($t,$sth,$res); my $pgversion = $dbh->{pg_server_version}; ## First, test out do() in all its variants $t=q{Method do() works as expected with no args }; eval { $res = $dbh->do('SELECT 123'); }; is ($@, q{}, $t); is ($res, 1, $t); $t=q{Method do() works as expected with an unused attribute }; eval { $res = $dbh->do('SELECT 123', {pg_nosuch => 'arg'}); }; is ($@, q{}, $t); is ($res, 1, $t); $t=q{Method do() works as expected with an unused attribute and a non-prepared param }; eval { $res = $dbh->do('SET random_page_cost TO ?', undef, '2.2'); }; is ($@, q{}, $t); is ($res, '0E0', $t); $t=q{Method do() works as expected with an unused attribute and multiple real bind params }; eval { $res = $dbh->do('SELECT count(*) FROM pg_class WHERE reltuples IN (?,?,?)', undef, 1,2,3); }; is ($@, q{}, $t); is ($res, 1, $t); $t=q{Canceling a non-async do() query gives an error }; eval { $res = $dbh->pg_cancel(); }; like ($@, qr{No asynchronous query is running}, $t); $t=q{Method do() works as expected with an asynchronous flag }; eval { $res = $dbh->do('SELECT 123', {pg_async => PG_ASYNC}); }; is ($@, q{}, $t); is ($res, '0E0', $t); $t=q{Database attribute "async_status" returns 1 after async query}; $res = $dbh->{pg_async_status}; is ($res, +1, $t); sleep 1; $t=q{Canceling an async do() query works }; eval { $res = $dbh->pg_cancel(); }; is ($@, q{}, $t); $t=q{Database method pg_cancel returns a false value when cancellation works but finished}; is ($res, q{}, $t); $t=q{Database attribute "async_status" returns 0 after pg_cancel}; $res = $dbh->{pg_async_status}; is ($res, 0, $t); $t=q{Running do() after a canceled query works}; eval { $res = $dbh->do('SELECT 123'); }; is ($@, q{}, $t); $t=q{Database attribute "async_status" returns 0 after normal query run}; $res = $dbh->{pg_async_status}; is ($res, 0, $t); $t=q{Method pg_ready() fails after a non-async query}; eval { $dbh->pg_ready(); }; like ($@, qr{No async}, $t); $res = $dbh->do('SELECT 123', {pg_async => PG_ASYNC}); $t=q{Method pg_ready() works after async query}; ## Sleep a sub-second to make sure the server has caught up sleep 0.2; eval { $res = $dbh->pg_ready(); }; is ($@, q{}, $t); $t=q{Database method pg_ready() returns 1 after a completed async do()}; is ($res, 1, $t); $res = $dbh->pg_ready(); $t=q{Database method pg_ready() returns true when called a second time}; is ($res, 1, $t); $t=q{Canceling an async do() query works }; eval { $res = $dbh->pg_cancel(); }; is ($@, q{}, $t); $t=q{Database method pg_cancel() returns expected false value for completed value}; is ($res, q{}, $t); $t=q{Method do() runs after pg_cancel has cleared the async query}; eval { $dbh->do('SELECT 456'); }; is ($@, q{}, $t); $dbh->do(q{SELECT 'async2'}, {pg_async => PG_ASYNC}); $t=q{Method do() fails when async query has not been cleared}; eval { $dbh->do(q{SELECT 'async_blocks'}); }; like ($@, qr{previous async}, $t); $t=q{Database method pg_result works as expected}; eval { $res = $dbh->pg_result(); }; is ($@, q{}, $t); $t=q{Database method pg_result() returns correct value}; is ($res, 1, $t); $t=q{Database method pg_result() fails when called twice}; eval { $dbh->pg_result(); }; like ($@, qr{No async}, $t); $t=q{Database method pg_cancel() fails when called after pg_result()}; eval { $dbh->pg_cancel(); }; like ($@, qr{No async}, $t); $t=q{Database method pg_ready() fails when called after pg_result()}; eval { $dbh->pg_ready(); }; like ($@, qr{No async}, $t); $t=q{Database method do() works after pg_result()}; eval { $dbh->do('SELECT 123'); }; is ($@, q{}, $t); SKIP: { if ($pgversion < 80200) { skip ('Need pg_sleep() to perform rest of async tests: your Postgres is too old', 14); } eval { $dbh->do('SELECT pg_sleep(0)'); }; is ($@, q{}, 'Calling pg_sleep works as expected'); my $time = time(); eval { $res = $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); }; $time = time()-$time; $t = q{Database method do() returns right away when in async mode}; cmp_ok ($time, '<=', 1, $t); $t=q{Method pg_ready() returns false when query is still running}; $res = $dbh->pg_ready(); is ($res, 0, $t); pass ('Sleeping to allow query to finish'); sleep(3); $t=q{Method pg_ready() returns true when query is finished}; $res = $dbh->pg_ready(); ok ($res, $t); $t=q{Method do() will not work if async query not yet cleared}; eval { $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); }; like ($@, qr{previous async}, $t); $t=q{Database method pg_cancel() works while async query is running}; eval { $res = $dbh->pg_cancel(); }; is ($@, q{}, $t); $t=q{Database method pg_cancel returns false when query has already finished}; ok (!$res, $t); $t=q{Database method pg_result() fails after async query has been canceled}; eval { $res = $dbh->pg_result(); }; like ($@, qr{No async}, $t); $t=q{Database method do() cancels the previous async when requested}; eval { $res = $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC + PG_OLDQUERY_CANCEL}); }; is ($@, q{}, $t); $t=q{Database method pg_result works when async query is still running}; eval { $res = $dbh->pg_result(); }; is ($@, q{}, $t); ## Now throw in some execute after the do() $sth = $dbh->prepare('SELECT 567'); $t = q{Running execute after async do() gives an error}; $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); eval { $res = $sth->execute(); }; like ($@, qr{previous async}, $t); $t = q{Running execute after async do() works when told to cancel}; $sth = $dbh->prepare('SELECT 678', {pg_async => PG_OLDQUERY_CANCEL}); eval { $sth->execute(); }; is ($@, q{}, $t); $t = q{Running execute after async do() works when told to wait}; $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); $sth = $dbh->prepare('SELECT 678', {pg_async => PG_OLDQUERY_WAIT}); eval { $sth->execute(); }; is ($@, q{}, $t); $sth->finish(); $t = q{Can get result of an async query which already finished after pg_send_cancel}; $dbh->do('select 123', { pg_async => PG_ASYNC}); sleep(1); $dbh->pg_send_cancel(); $res = $dbh->pg_result(); is($res, 1, $t); $dbh->do('select pg_sleep(10)', { pg_async => PG_ASYNC }); $dbh->pg_send_cancel(); $res = $dbh->pg_result(); is (0+$res, 0, 'pg_result returns zero after canceled query'); is ($dbh->state(), '57014', 'state is 57014 after canceled query'); } ## end of pg_sleep skip $t=q{Method execute() works when prepare has PG_ASYNC flag}; $sth = $dbh->prepare('SELECT 123', {pg_async => PG_ASYNC}); eval { $sth->execute(); }; is ($@, q{}, $t); $t=q{Database attribute "async_status" returns 1 after prepare async}; $res = $dbh->{pg_async_status}; is ($res, 1, $t); $t=q{Method do() fails when previous async prepare has been executed}; eval { $dbh->do('SELECT 123'); }; like ($@, qr{previous async}, $t); $t=q{Method execute() fails when previous async prepare has been executed}; eval { $sth->execute(); }; like ($@, qr{previous async}, $t); $t=q{Database method pg_cancel works if async query has already finished}; sleep 0.5; eval { $res = $sth->pg_cancel(); }; is ($@, q{}, $t); $t=q{Statement method pg_cancel() returns a false value when cancellation works but finished}; is ($res, q{}, $t); $t=q{Method do() fails when previous execute async has not been cleared}; $sth->execute(); $sth->finish(); ## Ideally, this would clear out the async, but it cannot at the moment eval { $dbh->do('SELECT 345'); }; like ($@, qr{previous async}, $t); $dbh->pg_cancel; $t=q{Directly after pg_cancel(), pg_async_status is 0}; is ($dbh->{pg_async_status}, 0, $t); $t=q{Method execute() works when prepare has PG_ASYNC flag}; $sth->execute(); $t=q{After async execute, pg_async_status is 1}; is ($dbh->{pg_async_status}, 1, $t); $t=q{Method pg_result works after a prepare/execute call}; eval { $res = $dbh->pg_result; }; is ($@, q{}, $t); $t=q{Method pg_result() returns expected result after prepare/execute select}; is ($res, 1, $t); $t=q{Method fetchall_arrayref works after pg_result}; eval { $res = $sth->fetchall_arrayref(); }; is ($@, q{}, $t); $t=q{Method fetchall_arrayref returns correct result after pg_result}; is_deeply ($res, [[123]], $t); $dbh->do('CREATE TABLE dbd_pg_test5(id INT, t TEXT)'); $sth->execute(); $t=q{Method prepare() works when passed in PG_OLDQUERY_CANCEL}; my $sth2; my $SQL = 'INSERT INTO dbd_pg_test5(id) SELECT 123 UNION SELECT 456'; eval { $sth2 = $dbh->prepare($SQL, {pg_async => PG_ASYNC + PG_OLDQUERY_CANCEL}); }; is ($@, q{}, $t); $t=q{Fetch on canceled statement handle fails}; eval { $sth->fetch(); }; like ($@, qr{no statement executing}, $t); $t=q{Method execute works after async + cancel prepare}; eval { $sth2->execute(); }; is ($@, q{}, $t); $t=q{Statement method pg_result works on async statement handle}; eval { $res = $sth2->pg_result(); }; is ($@, q{}, $t); $t=q{Statement method pg_result returns correct result after execute}; is ($res, 2, $t); $sth2->execute(); $t=q{Database method pg_result works on async statement handle}; eval { $res = $sth2->pg_result(); }; is ($@, q{}, $t); $t=q{Database method pg_result returns correct result after execute}; is ($res, 2, $t); { my ($sth0, $sth1, $old_switch); # # Test that handle_old_async deals correctly with async prepares. # See https://github.com/bucardo/dbdpg/pull/142#issuecomment-4260460925 # $t=q{Pending async prepare handled correctly by handle_old_async}; # Start an async prepare. $sth0 = $dbh->prepare('select * from dbd_pg_test5 where id = ?', { pg_async => PG_ASYNC, pg_prepare_now => 1 }); # Tell execute that it should prepare on first execution. $old_switch = $$dbh{switch_prepared}; $dbh->{pg_switch_prepared} = 1; # Create async statement w/o prepare. $sth1 = $dbh->prepare('select * from dbd_pg_test5 where t = ?', { pg_async => PG_ASYNC | PG_OLDQUERY_WAIT}); # Execute. This will call handle_old_async to wait for the result # of the previous async prepare & query and then start a second # async prepare. $sth1->execute(2); eval { # Wait for result. # Without the fix, this will abort with # # prepared statement "dbdpg_p3993_X" already exists # # as first and second prepare will have used the same # prepare_number because handle_old_async didn't increment # it. $dbh->pg_result(); }; is ($@, q{}, $t); $dbh->{pg_switch_prepared} = $old_switch; } $dbh->do('DROP TABLE dbd_pg_test5'); ## TODO: More pg_sleep tests with execute ## ==================================================================== ## Regression tests for async query ownership and data preservation ## (GitHub issue #105) ## ==================================================================== my ($sth1, $sth3, $rows, $id, $val, @sths); ## pg_result() on the wrong statement handle returns an error and does not steal results $sth1 = $dbh->prepare(q{SELECT 991 AS id}, { pg_async => PG_ASYNC }); $sth2 = $dbh->prepare(q{SELECT 992 AS id}, { pg_async => PG_ASYNC }); $t=q{Async execute on sth1 succeeds}; ok ($sth1->execute, $t); $t=q{pg_result() on wrong statement handle mentions wrong statement}; eval { $rows = $sth2->pg_result; }; like ($@, qr/wrong statement/i, $t); $t=q{pg_result() on correct statement handle returns expected row count}; $rows = $sth1->pg_result; is ($rows, 1, $t); $t=q{fetchrow_array on correct statement handle returns expected data}; ($id) = $sth1->fetchrow_array; is ($id, 991, $t); $sth1->finish; $sth2->finish; ## $dbh->pg_result() retrieves results and finished statement cannot steal new async results $sth1 = $dbh->prepare(q{SELECT 993 AS num}, { pg_async => PG_ASYNC }); $t=q{Async execute on sth1 for dbh->pg_result test}; ok ($sth1->execute, $t); $t=q{$dbh->pg_result() returns expected row count}; $rows = $dbh->pg_result; is ($rows, 1, $t); $t=q{Data is accessible via statement handle after $dbh->pg_result()}; ($val) = $sth1->fetchrow_array; is ($val, 993, $t); $t=q{$dbh->pg_result() with no pending async query mentions no async}; eval { $dbh->pg_result; }; like ($@, qr/no async/i, $t); $sth1->finish; $sth2 = $dbh->prepare(q{SELECT 994}, { pg_async => PG_ASYNC }); $t=q{Async execute on sth2 after sth1 finished}; ok ($sth2->execute, $t); $t=q{Finished statement handle cannot retrieve results from new async query}; eval { $sth1->pg_result; }; like ($@, qr/no async|wrong statement/i, $t); $sth2->pg_result; $sth2->finish; ## Destroying an unrelated statement handle does not cancel an active async query $sth1 = $dbh->prepare(q{SELECT 991 AS id}, { pg_async => PG_ASYNC }); $t=q{Async execute on sth1 before destroying unrelated statement}; ok ($sth1->execute, $t); ## Scope block: create and destroy an unrelated statement handle { $sth2 = $dbh->prepare(q{SELECT 992 AS id}, { pg_async => PG_ASYNC }); $t=q{Unrelated statement handle created}; ok ($sth2, $t); } $t=q{Unrelated statement handle destroyed via scope exit}; pass ($t); $t=q{pg_result() returns expected row count after unrelated destroy}; $rows = $sth1->pg_result; is ($rows, 1, $t); $t=q{fetchrow_array returns expected data after unrelated destroy}; ($id) = $sth1->fetchrow_array; is ($id, 991, $t); $t=q{Statement finish succeeds after unrelated destroy}; ok ($sth1->finish, $t); ## Only the statement that initiated the async query can retrieve its result for my $i (1..3) { my $qval = 990 + $i; $sths[$i] = $dbh->prepare(qq{SELECT $qval AS id}, { pg_async => PG_ASYNC }); $t=qq{Statement $i prepared for cross-statement test}; ok ($sths[$i], $t); } $t=q{Async execute on middle statement only}; ok ($sths[2]->execute, $t); $t=q{Non-executing statement gets appropriate error}; eval { $sths[1]->pg_result; }; like ($@, qr/no async|wrong statement/i, $t); $t=q{Other non-executing statement gets appropriate error}; eval { $sths[3]->pg_result; }; like ($@, qr/no async|wrong statement/i, $t); $t=q{Executing statement retrieves its own async result}; ok ($sths[2]->pg_result, $t); $t=q{Executing statement gets correct data}; ($id) = $sths[2]->fetchrow_array; is ($id, 992, $t); $_->finish for grep { defined } @sths; ## PG_OLDQUERY_WAIT auto-retrieves results for the owning statement $sth1 = $dbh->prepare(q{SELECT 991 AS id, pg_sleep(0.001)}, { pg_async => PG_ASYNC }); $t=q{Async execute on sth1 for OLDQUERY_WAIT auto-retrieve test}; ok ($sth1->execute, $t); $sth2 = $dbh->prepare(q{SELECT 992 AS id}, { pg_async => PG_ASYNC + PG_OLDQUERY_WAIT }); $t=q{Async execute with OLDQUERY_WAIT on sth2 waits for sth1}; ok ($sth2->execute, $t); $sth3 = $dbh->prepare(q{SELECT 993 AS id}, { pg_async => PG_ASYNC + PG_OLDQUERY_WAIT }); $t=q{Async execute with OLDQUERY_WAIT on sth3 waits for sth2}; ok ($sth3->execute, $t); $t=q{pg_result() on sth3 succeeds}; ok ($sth3->pg_result, $t); $t=q{pg_result() on sth1 retrieves auto-stored results}; ok ($sth1->pg_result, $t); $t=q{pg_result() on sth2 retrieves auto-stored results}; ok ($sth2->pg_result, $t); $t=q{sth1 has correct auto-retrieved data}; ($val) = $sth1->fetchrow_array; is ($val, 991, $t); $t=q{sth2 has correct data}; ($val) = $sth2->fetchrow_array; is ($val, 992, $t); $t=q{sth3 has correct data}; ($val) = $sth3->fetchrow_array; is ($val, 993, $t); $sth1->finish; $sth2->finish; $sth3->finish; ## Errors from PG_OLDQUERY_WAIT are attributed to the correct statement ## Use the no-error handle since pg_result on error results raises $sth1 = $dbh_noerr->prepare(q{SELECT * FROM dbd_pg_missing1}, { pg_async => PG_ASYNC }); $t=q{Async execute on query referencing dbd_pg_missing1}; ok ($sth1->execute, $t); $sth2 = $dbh_noerr->prepare(q{SELECT * FROM dbd_pg_missing2}, { pg_async => PG_ASYNC + PG_OLDQUERY_WAIT }); $t=q{Async execute with OLDQUERY_WAIT on query referencing dbd_pg_missing2}; ok ($sth2->execute, $t); my $good = $dbh_noerr->prepare(q{SELECT 994}, { pg_async => PG_ASYNC + PG_OLDQUERY_WAIT }); $t=q{Async execute with OLDQUERY_WAIT on valid query}; ok ($good->execute, $t); $t=q{pg_result() on query with dbd_pg_missing1 fails}; ok (!$sth1->pg_result, $t); $t=q{Error for dbd_pg_missing1 query mentions the correct table name}; like ($sth1->errstr || '', qr/dbd_pg_missing1/, $t); $t=q{pg_result() on query with dbd_pg_missing2 fails}; ok (!$sth2->pg_result, $t); $t=q{Error for dbd_pg_missing2 query mentions the correct table name}; like ($sth2->errstr || '', qr/dbd_pg_missing2/, $t); $t=q{pg_result() on valid query after error queries succeeds}; ok ($good->pg_result, $t); $sth1->finish; $sth2->finish; $good->finish; ## PG_OLDQUERY_WAIT preserves data from the previous async query via auto-retrieve $sth1 = $dbh->prepare(q{SELECT 991 AS id}, { pg_async => PG_ASYNC }); $t=q{Async execute on sth1 for data preservation test}; ok ($sth1->execute, $t); $sth2 = $dbh->prepare(q{SELECT 992 AS id}, { pg_async => PG_ASYNC + PG_OLDQUERY_WAIT }); $t=q{Async execute with OLDQUERY_WAIT triggers auto-retrieve of sth1 results}; ok ($sth2->execute, $t); $t=q{Auto-retrieved data from sth1 is preserved and correct}; ($val) = $sth1->fetchrow_array; is ($val, 991, $t); $t=q{pg_result() on sth2 after OLDQUERY_WAIT succeeds}; ok ($sth2->pg_result, $t); $t=q{sth2 data is correct after OLDQUERY_WAIT}; ($val) = $sth2->fetchrow_array; is ($val, 992, $t); $t=q{sth2 finish succeeds}; ok ($sth2->finish, $t); $sth1->finish; # Test async COPY TO STDOUT: non-blocking do(), polling, result, and data drain $t = q{do() with PG_ASYNC on COPY TO STDOUT returns '0E0' immediately (non-blocking)}; eval { $res = $dbh->do( q{COPY (SELECT * FROM unnest(ARRAY[1,2,3,4,5,6,7,8,9,10]::int[]) as dbd_pg_asynccopytest(a)) TO STDOUT}, { pg_async => PG_ASYNC } ); }; is ($@, q{}, $t); is ($res, '0E0', "$t - result is '0E0' (expected for async COPY TO STDOUT)"); $t = q{Database is in async mode after async COPY do()}; is ($dbh->{pg_async_status}, 1, $t); $t = q{pg_ready() becomes true within reasonable time for small async COPY TO STDOUT}; my $ready = 0; for my $i (1..12) { # up to ~12 seconds max wait if ($dbh->pg_ready) { $ready = 1; last; } sleep 1; } ok ($ready, $t); $t = q{pg_result() succeeds after async COPY TO STDOUT completes without error}; eval { $res = $dbh->pg_result(); }; is ($@, q{}, $t); $t = q{pg_result() after async COPY TO STDOUT returns -1 (rows unknown during COPY)}; is ($res, -1, $t); $t = q{We can drain the async COPY TO STDOUT data stream via pg_getcopydata loop}; my @copied_rows; while (1) { my $buf = ''; my $status = $dbh->pg_getcopydata($buf); last if !(defined $status && $status >= 0); chomp $buf; push @copied_rows, $buf; } is (scalar @copied_rows, 10, "$t - received correct number of rows from async COPY TO STDOUT"); is_deeply (\@copied_rows, [qw(1 2 3 4 5 6 7 8 9 10)], "$t - correct row values from async COPY TO STDOUT"); $t = q{Async status cleared after full COPY drain + pg_result}; is ($dbh->{pg_async_status}, 0, $t); # Cleanup / sanity checks eval { $dbh->pg_ready(); }; like ($@, qr{No async|async query}, 'pg_ready fails after COPY TO STDOUT completed and cleared'); eval { $dbh->do('SELECT 1'); }; is ($@, q{}, 'Normal synchronous query works after async COPY TO STDOUT finished'); cleanup_database($dbh,'test'); $dbh_noerr->disconnect; $dbh->disconnect; DBD-Pg-3.20.2/t/12placeholders.t0000644000175000017500000006365015174664550014454 0ustar greggreg#!perl ## Test of placeholders use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Test::More; use DBI qw/:sql_types/; use DBD::Pg qw/:pg_types/; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 266; my $t='Connect to database for placeholder testing'; isnt ($dbh, undef, $t); my $pgversion = $dbh->{pg_server_version}; if ($pgversion >= 80100 and $pgversion < 19000) { $dbh->do('SET escape_string_warning = false'); } my ($result, $SQL, $qresult); # Make sure that quoting works properly. $t='Quoting works properly'; my $E = $pgversion >= 80100 ? q{E} : q{}; my $quo = $dbh->quote('\\\'?:'); is ($quo, qq{${E}'\\\\''?:'}, $t); $t='Quoting works with a function call'; # Make sure that quoting works with a function call. # It has to be in this function, otherwise it doesn't fail the # way described in https://rt.cpan.org/Ticket/Display.html?id=4996. sub checkquote { my $string = shift; return is ($dbh->quote(substr($string, 0, 10)), "'$string'", $t); } checkquote('one'); checkquote('two'); checkquote('three'); checkquote('four'); ## Github issue #33 my $sth; if ($dbh->{pg_server_version} >= 90400) { $SQL = q{ SELECT '{"a":1}'::jsonb \? 'abc' AND 123=$1}; for (1..300) { $sth = $dbh->prepare($SQL); $sth->execute(123); } } $t='Fetch returns the correct quoted value'; $sth = $dbh->prepare(qq{INSERT INTO dbd_pg_test (id,pname) VALUES (?, $quo)}); $sth->execute(100); my $sql = "SELECT pname FROM dbd_pg_test WHERE pname = $quo"; $sth = $dbh->prepare($sql); $sth->execute(); my ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with one bind param where none expected fails'; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with ? placeholder works'; $sql = 'SELECT pname FROM dbd_pg_test WHERE pname = ?'; $sth = $dbh->prepare($sql); $sth->execute('\\\'?:'); ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with :1 placeholder works'; $sql = 'SELECT pname FROM dbd_pg_test WHERE pname = :1'; $sth = $dbh->prepare($sql); $sth->bind_param(':1', '\\\'?:'); $sth->execute(); ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with $1 placeholder works'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = $1 AND pname <> 'foo'}; $sth = $dbh->prepare($sql); $sth->execute('\\\'?:'); ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with quoted ? fails with a placeholder'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = '?'}; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with quoted :1 fails with a placeholder'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = ':1'}; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with quoted ? fails with a placeholder'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = '\\\\' AND pname = '?'}; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with named placeholders works'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar2 AND pname = :foobar AND pname = :foobar2}; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->bind_param(':foobar2', 456); $sth->execute(); }; is ($@, q{}, $t); ## Same, but fiddle with whitespace $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar2 AND pname = :foobar2}; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->bind_param(':foobar2', 456); $sth->execute(); }; is ($@, q{}, $t); $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar AND pname = :foobar2 }; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->bind_param(':foobar2', 456); $sth->execute(); }; is ($@, q{}, $t); $t='Execute with repeated named placeholders works'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar }; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->execute(); }; is ($@, q{}, $t); ## Same thing, different whitespace $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar}; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->execute(); }; is ($@, q{}, $t); $t='Prepare with large number of parameters works'; ## Test large number of placeholders $sql = 'SELECT 1 FROM dbd_pg_test WHERE id IN (' . '?,' x 300 . '?)'; my @args = map { $_ } (1..301); $sth = $dbh->prepare($sql); my $count = $sth->execute(@args); $sth->finish(); is ($count, 1, $t); $sth->finish(); $t='Prepare with backslashes inside quotes works'; $SQL = q{SELECT setting FROM pg_settings WHERE name = 'backslash_quote'}; $count = $dbh->selectall_arrayref($SQL)->[0]; my $backslash = defined $count ? $count->[0] : 0; my $scs = $dbh->{pg_standard_conforming_strings}; $SQL = $scs ? q{SELECT E'\\'?'} : q{SELECT '\\'?'}; $sth = $dbh->prepare($SQL); eval { $sth->execute(); }; my $expected = $backslash eq 'off' ? qr{unsafe} : qr{}; like ($@, $expected, $t); ## Test quoting of geometric types my @geotypes = qw/point line lseg box path polygon circle/; eval { $dbh->do('DROP TABLE dbd_pg_test_geom'); }; $dbh->commit(); $SQL = 'CREATE TABLE dbd_pg_test_geom ( id INT, argh TEXT[], '; for my $type (@geotypes) { $SQL .= "x$type $type,"; } $SQL =~ s/,$/)/; $dbh->do($SQL); $dbh->commit(); my %typemap = ( point => PG_POINT, line => PG_LINE, lseg => PG_LSEG, box => PG_BOX, path => PG_PATH, polygon => PG_POLYGON, circle => PG_CIRCLE, ); my $testdata = q{ point datatype integers 12,34 '12,34' (12,34) point datatype floating point numbers 1.34,667 '1.34,667' (1.34,667) point datatype exponential numbers 1e134,9E4 '1e134,9E4' (1e+134,90000) point datatype plus and minus signs 1e+134,-.45 '1e+134,-.45' (1e+134,-0.45) point datatype invalid number 123,abc ERROR: Invalid input for geometric type ERROR: any point datatype invalid format 123 '123' ERROR: any point datatype invalid format 123,456,789 '123,456,789' ERROR: any point datatype invalid format <(2,4),6> ERROR: Invalid input for geometric type ERROR: any point datatype invalid format [(1,2)] ERROR: Invalid input for geometric type ERROR: any line datatype integers 12,34 '12,34' ERROR: not yet implemented line datatype floating point numbers 1.34,667 '1.34,667' ERROR: not yet implemented line datatype exponential numbers 1e134,9E4 '1e134,9E4' ERROR: not yet implemented line datatype plus and minus signs 1e+134,-.45 '1e+134,-.45' ERROR: not yet implemented line datatype invalid number 123,abc ERROR: Invalid input for geometric type ERROR: not yet implemented lseg datatype invalid format 12,34 '12,34' ERROR: any lseg datatype integers (12,34),(56,78) '(12,34),(56,78)' [(12,34),(56,78)] lseg datatype floating point and exponential numbers (1.2,3.4),(5e3,7E1) '(1.2,3.4),(5e3,7E1)' [(1.2,3.4),(5000,70)] box datatype invalid format 12,34 '12,34' ERROR: any box datatype integers (12,34),(56,78) '(12,34),(56,78)' (56,78),(12,34) box datatype floating point and exponential numbers (1.2,3.4),(5e3,7E1) '(1.2,3.4),(5e3,7E1)' (5000,70),(1.2,3.4) path datatype invalid format 12,34 '12,34' ERROR: any path datatype integers (12,34),(56,78) '(12,34),(56,78)' ((12,34),(56,78)) path datatype floating point and exponential numbers (1.2,3.4),(5e3,7E1) '(1.2,3.4),(5e3,7E1)' ((1.2,3.4),(5000,70)) path datatype alternate bracket format [(1.2,3.4),(5e3,7E1)] '[(1.2,3.4),(5e3,7E1)]' [(1.2,3.4),(5000,70)] path datatype many elements (1.2,3.4),(5,6),(7,8),(-9,10) '(1.2,3.4),(5,6),(7,8),(-9,10)' ((1.2,3.4),(5,6),(7,8),(-9,10)) path datatype fails with braces {(1,2),(3,4)} ERROR: Invalid input for path type ERROR: any polygon datatype invalid format 12,34 '12,34' ERROR: any polygon datatype integers (12,34),(56,78) '(12,34),(56,78)' ((12,34),(56,78)) polygon datatype floating point and exponential numbers (1.2,3.4),(5e3,7E1) '(1.2,3.4),(5e3,7E1)' ((1.2,3.4),(5000,70)) polygon datatype many elements (1.2,3.4),(5,6),(7,8),(-9,10) '(1.2,3.4),(5,6),(7,8),(-9,10)' ((1.2,3.4),(5,6),(7,8),(-9,10)) polygon datatype fails with brackets [(1,2),(3,4)] ERROR: Invalid input for geometric type ERROR: any circle datatype integers <(12,34),5> '<(12,34),5>' <(12,34),5> circle datatype floating point and exponential numbers <(-1.2,2E2),3e3> '<(-1.2,2E2),3e3>' <(-1.2,200),3000> circle datatype fails with brackets [(1,2),(3,4)] ERROR: Invalid input for circle type ERROR: any }; $testdata =~ s/^\s+//; my $curtype = ''; for my $line (split /\n\n+/ => $testdata) { my ($text,$input,$quoted,$rows) = split /\n/ => $line; next if ! $text; $t = "Geometric type test: $text"; (my $type) = ($text =~ m{(\w+)}); last if $type eq 'LAST'; if ($curtype ne $type) { $curtype = $type; eval { $dbh->do('DEALLOCATE geotest'); }; $dbh->commit(); $dbh->do(qq{PREPARE geotest($type) AS INSERT INTO dbd_pg_test_geom(x$type) VALUES (\$1)}); $sth = $dbh->prepare(qq{INSERT INTO dbd_pg_test_geom(x$type) VALUES (?)}); $sth->bind_param(1, '', {pg_type => $typemap{$type} }); } $dbh->do('DELETE FROM dbd_pg_test_geom'); eval { $qresult = $dbh->quote($input, {pg_type => $typemap{$type}}); }; if ($@) { if ($quoted !~ /ERROR: (.+)/) { ## no critic fail ("$t error: $@"); } else { like ($@, qr{$1}, $t); } } else { is ($qresult, $quoted, $t); } $dbh->commit(); eval { $dbh->do("EXECUTE geotest('$input')"); }; if ($@) { if ($rows !~ /ERROR: .+/) { fail ("$t error: $@"); } else { ## Do any error for now: i18n worries pass ($t); } } $dbh->commit(); eval { $sth->execute($input); }; if ($@) { if ($rows !~ /ERROR: .+/) { fail ($t); } else { ## Do any error for now: i18n worries pass ($t); } } $dbh->commit(); if ($rows !~ /ERROR/) { $SQL = "SELECT x$type FROM dbd_pg_test_geom"; $expected = [[$rows],[$rows]]; $result = $dbh->selectall_arrayref($SQL); is_deeply ($result, $expected, $t); } } $t='Calling do() with non-DML placeholder works'; $sth->finish(); $dbh->commit(); eval { $dbh->do(q{SET search_path TO ?}, undef, 'pg_catalog'); }; is ($@, q{}, $t); $dbh->rollback(); $t='Calling do() with DML placeholder works'; $dbh->commit(); eval { $dbh->do(q{SELECT ?::text}, undef, 'public'); }; is ($@, q{}, $t); $t='Calling do() with invalid crowded placeholders fails cleanly'; $dbh->commit(); eval { $dbh->do(q{SELECT ??}, undef, 'public', 'error'); }; is ($dbh->state, '42601', $t); $t='Prepare/execute with non-DML placeholder works'; $dbh->commit(); eval { $sth = $dbh->prepare(q{SET search_path TO ?}); $sth->execute('pg_catalog'); }; is ($@, q{}, $t); $dbh->rollback(); $t='Prepare/execute does not allow geometric operators'; eval { $sth = $dbh->prepare(q{SELECT ?- lseg '(1,0),(1,1)'}); $sth->execute(); }; like ($@, qr{unbound placeholder}, $t); $t='Prepare/execute allows geometric operator ?- when dollaronly is set'; $dbh->commit(); $dbh->{pg_placeholder_dollaronly} = 1; eval { $sth = $dbh->prepare(q{SELECT ?- lseg '(1,0),(1,1)'}); $sth->execute(); $sth->finish(); }; is ($@, q{}, $t); $t='Prepare/execute allows geometric operator ?# when dollaronly set'; $dbh->commit(); eval { $sth = $dbh->prepare(q{SELECT lseg'(1,0),(1,1)' ?# lseg '(2,3),(4,5)'}); $sth->execute(); $sth->finish(); }; is ($@, q{}, $t); $t=q{Value of placeholder_dollaronly can be retrieved}; is ($dbh->{pg_placeholder_dollaronly}, 1, $t); $t=q{Prepare/execute does not allow use of raw ? and :foo forms}; $dbh->{pg_placeholder_dollaronly} = 0; eval { $sth = $dbh->prepare(q{SELECT uno ?: dos ? tres :foo bar $1}); $sth->execute(); $sth->finish(); }; like ($@, qr{mix placeholder}, $t); $t='Prepare/execute allows use of raw ? and :foo forms when dollaronly set'; $dbh->{pg_placeholder_dollaronly} = 1; eval { $sth = $dbh->prepare(q{SELECT uno ?: dos ? tres :foo bar $1}, {pg_placeholder_dollaronly => 1}); $sth->{pg_placeholder_dollaronly} = 1; $sth->execute(); $sth->finish(); }; like ($@, qr{unbound placeholder}, $t); $t='Prepare works with pg_placeholder_dollaronly'; $dbh->{pg_placeholder_dollaronly} = 0; eval { $sth = $dbh->prepare(q{SELECT uno ?: dos ? tres :foo bar $1}, {pg_placeholder_dollaronly => 1}); $sth->execute(); $sth->finish(); }; like ($@, qr{unbound placeholder}, $t); $t=q{Value of placeholder_nocolons defaults to 0}; is ($dbh->{pg_placeholder_nocolons}, 0, $t); $t='Simple array slices do not get picked up as placeholders'; $SQL = q{SELECT argh[1:2] FROM dbd_pg_test_geom WHERE id = ?}; eval { $sth = $dbh->prepare($SQL); $sth->execute(1); $sth->finish(); }; is ($@, q{}, $t); $t='Without placeholder_nocolons, queries with array slices fail'; $SQL = q{SELECT argh[1 :2] FROM dbd_pg_test_geom WHERE id = ?}; eval { $sth = $dbh->prepare($SQL); $sth->execute(1); $sth->finish(); }; like ($@, qr{Cannot mix placeholder styles}, $t); $t='Use of statement level placeholder_nocolons allows use of ? placeholders while ignoring :'; eval { $sth = $dbh->prepare($SQL, {pg_placeholder_nocolons => 1}); $sth->execute(1); $sth->finish(); }; is ($@, q{}, $t); $t='Use of database level placeholder_nocolons allows use of ? placeholders while ignoring :'; $dbh->{pg_placeholder_nocolons} = 1; eval { $sth = $dbh->prepare($SQL); $sth->execute(1); $sth->finish(); }; is ($@, q{}, $t); $t=q{Value of placeholder_nocolons can be retrieved}; is ($dbh->{pg_placeholder_nocolons}, 1, $t); $t='Use of statement level placeholder_nocolons allows use of $ placeholders while ignoring :'; $dbh->{pg_placeholder_nocolons} = 0; $SQL = q{SELECT argh[1:2] FROM dbd_pg_test_geom WHERE id = $1}; eval { $sth = $dbh->prepare($SQL, {pg_placeholder_nocolons => 1}); $sth->execute(1); $sth->finish(); }; is ($@, q{}, $t); $t='Use of database level placeholder_nocolons allows use of $ placeholders while ignoring :'; $dbh->{pg_placeholder_nocolons} = 1; eval { $sth = $dbh->prepare($SQL); $sth->execute(1); $sth->finish(); }; is ($@, q{}, $t); $dbh->{pg_placeholder_nocolons} = 0; $t='Prepare works with identical named placeholders'; eval { $sth = $dbh->prepare(q{SELECT :row, :row, :row, :yourboat}); $sth->finish(); }; is ($@, q{}, $t); $t='Prepare works with placeholders after double slashes'; eval { $dbh->do(q{CREATE OPERATOR // ( PROCEDURE=bit, LEFTARG=int, RIGHTARG=int )}); $sth = $dbh->prepare(q{SELECT ? // ?}); $sth->execute(1,2); $sth->finish(); }; is ($@, q{}, $t); $t='Dollar quotes starting with a number are not treated as valid identifiers'; eval { $sth = $dbh->prepare(q{SELECT $123$ $123$}); $sth->execute(1); $sth->finish(); }; like ($@, qr{Invalid placeholders}, $t); $t='Dollar quotes with invalid characters are not parsed as identifiers'; for my $char (qw!+ / : @ [ `!) { ## six characters eval { $sth = $dbh->prepare(qq{SELECT \$abc${char}\$ 123 \$abc${char}\$}); $sth->execute(); $sth->finish(); }; like ($@, qr{syntax error}, "$t: char=$char"); } $t='Dollar quotes with valid characters are parsed as identifiers'; $dbh->rollback(); for my $char (qw{0 9 A Z a z}) { ## six letters eval { $sth = $dbh->prepare(qq{SELECT \$abc${char}\$ 123 \$abc${char}\$}); $sth->execute(); $sth->finish(); }; is ($@, q{}, $t); } SKIP: { my $server_encoding = $dbh->selectrow_array('SHOW server_encoding'); my $client_encoding = $dbh->selectrow_array('SHOW client_encoding'); skip "Cannot test non-ascii dollar quotes with server_encoding='$server_encoding' (need UTF8 or SQL_ASCII)", 3, unless $server_encoding =~ /\A(?:UTF8|SQL_ASCII)\z/; skip 'Cannot test non-ascii dollar quotes unless client_encoding is UTF8', 3 if $client_encoding ne 'UTF8'; for my $ident (qq{\x{5317}}, qq{abc\x{5317}}, qq{_cde\x{5317}}) { ## hi-bit chars eval { $sth = $dbh->prepare(qq{SELECT \$$ident\$ 123 \$$ident\$}); $sth->execute(); $sth->finish(); }; is ($@, q{}, $t); } } SKIP: { skip 'Cannot run backslash_quote test on Postgres < 8.2', 1 if $pgversion < 80200; $t='Backslash quoting inside double quotes is parsed correctly'; $dbh->do(q{SET backslash_quote = 'on'}); $dbh->commit(); eval { $sth = $dbh->prepare(q{SELECT * FROM "\" WHERE a=?}); $sth->execute(1); $sth->finish(); }; like ($@, qr{relation ".*" does not exist}, $t); } $dbh->rollback(); SKIP: { skip 'Cannot adjust standard_conforming_strings for testing on this version of Postgres', 4 if $pgversion < 80200 or $pgversion >= 19000; $t='Backslash quoting inside single quotes is parsed correctly with standard_conforming_strings off'; $dbh->do(q{SET standard_conforming_strings = 'off'}); eval { local $dbh->{Warn} = ''; $sth = $dbh->prepare(q{SELECT '\', ?}); $sth->execute(); $sth->finish(); }; like ($@, qr{unterminated quoted string}, $t); $dbh->rollback(); $t=q{Backslash quoting inside E'' is parsed correctly with standard_conforming_strings = 'off'}; eval { $sth = $dbh->prepare(q{SELECT E'\'?'}); $sth->execute(); $sth->finish; }; is ($@, q{}, $t); $dbh->rollback(); $t='Backslash quoting inside single quotes is parsed correctly with standard_conforming_strings on'; eval { $dbh->do(q{SET standard_conforming_strings = 'on'}); $sth = $dbh->prepare(q{SELECT '\', ?::int}); $sth->execute(1); $sth->finish(); }; is ($@, q{}, $t); $t=q{Backslash quoting inside E'' is parsed correctly with standard_conforming_strings = 'on'}; eval { $sth = $dbh->prepare(q{SELECT E'\'?'}); $sth->execute(); $sth->finish; }; is ($@, q{}, $t); } $t='Valid integer works when quoting with SQL_INTEGER'; my $val; $val = $dbh->quote('123', SQL_INTEGER); is ($val, 123, $t); $t='Invalid integer fails to pass through when quoting with SQL_INTEGER'; $val = -1; eval { $val = $dbh->quote('123abc', SQL_INTEGER); }; like ($@, qr{Invalid integer}, $t); is ($val, -1, $t); my $prefix = 'Valid float value works when quoting with SQL_FLOAT'; for my $float ('123','0.00','0.234','23.31562', '1.23e04','6.54e+02','4e-3','NaN','Infinity','-infinity') { $t = "$prefix (value=$float)"; $val = -1; eval { $val = $dbh->quote($float, SQL_FLOAT); }; is ($@, q{}, $t); is ($val, $float, $t); next unless $float =~ /\w/; my $lcfloat = lc $float; $t = "$prefix (value=$lcfloat)"; $val = -1; eval { $val = $dbh->quote($lcfloat, SQL_FLOAT); }; is ($@, q{}, $t); is ($val, $lcfloat, $t); my $ucfloat = uc $float; $t = "$prefix (value=$ucfloat)"; $val = -1; eval { $val = $dbh->quote($ucfloat, SQL_FLOAT); }; is ($@, q{}, $t); is ($val, $ucfloat, $t); } $prefix = 'Invalid float value fails when quoting with SQL_FLOAT'; for my $float ('3abc','123abc','','NaNum','-infinitee') { $t = "$prefix (value=$float)"; $val = -1; eval { $val = $dbh->quote($float, SQL_FLOAT); }; like ($@, qr{Invalid float}, $t); is ($val, -1, $t); } $dbh->rollback(); ## Test placeholders plus binding $t='Bound placeholders enforce data types when not using server side prepares'; $dbh->trace(0); $dbh->{pg_server_prepare} = 0; $sth = $dbh->prepare('SELECT (1+?+?)::integer'); $sth->bind_param(1, 1, SQL_INTEGER); eval { $sth->execute('10foo',20); }; like ($@, qr{Invalid integer}, 'Invalid integer test 2'); ## Test quoting of the "name" type $prefix = q{The 'name' data type does correct quoting}; for my $word (qw/User user USER trigger Trigger user-user/) { $t = qq{$prefix for the word "$word"}; my $got = $dbh->quote($word, { pg_type => PG_NAME }); $expected = qq{"$word"}; is ($got, $expected, $t); } for my $word (qw/auser userz/) { $t = qq{$prefix for the word "$word"}; my $got = $dbh->quote($word, { pg_type => PG_NAME }); $expected = qq{$word}; is ($got, $expected, $t); } ## Test quoting of booleans my %booltest = ( ## no critic (Lax::ProhibitLeadingZeros::ExceptChmod, ValuesAndExpressions::ProhibitLeadingZeros, ValuesAndExpressions::ProhibitDuplicateHashKeys) undef => 'NULL', 't' => 'TRUE', 'T' => 'TRUE', 'true' => 'TRUE', 'TRUE' => 'TRUE', 1 => 'TRUE', '01' => 'TRUE', '1' => 'TRUE', '0E0' => 'TRUE', '0e0' => 'TRUE', '0 but true' => 'TRUE', '0 BUT TRUE' => 'TRUE', 'real true' => 'TRUE', 'f' => 'FALSE', 'F' => 'FALSE', 0 => 'FALSE', 00 => 'FALSE', '0' => 'FALSE', 'false' => 'FALSE', 'FALSE' => 'FALSE', '' => 'FALSE', 'real false' => 'FALSE', 12 => 'ERROR', '01' => 'ERROR', '00' => 'ERROR', ' false' => 'ERROR', ' TRUE' => 'ERROR', 'FALSEY' => 'ERROR', 'trueish' => 'ERROR', '0E0E0' => 'ERROR', ## Jungle love... '0 but truez' => 'ERROR', ); while (my ($name,$res) = each %booltest) { my ($bool, $desc) = $name eq 'undef' ? (undef, $name) : $name =~ /\Areal/ ? (!!($name =~ / true\z/), $name) : ($name, qq{"$name"}); $t = "Boolean quoting of $desc", eval { $result = $dbh->quote($bool, {pg_type => PG_BOOL}); }; if ($@) { if ($res eq 'ERROR' and $@ =~ /Invalid boolean/) { pass ($t); } else { fail ("Failure at $t: $@"); } $dbh->rollback(); } else { is ($result, $res, $t); } } $t = q{Inserting into a boolean column with an empty string fails}; $SQL = q{INSERT INTO dbd_pg_test(id, "CaseTest", val) VALUES (?,?,?) RETURNING id, "CaseTest"}; $sth = $dbh->prepare($SQL); eval { $sth->execute(101,'','Boolean empty string attempt number one'); }; ok ($@, $t); $dbh->rollback(); $t = q{Inserting into a boolean column with an empty string works if we call bind_param first}; $sth = $dbh->prepare($SQL); $sth->bind_param(2,'f',SQL_BOOLEAN); $sth->execute(102,'','Boolean empty string attempt number two'); is_deeply ($sth->fetch, [102,0], $t); $t = q{Inserting into a boolean column with an empty string fails if we cast the boolean}; $SQL = q{INSERT INTO dbd_pg_test(id, "CaseTest",val) VALUES (?,?::BOOLEAN,?) RETURNING id, "CaseTest"}; $sth = $dbh->prepare($SQL); eval { $sth->execute(103,'','Boolean empty string attempt number three'); }; ok ($@, $t); $dbh->rollback(); $t = q{Inserting into a boolean column with an empty string works if we call bind_param first (pg_bool_tf on)}; $sth = $dbh->prepare($SQL); $sth->bind_param(2,'TRUE',SQL_BOOLEAN); $sth->execute(104,'','Boolean empty string attempt number four'); $dbh->{pg_bool_tf} = 1; is_deeply ($sth->fetch, [104,'f'], $t); $dbh->{pg_bool_tf} = 0; SKIP: { skip 'Cannot test native false without builtin::is_bool', 3 unless defined &builtin::is_bool; $t = q{Inserting into a boolean column with native false works}; $sth = $dbh->prepare($SQL); $sth->execute(105, !!0, 'Boolean native false'); is_deeply ($sth->fetch, [105, 0], $t); local $dbh->{pg_bool_tf} = 1; $t = q{Inserting into a boolean column with native false works (pg_bool_tf on)}; $sth = $dbh->prepare($SQL); $sth->execute(106, !!1, 'Boolean native true (pg_bool_tf on)'); is_deeply ($sth->fetch, [106, 't'], $t); $sth->execute(107, !!0, 'Boolean native false (pg_bool_tf on)'); is_deeply ($sth->fetch, [107, 'f'], $t); } ## Test of placeholder escaping. Enabled by default, so let's jump right in $t = q{Basic placeholder escaping works via backslash-question mark for \?}; ## But first, we need some operators $dbh->do('create operator ? (leftarg=int,rightarg=int,procedure=int4eq)'); $dbh->commit(); $dbh->do('create operator ?? (leftarg=text,rightarg=text,procedure=texteq)'); $dbh->commit(); ## This is necessary to "reset" the var so we can test the modification properly undef $SQL; $SQL = qq{SELECT count(*) FROM dbd_pg_test WHERE id \\? ?}; ## no critic my $original_sql = "$SQL"; ## Need quotes because we don't want a shallow copy! $sth = $dbh->prepare($SQL); eval { $count = $sth->execute(123); }; is ($@, '', $t); $sth->finish(); $t = q{Basic placeholder escaping does NOT modify the original string}; ## RT 114000 is ($SQL, $original_sql, $t); $t = q{Basic placeholder escaping works via backslash-question mark for \?\?}; $SQL = qq{SELECT count(*) FROM dbd_pg_test WHERE pname \\?\\? ?}; ## no critic $sth = $dbh->prepare($SQL); eval { $count = $sth->execute('foobar'); }; is ($@, '', $t); $sth->finish(); ## This is an emergency hatch only. Hopefully will never be used in the wild! $dbh->{pg_placeholder_escaped} = 0; $t = q{Basic placeholder escaping fails when pg_placeholder_escaped is set to false}; $SQL = qq{SELECT count(*) FROM dbd_pg_test WHERE pname \\?\\? ?}; ## no critic $sth = $dbh->prepare($SQL); eval { $count = $sth->execute('foobar'); }; like ($@, qr{execute}, $t); $sth->finish(); ## The space before the colon is significant here $SQL = q{SELECT testarray [1 :5] FROM dbd_pg_test WHERE pname = :foo}; $sth = $dbh->prepare($SQL); eval { $sth->bind_param(':foo', 'abc'); $count = $sth->execute(); }; like ($@, qr{execute}, $t); $sth->finish(); $t = q{Placeholder escaping works for colons}; $dbh->{pg_placeholder_escaped} = 1; $SQL = q{SELECT testarray [1 \:5] FROM dbd_pg_test WHERE pname = :foo}; $sth = $dbh->prepare($SQL); eval { $sth->bind_param(':foo', 'abc'); $count = $sth->execute(); }; is ($@, '', $t); $sth->finish(); ## Begin custom type testing $dbh->rollback(); cleanup_database($dbh,'test'); $dbh->disconnect(); DBD-Pg-3.20.2/t/06bytea.t0000644000175000017500000001157115174664306013110 0ustar greggreg#!perl ## Test bytea handling use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Test::More; use DBI ':sql_types'; use DBD::Pg ':pg_types'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 36; isnt ($dbh, undef, 'Connect to database for bytea testing'); my $pgversion = $dbh->{pg_server_version}; if ($pgversion >= 80100 and $pgversion < 19000) { $dbh->do('SET escape_string_warning = false'); } my ($sth, $t); $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest,bytearray,testarray2) VALUES (?,?,'{1,2,3}','{5,6,7}')}); $t='bytea insert test with string containing null and backslashes'; $sth->bind_param(1, undef, { pg_type => PG_INT4 }); $sth->bind_param(2, undef, { pg_type => PG_BYTEA }); ok ($sth->execute(400, 'aa\\bb\\cc\\\0dd\\'), $t); ## nospellcheck $t='bytea insert test with string containing a single quote'; ok ($sth->execute(401, '\''), $t); $t='bytea (second) insert test with string containing a single quote'; ok ($sth->execute(402, '\''), $t); my ($binary_in, $binary_out); $t='store binary data in BYTEA column'; for(my $i=0; $i<256; $i++) { $binary_out .= chr($i); } $sth->{pg_server_prepare} = 0; ok ($sth->execute(403, $binary_out), $t); $sth->{pg_server_prepare} = 1; ok ($sth->execute(404, $binary_out), $t); $t='store binary data in BYTEA column via SQL_BLOB'; $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest,bytearray,testarray2) VALUES (?,?,'{1,2,3}','{5,6,7}')}); $sth->bind_param(1, undef, { pg_type => PG_INT4 }); $sth->bind_param(2, undef, SQL_BLOB); ok ($sth->execute(405, $binary_out), $t); $t='store binary data in BYTEA column via SQL_BINARY'; $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest,bytearray,testarray2) VALUES (?,?,'{1,2,3}','{5,6,7}')}); $sth->bind_param(1, undef, { pg_type => PG_INT4 }); $sth->bind_param(2, undef, SQL_BINARY); ok ($sth->execute(406, $binary_out), $t); $t='store binary data in BYTEA column via SQL_VARBINARY'; $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest,bytearray,testarray2) VALUES (?,?,'{1,2,3}','{5,6,7}')}); $sth->bind_param(1, undef, { pg_type => PG_INT4 }); $sth->bind_param(2, undef, SQL_VARBINARY); ok ($sth->execute(407, $binary_out), $t); $t='store binary data in BYTEA column via SQL_LONGVARBINARY'; $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest,bytearray,testarray2) VALUES (?,?,'{1,2,3}','{5,6,7}')}); $sth->bind_param(1, undef, { pg_type => PG_INT4 }); $sth->bind_param(2, undef, SQL_LONGVARBINARY); ok ($sth->execute(408, $binary_out), $t); if ($pgversion < 90000) { test_outputs(undef); SKIP: { skip 'No BYTEA output format setting before 9.0', 13 } } else { test_outputs($_) for qw(hex escape); } $sth->finish(); cleanup_database($dbh,'test'); $dbh->disconnect(); sub test_outputs { my $output = shift; $dbh->do(qq{SET bytea_output = '$output'}) if $output; $t='Received correct text from BYTEA column with backslashes'; $t.=" ($output output)" if $output; $sth = $dbh->prepare(q{SELECT bytetest FROM dbd_pg_test WHERE id=?}); $sth->execute(400); my $byte = $sth->fetchall_arrayref()->[0][0]; is ($byte, 'aa\bb\cc\\\0dd\\', $t); ## nospellcheck $t='Received correct text from BYTEA column with quote'; $t.=" ($output output)" if $output; $sth->execute(402); $byte = $sth->fetchall_arrayref()->[0][0]; is ($byte, '\'', $t); $t='Ensure proper handling of high bit characters'; $t.=" ($output output)" if $output; $sth->execute(403); ($binary_in) = $sth->fetchrow_array(); cmp_ok ($binary_in, 'eq', $binary_out, $t); $sth->execute(404); ($binary_in) = $sth->fetchrow_array(); ok ($binary_in eq $binary_out, $t); $sth->execute(405); ($binary_in) = $sth->fetchrow_array(); cmp_ok ($binary_in, 'eq', $binary_out, $t); $sth->execute(406); ($binary_in) = $sth->fetchrow_array(); cmp_ok ($binary_in, 'eq', $binary_out, $t); $sth->execute(407); ($binary_in) = $sth->fetchrow_array(); cmp_ok ($binary_in, 'eq', $binary_out, $t); $sth->execute(408); ($binary_in) = $sth->fetchrow_array(); cmp_ok ($binary_in, 'eq', $binary_out, $t); $t='quote properly handles bytea strings'; $t.=" ($output output)" if $output; my $string = "abc\123\\def\0ghi"; my $result = $dbh->quote($string, { pg_type => PG_BYTEA }); my $E = $pgversion >= 80100 ? q{E} : q{}; my $expected = qq{${E}'abc\123\\\\\\\\def\\\\000ghi'}; is ($result, $expected, $t); is ($dbh->quote($string, SQL_BLOB), $expected, "$t (SQL_BLOB)"); is ($dbh->quote($string, SQL_BINARY), $expected, "$t (SQL_BINARY)"); is ($dbh->quote($string, SQL_VARBINARY), $expected, "$t (SQL_VARBINARY)"); is ($dbh->quote($string, SQL_LONGVARBINARY), $expected, "$t (SQL_LONGVARBINARY)"); return; } DBD-Pg-3.20.2/t/lib/0000755000175000017500000000000015175422003012175 5ustar greggregDBD-Pg-3.20.2/t/lib/App/0000755000175000017500000000000015175422003012715 5ustar greggregDBD-Pg-3.20.2/t/lib/App/Info.pm0000644000175000017500000013522415157052770014167 0ustar greggregpackage App::Info; =head1 NAME App::Info - Information about software packages on a system =head1 SYNOPSIS use App::Info::Category::FooApp; my $app = App::Info::Category::FooApp->new; if ($app->installed) { print "App name: ", $app->name, "\n"; print "Version: ", $app->version, "\n"; print "Bin dir: ", $app->bin_dir, "\n"; } else { print "App not installed on your system. :-(\n"; } =head1 DESCRIPTION App::Info is an abstract base class designed to provide a generalized interface for subclasses that provide meta data 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 meta data about those software packages. App::Info provides an event model for handling events triggered by App::Info subclasses. The events are classified as "info", "error", "unknown", and "confirm" events, and multiple handlers may be specified to handle any or all of these event types. This allows App::Info clients to flexibly handle events in any way they deem necessary. Implementing new event handlers is straight-forward, and use the triggering of events by App::Info subclasses is likewise kept easy-to-use. A few L are provided with the distribution, but others are invited to write their own subclasses and contribute them to the CPAN. Contributors are welcome to extend their subclasses to provide more information relevant to the application for which data is to be provided (see L for an example), but are encouraged to, at a minimum, implement the abstract methods defined here and in the category abstract base classes (e.g., L and L). See L for more information on implementing new subclasses. =cut use strict; use Carp (); use App::Info::Handler; use App::Info::Request; our $VERSION = '0.57'; ############################################################################## ############################################################################## # This code ref is used by the abstract methods to throw an exception when # they're called directly. my $croak = sub { my ($caller, $meth) = @_; $caller = ref $caller || $caller; if ($caller eq __PACKAGE__) { $meth = __PACKAGE__ . '::' . $meth; Carp::croak(__PACKAGE__ . " is an abstract base class. Attempt to " . " call non-existent method $meth"); } else { Carp::croak("Class $caller inherited from the abstract base class " . __PACKAGE__ . ", but failed to redefine the $meth() " . "method. Attempt to call non-existent method " . "${caller}::$meth"); } }; ############################################################################## # This code reference is used by new() and the on_* error handler methods to # set the error handlers. my $set_handlers = sub { my $on_key = shift; # Default is to do nothing. return unless $on_key; my $ref = ref $on_key; if ($ref) { $on_key = [$on_key] unless $ref eq 'ARRAY'; # Make sure they're all handlers. foreach my $h (@$on_key) { if (my $r = ref $h) { Carp::croak("$r object is not an App::Info::Handler") unless UNIVERSAL::isa($h, 'App::Info::Handler'); } else { # Look up the handler. $h = App::Info::Handler->new( key => $h); } } # Return 'em! return @$on_key; } else { # Look up the handler. return App::Info::Handler->new( key => $on_key); } }; ############################################################################## ############################################################################## =head1 INTERFACE This section documents the public interface of App::Info. =head2 Constructor =head3 new my $app = App::Info::Category::FooApp->new(@params); Constructs an App::Info object and returns it. The @params arguments define attributes that can be used to help the App::Info object search for application information on the file system, as well as how the App::Info object will respond to certain events. The event parameters correspond to their like-named methods. See the L<"Event Handler Object Methods"> section for more information on App::Info events and how to handle them. The search parameters that can be passed to C are: =over =item search_exe_names An array reference of possible names for binary executables. These may be used by subclasses to search for application programs that can be used to retrieve application information, such as version numbers. The subclasses generally provide reasonable defaults for most cases. =item search_bin_dirs An array reference of local directories in which to search for executables. These may be used to search for the value of the C attribute in addition to and in preference to the defaults used by each subclass. =item search_lib_names An array reference of possible names for library files. These may be used by subclasses 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 subclasses to search for shared object library files for the application. The subclasses generally provide reasonable defaults for most cases. =item search_lib_dirs An array reference of local directories in which to search for libraries. These may be used to search for the value of the C and C attributes in addition to and in preference to the defaults used by each subclass. =item search_inc_names An array reference of possible names for include files. These may be used by subclasses to search for include files for the application. The subclasses generally provide reasonable defaults for most cases. =item search_inc_dirs An array reference of local directories in which to search for include files. These may be used to search for the value of the C attribute in addition to and in preference to the defaults used by each subclass. =back The parameters to C for the different types of App::Info events are: =over 4 =item on_info =item on_error =item on_unknown =item on_confirm =back When passing event handlers to C, the list of handlers for each type should be an anonymous array, for example: my $app = App::Info::Category::FooApp->new( on_info => \@handlers ); =cut sub new { my ($pkg, %p) = @_; my $class = ref $pkg || $pkg; # Fail if the method isn't overridden. $croak->($pkg, 'new') if $class eq __PACKAGE__; # Set up handlers. for (qw(on_error on_unknown on_info on_confirm)) { $p{$_} = [$set_handlers->($p{$_})]; } # Set up search defaults. for (qw(bin_dirs lib_dirs inc_dirs exe_names lib_names inc_names so_lib_names)) { local $_ = "search_$_"; if (exists $p{$_}) { $p{$_} = [$p{$_}] unless ref $p{$_} eq 'ARRAY'; } else { $p{$_} = []; } } # Do it! return bless \%p, $class; } ############################################################################## ############################################################################## =head2 Meta Data Object Methods These are abstract methods in App::Info and must be provided by its subclasses. They provide the essential meta data of the software package supported by the App::Info subclass. =head3 key_name my $key_name = $app->key_name; Returns a string that uniquely identifies the software for which the App::Info subclass provides data. This value should be unique across all App::Info classes. Typically, it's simply the name of the software. =cut sub key_name { $croak->(shift, 'key_name') } =head3 installed if ($app->installed) { print "App is installed.\n" } else { print "App is not installed.\n" } Returns a true value if the application is installed, and a false value if it is not. =cut sub installed { $croak->(shift, 'installed') } ############################################################################## =head3 name my $name = $app->name; Returns the name of the application. =cut sub name { $croak->(shift, 'name') } ############################################################################## =head3 version my $version = $app->version; Returns the full version number of the application. =cut ############################################################################## sub version { $croak->(shift, 'version') } =head3 major_version my $major_version = $app->major_version; Returns the major version number of the application. For example, if C returns "7.1.2", then this method returns "7". =cut sub major_version { $croak->(shift, 'major_version') } ############################################################################## =head3 minor_version my $minor_version = $app->minor_version; Returns the minor version number of the application. For example, if C returns "7.1.2", then this method returns "1". =cut sub minor_version { $croak->(shift, 'minor_version') } ############################################################################## =head3 patch_version my $patch_version = $app->patch_version; Returns the patch version number of the application. For example, if C returns "7.1.2", then this method returns "2". =cut sub patch_version { $croak->(shift, 'patch_version') } ############################################################################## =head3 bin_dir my $bin_dir = $app->bin_dir; Returns the full path the application's bin directory, if it exists. =cut sub bin_dir { $croak->(shift, 'bin_dir') } ############################################################################## =head3 executable my $executable = $app->executable; Returns the full path the application's bin directory, if it exists. =cut sub executable { $croak->(shift, 'executable') } ############################################################################## =head3 inc_dir my $inc_dir = $app->inc_dir; Returns the full path the application's include directory, if it exists. =cut sub inc_dir { $croak->(shift, 'inc_dir') } ############################################################################## =head3 lib_dir my $lib_dir = $app->lib_dir; Returns the full path the application's lib directory, if it exists. =cut sub lib_dir { $croak->(shift, 'lib_dir') } ############################################################################## =head3 so_lib_dir my $so_lib_dir = $app->so_lib_dir; Returns the full path the application's shared library directory, if it exists. =cut sub so_lib_dir { $croak->(shift, 'so_lib_dir') } ############################################################################## =head3 home_url my $home_url = $app->home_url; The URL for the software's home page. =cut sub home_url { $croak->(shift, 'home_url') } ############################################################################## =head3 download_url my $download_url = $app->download_url; The URL for the software's download page. =cut sub download_url { $croak->(shift, 'download_url') } ############################################################################## ############################################################################## =head2 Search Attributes These methods return lists of things to look for on the local file system when searching for application programs, library files, and include files. They are empty by default, since each subclass generally relies on its own settings, but you can add your own as preferred search parameters by specifying them as parameters to the C constructor. =head3 exe_names my @search_exe_names = $app->search_exe_names; Returns a list of possible names for an executable. Typically used by the C constructor to search for an executable to execute and collect application info. =cut sub search_exe_names { @{shift->{search_exe_names}} } ############################################################################## =head3 search_bin_dirs my @search_bin_dirs = $app->search_bin_dirs; Returns a list of possible directories in which to search an executable. Typically used by the C constructor to find an executable to execute and collect application info. The found directory will also generally then be returned by the C method. =cut sub search_bin_dirs { @{shift->{search_bin_dirs}} } ############################################################################## =head3 lib_names my @search_lib_names = $app->search_lib_names; Returns a list of possible names for library files. Typically used by the C method to find library files. =cut sub search_lib_names { @{shift->{search_lib_names}} } ############################################################################## =head3 so_lib_names my @search_so_lib_names = $app->search_so_lib_names; Returns a list of possible names for library files. Typically used by the C method to find shared object library files. =cut sub search_so_lib_names { @{shift->{search_so_lib_names}} } ############################################################################## =head3 search_lib_dirs my @search_lib_dirs = $app->search_lib_dirs; Returns a list of possible directories in which to search for libraries. Typically used by the C and C methods to find library files. =cut sub search_lib_dirs { @{shift->{search_lib_dirs}} } ############################################################################## =head3 inc_names my @search_inc_names = $app->search_inc_names; Returns a list of possible names for include files. Typically used by the C method to find include files. =cut sub search_inc_names { @{shift->{search_inc_names}} } ############################################################################## =head3 search_inc_dirs my @search_inc_dirs = $app->search_inc_dirs; Returns a list of possible directories in which to search for includes. Typically used by the C method to find include files. =cut sub search_inc_dirs { @{shift->{search_inc_dirs}} } ############################################################################## ############################################################################## =head2 Event Handler Object Methods These methods provide control over App::Info event handling. Events can be handled by one or more objects of subclasses of App::Info::Handler. The first to return a true value will be the last to execute. This approach allows handlers to be stacked, and makes it relatively easy to create new handlers. L for information on writing event handlers. Each of the event handler methods takes a list of event handlers as its arguments. If none are passed, the existing list of handlers for the relevant event type will be returned. If new handlers are passed in, they will be returned. The event handlers may be specified as one or more objects of the App::Info::Handler class or subclasses, as one or more strings that tell App::Info construct such handlers itself, or a combination of the two. The strings can only be used if the relevant App::Info::Handler subclasses have registered strings with App::Info. For example, the App::Info::Handler::Print class included in the App::Info distribution registers the strings "stderr" and "stdout" when it starts up. These strings may then be used to tell App::Info to construct App::Info::Handler::Print objects that print to STDERR or to STDOUT, respectively. See the App::Info::Handler subclasses for what strings they register with App::Info. =head3 on_info my @handlers = $app->on_info; $app->on_info(@handlers); Info events are triggered when the App::Info subclass wants to send an informational status message. By default, these events are ignored, but a common need is for such messages to simply print to STDOUT. Use the L class included with the App::Info distribution to have info messages print to STDOUT: use App::Info::Handler::Print; $app->on_info('stdout'); # Or: my $stdout_handler = App::Info::Handler::Print->new('stdout'); $app->on_info($stdout_handler); =cut sub on_info { my $self = shift; @{ $self->{on_info} } = $set_handlers->(\@_) if @_; return @{ $self->{on_info} }; } =head3 on_error my @handlers = $app->on_error; $app->on_error(@handlers); Error events are triggered when the App::Info subclass runs into an unexpected but not fatal problem. (Note that fatal problems will likely throw an exception.) By default, these events are ignored. A common way of handling these events is to print them to STDERR, once again using the L class included with the App::Info distribution: use App::Info::Handler::Print; my $app->on_error('stderr'); # Or: my $stderr_handler = App::Info::Handler::Print->new('stderr'); $app->on_error($stderr_handler); Another approach might be to turn such events into fatal exceptions. Use the included L class for this purpose: use App::Info::Handler::Carp; my $app->on_error('croak'); # Or: my $croaker = App::Info::Handler::Carp->new('croak'); $app->on_error($croaker); =cut sub on_error { my $self = shift; @{ $self->{on_error} } = $set_handlers->(\@_) if @_; return @{ $self->{on_error} }; } =head3 on_unknown my @handlers = $app->on_unknown; $app->on_uknown(@handlers); Unknown events are triggered when the App::Info subclass cannot find the value to be returned by a method call. By default, these events are ignored. A common way of handling them is to have the application prompt the user for the relevant data. The App::Info::Handler::Prompt class included with the App::Info distribution can do just that: use App::Info::Handler::Prompt; my $app->on_unknown('prompt'); # Or: my $prompter = App::Info::Handler::Prompt; $app->on_unknown($prompter); See L for information on how it works. =cut sub on_unknown { my $self = shift; @{ $self->{on_unknown} } = $set_handlers->(\@_) if @_; return @{ $self->{on_unknown} }; } =head3 on_confirm my @handlers = $app->on_confirm; $app->on_confirm(@handlers); Confirm events are triggered when the App::Info subclass has found an important piece of information (such as the location of the executable it'll use to collect information for the rest of its methods) and wants to confirm that the information is correct. These events will most often be triggered during the App::Info subclass object construction. Here, too, the App::Info::Handler::Prompt class included with the App::Info distribution can help out: use App::Info::Handler::Prompt; my $app->on_confirm('prompt'); # Or: my $prompter = App::Info::Handler::Prompt; $app->on_confirm($prompter); =cut sub on_confirm { my $self = shift; @{ $self->{on_confirm} } = $set_handlers->(\@_) if @_; return @{ $self->{on_confirm} }; } ############################################################################## ############################################################################## =head1 SUBCLASSING As an abstract base class, App::Info is not intended to be used directly. Instead, you'll use concrete subclasses that implement the interface it defines. These subclasses each provide the meta data necessary for a given software package, via the interface outlined above (plus any additional methods the class author deems sensible for a given application). This section describes the facilities App::Info provides for subclassing. The goal of the App::Info design has been to make subclassing straight-forward, so that developers can focus on gathering the data they need for their application and minimize the work necessary to handle unknown values or to confirm values. As a result, there are essentially three concepts that developers need to understand when subclassing App::Info: organization, utility methods, and events. =head2 Organization The organizational idea behind App::Info is to name subclasses by broad software categories. This approach allows the categories themselves to function as abstract base classes that extend App::Info, so that they can specify more methods for all of their base classes to implement. For example, App::Info::HTTPD has specified the C abstract method that its subclasses must implement. So as you get ready to implement your own subclass, think about what category of software you're gathering information about. New categories can be added as necessary. =head2 Utility Methods Once you've decided on the proper category, you can start implementing your App::Info concrete subclass. As you do so, take advantage of App::Info::Util, wherein I've tried to encapsulate common functionality to make subclassing easier. I found that most of what I was doing repetitively was looking for files and directories, and searching through files. Thus, App::Info::Util subclasses L in order to offer easy access to commonly-used methods from that class, e.g., C. Plus, it has several of its own methods to assist you in finding files and directories in lists of files and directories, as well as methods for searching through files and returning the values found in those files. See L for more information, and the App::Info subclasses in this distribution for usage examples. I recommend the use of a package-scoped lexical App::Info::Util object. That way it's nice and handy when you need to carry out common tasks. If you find you're doing something over and over that's not already addressed by an App::Info::Util method, consider submitting a patch to App::Info::Util to add the functionality you need. =head2 Events Use the methods described below to trigger events. Events are designed to provide a simple way for App::Info subclass developers to send status messages and errors, to confirm data values, and to request a value when the class cannot determine a value itself. Events may optionally be handled by module users who assign App::Info::Handler subclass objects to your App::Info subclass object using the event handling methods described in the L<"Event Handler Object Methods"> section. =cut ############################################################################## # This code reference is used by the event methods to manage the stack of # event handlers that may be available to handle each of the events. my $handler = sub { my ($self, $meth, $params) = @_; # Sanity check. We really want to keep control over this. Carp::croak("Cannot call protected method $meth()") unless UNIVERSAL::isa($self, scalar caller(1)); # Create the request object. $params->{type} ||= $meth; my $req = App::Info::Request->new(%$params); # Do the deed. The ultimate handling handler may die. foreach my $eh (@{$self->{"on_$meth"}}) { last if $eh->handler($req); } # Return the request. return $req; }; ############################################################################## =head3 info $self->info(@message); Use this method to display status messages for the user. You may wish to use it to inform users that you're searching for a particular file, or attempting to parse a file or some other resource for the data you need. For example, a common use might be in the object constructor: generally, when an App::Info object is created, some important initial piece of information is being sought, such as an executable file. That file may be in one of many locations, so it makes sense to let the user know that you're looking for it: $self->info("Searching for executable"); Note that, due to the nature of App::Info event handlers, your informational message may be used or displayed any number of ways, or indeed not at all (as is the default behavior). The C<@message> will be joined into a single string and stored in the C attribute of the App::Info::Request object passed to info event handlers. =cut sub info { my $self = shift; # Execute the handler sequence. my $req = $handler->($self, 'info', { message => join '', @_ }); } ############################################################################## =head3 error $self->error(@error); Use this method to inform the user that something unexpected has happened. An example might be when you invoke another program to parse its output, but it's output isn't what you expected: $self->error("Unable to parse version from `/bin/myapp -c`"); As with all events, keep in mind that error events may be handled in any number of ways, or not at all. The C<@erorr> will be joined into a single string and stored in the C attribute of the App::Info::Request object passed to error event handlers. If that seems confusing, think of it as an "error message" rather than an "error error." :-) =cut sub error { my $self = shift; # Execute the handler sequence. my $req = $handler->($self, 'error', { message => join '', @_ }); } ############################################################################## =head3 unknown my $val = $self->unknown(@params); Use this method when a value is unknown. This will give the user the option -- assuming the appropriate handler handles the event -- to provide the needed data. The value entered will be returned by C. The parameters are as follows: =over 4 =item key The C parameter uniquely identifies the data point in your class, and is used by App::Info to ensure that an unknown event is handled only once, no matter how many times the method is called. The same value will be returned by subsequent calls to C as was returned by the first call, and no handlers will be activated. Typical values are "version" and "lib_dir". =item prompt The C parameter is the prompt to be displayed should an event handler decide to prompt for the appropriate value. Such a prompt might be something like "Path to your httpd executable?". If this parameter is not provided, App::Info will construct one for you using your class' C method and the C parameter. The result would be something like "Enter a valid FooApp version". The C parameter value will be stored in the C attribute of the App::Info::Request object passed to event handlers. =item callback Assuming a handler has collected a value for your unknown data point, it might make sense to validate the value. For example, if you prompt the user for a directory location, and the user enters one, it makes sense to ensure that the directory actually exists. The C parameter allows you to do this. It is a code reference that takes the new value or values as its arguments, and returns true if the value is valid, and false if it is not. For the sake of convenience, the first argument to the callback code reference is also stored in C<$_> .This makes it easy to validate using functions or operators that, er, operate on C<$_> by default, but still allows you to get more information from C<@_> if necessary. For the directory example, a good callback might be C. The C parameter code reference will be stored in the C attribute of the App::Info::Request object passed to event handlers. =item error The error parameter is the error message to display in the event that the C code reference returns false. This message may then be used by the event handler to let the user know what went wrong with the data she entered. For example, if the unknown value was a directory, and the user entered a value that the C identified as invalid, a message to display might be something like "Invalid directory path". Note that if the C parameter is not provided, App::Info will supply the generic error message "Invalid value". This value will be stored in the C attribute of the App::Info::Request object passed to event handlers. =back This may be the event method you use most, as it should be called in every meta data 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 = $params{key} or Carp::croak("No key parameter passed to unknown()"); # Just return the value if we've already handled this value. Ideally this # shouldn't happen. return $self->{__unknown__}{$key} if exists $self->{__unknown__}{$key}; # Create a prompt and error message, if necessary. $params{message} = delete $params{prompt} || "Enter a valid " . $self->key_name . " $key"; $params{error} ||= 'Invalid value'; # Execute the handler sequence. my $req = $handler->($self, "unknown", \%params); # Mark that we've provided this value and then return it. $self->{__unknown__}{$key} = $req->value; return $self->{__unknown__}{$key}; } ############################################################################## =head3 confirm my $val = $self->confirm(@params); This method is very similar to C, but serves a different purpose. Use this method for significant data points where you've found an appropriate value, but want to ensure it's really the correct value. A "significant data point" is usually a value essential for your class to collect meta data 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 meta data methods and can assume that they'll be right because that first, significant data point has been confirmed. Other than where and how often to call C, its use is quite similar to that of C. Its parameters are as follows: =over =item key Same as for C, a string that uniquely identifies the data point in your class, and ensures that the event is handled only once for a given key. The same value will be returned by subsequent calls to C as was returned by the first call for a given key. =item prompt Same as for C. Although C is called to confirm a value, typically the prompt should request the relevant value, just as for C. The difference is that the handler I use the C parameter as the default should the user not provide a value. The C parameter will be stored in the C attribute of the App::Info::Request object passed to event handlers. =item value The value to be confirmed. This is the value you've found, and it will be provided to the user as the default option when they're prompted for a new value. This value will be stored in the C attribute of the App::Info::Request object passed to event handlers. =item callback Same as for C. Because the user can enter data to replace the default value provided via the C parameter, you might want to validate it. Use this code reference to do so. The callback will be stored in the C attribute of the App::Info::Request object passed to event handlers. =item error Same as for C: an error message to display in the event that a value entered by the user isn't validated by the C code reference. This value will be stored in the C attribute of the App::Info::Request object passed to event handlers. =back Here's an example usage demonstrating all of the above arguments: my $exe = $self->confirm( key => 'shell', prompt => 'Path to your shell?', value => '/bin/sh', callback => sub { -x }, error => 'Not an executable'); =cut sub confirm { my ($self, %params) = @_; my $key = $params{key} or Carp::croak("No key parameter passed to confirm()"); return $self->{__confirm__}{$key} if exists $self->{__confirm__}{$key}; # Create a prompt and error message, if necessary. $params{message} = delete $params{prompt} || "Enter a valid " . $self->key_name . " $key"; $params{error} ||= 'Invalid value'; # Execute the handler sequence. my $req = $handler->($self, "confirm", \%params); # Mark that we've confirmed this value. $self->{__confirm__}{$key} = $req->value; return $self->{__confirm__}{$key} } 1; __END__ =head2 Event Examples Below I provide some examples demonstrating the use of the event methods. These are meant to emphasize the contexts in which it's appropriate to use them. Let's start with the simplest, first. Let's say that to find the version number for an application, you need to search a file for the relevant data. Your App::Info concrete subclass might have a private method that handles this work, and this method is the appropriate place to use the C and, if necessary, C methods. sub _find_version { my $self = shift; # Try to find the revelant file. We cover this method below. # Just return if we cant' find it. my $file = $self->_find_file('version.conf') or return; # Send a status message. $self->info("Searching '$file' file for version"); # Search the file. $util is an App::Info::Util object. my $ver = $util->search_file($file, qr/^Version\s+(.*)$/); # Trigger an error message, if necessary. We really think we'll have the # value, but we have to cover our butts in the unlikely event that we're # wrong. $self->error("Unable to find version in file '$file'") unless $ver; # Return the version number. return $ver; } Here we've used the C method to display a status message to let the user know what we're doing. Then we used the C method when something unexpected happened, which in this case was that we weren't able to find the version number in the file. Note the C<_find_file()> method we've thrown in. This might be a method that we call whenever we need to find a file that might be in one of a list of directories. This method, too, will be an appropriate place for an C method call. But rather than call the C method when the file can't be found, you might want to give an event handler a chance to supply that value for you. Use the C method for a case such as this: sub _find_file { my ($self, $file) = @_; # Send a status message. $self->info("Searching for '$file' file"); # Look for the file. See App::Info:Utility for its interface. my @paths = qw(/usr/conf /etc/conf /foo/conf); my $found = $util->first_cat_path($file, @paths); # If we didn't find it, trigger an unknown event to # give a handler a chance to get the value. $found ||= $self->unknown( key => "file_$file", prompt => "Location of '$file' file?", callback => sub { -f }, error => "Not a file"); # Now return the file name, regardless of whether we found it or not. return $found; } Note how in this method, we've tried to locate the file ourselves, but if we can't find it, we trigger an unknown event. This allows clients of our App::Info subclass to try to establish the value themselves by having an App::Info::Handler subclass handle the event. If a value is found by an App::Info::Handler subclass, it will be returned by C and we can continue. But we can't assume that the unknown event will even be handled, and thus must expect that an unknown value may remain unknown. This is why the C<_find_version()> method above simply returns if C<_find_file()> doesn't return a file name; there's no point in searching through a file that doesn't exist. Attentive readers may be left to wonder how to decide when to use C and when to use C. To a large extent, this decision must be based on one's own understanding of what's most appropriate. Nevertheless, I offer the following simple guidelines: Use C when you expect something to work and then it just doesn't (as when a file exists and should contain the information you seek, but then doesn't). Use C when you're less sure of your processes for finding the value, and also for any of the values that should be returned by any of the L. And of course, C would be more appropriate when you encounter an unexpected condition and don't think that it could be handled in any other way. Now, more than likely, a method such C<_find_version()> would be called by the C method, which is a meta data 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 meta data methods should make use of the C method. The C method then should look something like this: sub version { my $self = shift; unless (exists $self->{version}) { # Try to find the version number. $self->{version} = $self->_find_version || $self->unknown( key => 'version', prompt => "Enter the version number"); } # Now return the version number. return $self->{version}; } Note how this method only tries to find the version number once. Any subsequent calls to C will return the same value that was returned the first time it was called. Of course, thanks to the C parameter in the call to C, we could have have tried to enumerate the version number every time, as C will return the same value every time it is called (as, indeed, should C<_find_version()>. But by checking for the C key in C<$self> ourselves, we save some of the overhead. But as I said before, every meta data method should make use of the C method. Thus, the C method might looks something like this: sub major { my $self = shift; unless (exists $self->{major}) { # Try to get the major version from the full version number. ($self->{major}) = $self->version =~ /^(\d+)\./; # Handle an unknown value. $self->{major} = $self->unknown( key => 'major', prompt => "Enter major version", callback => sub { /^\d+$/ }, error => "Not a number") unless defined $self->{major}; } return $self->{version}; } Finally, the C method should be used to verify core pieces of data that significant numbers of other methods rely on. Typically such data are executables or configuration files from which will be drawn other meta data. Most often, such major data points will be sought in the object constructor. Here's an example: sub new { # Construct the object so that handlers will work properly. my $self = shift->SUPER::new(@_); # Try to find the executable. $self->info("Searching for executable"); if (my $exe = $util->first_exe('/bin/myapp', '/usr/bin/myapp')) { # Confirm it. $self->{exe} = $self->confirm( key => 'binary', prompt => 'Path to your executable?', value => $exe, callback => sub { -x }, error => 'Not an executable'); } else { # Handle an unknown value. $self->{exe} = $self->unknown( key => 'binary', prompt => 'Path to your executable?', callback => sub { -x }, error => 'Not an executable'); } # We're done. return $self; } By now, most of what's going on here should be quite familiar. The use of the C method is quite similar to that of C. Really the only difference is that the value is known, but we need verification or a new value supplied if the value we found isn't correct. Such may be the case when multiple copies of the executable have been installed on the system, we found F, but the user may really be interested in F. Thus the C event gives the user the chance to change the value if the confirm event is handled. The final thing to note about this constructor is the first line: my $self = shift->SUPER::new(@_); The first thing an App::Info subclass should do is execute this line to allow the super class to construct the object first. Doing so allows any event handling arguments to set up the event handlers, so that when we call C or C the event will be handled as the client expects. If we needed our subclass constructor to take its own parameter argument, the approach is to specify the same C $arg> syntax as is used by App::Info's C method. Say we wanted to allow clients of our App::Info subclass to pass in a list of alternate executable locations for us to search. Such an argument would most make sense as an array reference. So we specify that the key be C and allow the user to construct an object like this: my $app = App::Info::Category::FooApp->new( alt_paths => \@paths ); This approach allows the super class constructor arguments to pass unmolested (as long as we use unique keys!): my $app = App::Info::Category::FooApp->new( on_error => \@handlers, alt_paths => \@paths ); Then, to retrieve these paths inside our C constructor, all we need do is access them directly from the object: my $self = shift->SUPER::new(@_); my $alt_paths = $self->{alt_paths}; =head2 Subclassing Guidelines To summarize, here are some guidelines for subclassing App::Info. =over 4 =item * Always subclass an App::Info category subclass. This will help to keep the App::Info name space well-organized. New categories can be added as needed. =item * When you create the C constructor, always call C. This ensures that the event handling methods methods defined by the App::Info base classes (e.g., C) will work properly. =item * Use a package-scoped lexical App::Info::Util object to carry out common tasks. If you find you're doing something over and over that's not already addressed by an App::Info::Util method, and you think that others might find your solution useful, consider submitting a patch to App::Info::Util to add the functionality you need. See L for complete documentation of its interface. =item * Use the C event triggering method to send messages to users of your subclass. =item * Use the C event triggering method to alert users of unexpected conditions. Fatal errors should still be fatal; use C to throw exceptions for fatal errors. =item * Use the C event triggering method when a meta data or other important value is unknown and you want to give any event handlers the chance to provide the data. =item * Use the C event triggering method when a core piece of data is known (such as the location of an executable in the C constructor) and you need to make sure that you have the I information. =item * Be sure to implement B of the abstract methods defined by App::Info and by your category abstract base class -- even if they don't do anything. Doing so ensures that all App::Info subclasses share a common interface, and can, if necessary, be used without regard to subclass. Any method not implemented but called on an object will generate a fatal exception. =back Otherwise, have fun! There are a lot of software packages for which relevant information might be collected and aggregated into an App::Info concrete subclass (witness all of the Automake macros in the world!), and folks who are knowledgeable about particular software packages or categories of software are warmly invited to contribute. As more subclasses are implemented, it will make sense, I think, to create separate distributions based on category -- or even, when necessary, on a single software package. Broader categories can then be aggregated in Bundle distributions. But I get ahead of myself... =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO The following classes define a few software package categories in which App::Info subclasses can be placed. Check them out for ideas on how to create new category subclasses. =over 4 =item L =item L =item L =back The following classes implement the App::Info interface for various software packages. Check them out for examples of how to implement new App::Info concrete subclasses. =over =item L =item L =item L =item L =back L provides utility methods for App::Info subclasses. L defines an interface for event handlers to subclass. Consult its documentation for information on creating custom event handlers. The following classes implement the App::Info::Handler interface to offer some simple event handling. Check them out for examples of how to implement new App::Info::Handler subclasses. =over 4 =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-3.20.2/t/lib/App/Info/0000755000175000017500000000000015175422003013610 5ustar greggregDBD-Pg-3.20.2/t/lib/App/Info/Handler.pm0000644000175000017500000002510715157052770015542 0ustar greggregpackage App::Info::Handler; =head1 NAME App::Info::Handler - App::Info event handler base class =head1 SYNOPSIS use App::Info::Category::FooApp; use App::Info::Handler; my $app = App::Info::Category::FooApp->new( on_info => ['default'] ); =head1 DESCRIPTION This class defines the interface for subclasses that wish to handle events triggered by App::Info concrete subclasses. The different types of events triggered by App::Info can all be handled by App::Info::Handler (indeed, by default they're all handled by a single App::Info::Handler object), and App::Info::Handler subclasses may be designed to handle whatever events they wish. If you're interested in I an App::Info event handler, this is probably not the class you should look at, since all it does is define a simple handler that does nothing with an event. Look to the L included in this distribution to do more interesting things with App::Info events. If, on the other hand, you're interested in implementing your own event handlers, read on! =cut use strict; our $VERSION = '0.57'; 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-sensitive, and should be unique across App::Info::Handler subclasses so that many subclasses can be loaded and used separately. If the C<$key> is already registered, C will throw an exception. The values are code references that, when executed, return the appropriate App::Info::Handler subclass object. =cut sub register_handler { my ($pkg, $key, $code) = @_; Carp::croak("Handler '$key' already exists") if $handlers{$key}; $handlers{$key} = $code; } # Register ourself. __PACKAGE__->register_handler('default', sub { __PACKAGE__->new } ); ############################################################################## =head2 Constructor =head3 new my $handler = App::Info::Handler->new; $handler = App::Info::Handler->new( key => $key); Constructs an App::Info::Handler object and returns it. If the key parameter is provided and has been registered by an App::Info::Handler subclass via the C class method, then the relevant code reference will be executed and the resulting App::Info::Handler subclass object returned. This approach provides a handy shortcut for having C behave as an abstract factory method, returning an object of the subclass appropriate to the key parameter. =cut sub new { my ($pkg, %p) = @_; my $class = ref $pkg || $pkg; $p{key} ||= 'default'; if ($class eq __PACKAGE__ && $p{key} ne 'default') { # We were called directly! Handle it. Carp::croak("No such handler '$p{key}'") unless $handlers{$p{key}}; return $handlers{$p{key}}->(); } else { # A subclass called us -- just instantiate and return. return bless \%p, $class; } } =head2 Instance Method =head3 handler $handler->handler($req); App::Info::Handler defines a single instance method that must be defined by its subclasses, C. This is the method that will be executed by an event triggered by an App::Info concrete subclass. It takes as its single argument an App::Info::Request object, and returns a true value if it has handled the event request. Returning a false value declines the request, and App::Info will then move on to the next handler in the chain. The C method implemented in App::Info::Handler itself does nothing more than return a true value. It thus acts as a very simple default event handler. See the App::Info::Handler subclasses for more interesting handling of events, or create your own! =cut sub handler { 1 } 1; __END__ =head1 SUBCLASSING I hatched the idea of the App::Info event model with its subclassable handlers as a way of separating the aggregation of application meta data from writing a user interface for handling certain conditions. I felt it a better idea to allow people to create their own user interfaces, and instead to provide only a few examples. The App::Info::Handler class defines the API interface for handling these conditions, which App::Info refers to as "events". There are various types of events defined by App::Info ("info", "error", "unknown", and "confirm"), but the App::Info::Handler interface is designed to be flexible enough to handle any and all of them. If you're interested in creating your own App::Info event handler, this is the place to learn how. =head2 The Interface To create an App::Info event handler, all one need do is subclass App::Info::Handler and then implement the C constructor and the C method. The C constructor can do anything you like, and take any arguments you like. However, I do recommend that the first thing you do in your implementation is to call the super constructor: sub new { my $pkg = shift; my $self = $pkg->SUPER::new(@_); # ... other stuff. return $self; } Although the default C constructor currently doesn't do much, that may change in the future, so this call will keep you covered. What it does do is take the parameterized arguments and assign them to the App::Info::Handler object. Thus if you've specified a "mode" argument, where clients can construct objects of you class like this: my $handler = FooHandler->new( mode => 'foo' ); You can access the mode parameter directly from the object, like so: sub new { my $pkg = shift; my $self = $pkg->SUPER::new(@_); if ($self->{mode} eq 'foo') { # ... } return $self; } Just be sure not to use a parameter key name required by App::Info::Handler itself. At the moment, the only parameter accepted by App::Info::Handler is "key", so in general you'll be pretty safe. Next, I recommend that you take advantage of the C method to create some shortcuts for creating handlers of your class. For example, say we're creating a handler subclass FooHandler. It has two modes, a default "foo" mode and an advanced "bar" mode. To allow both to be constructed by stringified shortcuts, the FooHandler class implementation might start like this: package FooHandler; use strict; use App::Info::Handler; our @ISA = qw(App::Info::Handler); foreach my $c (qw(foo bar)) { App::Info::Handler->register_handler ( $c => sub { __PACKAGE__->new( mode => $c) } ); } The strings "foo" and "bar" can then be used by clients as shortcuts to have App::Info objects automatically create and use handlers for certain events. For example, if a client wanted to use a "bar" event handler for its info events, it might do this: use App::Info::Category::FooApp; use FooHandler; my $app = App::Info::Category::FooApp->new(on_info => ['bar']); Take a look at App::Info::Handler::Print and App::Info::Handler::Carp to see concrete examples of C usage. The final step in creating a new App::Info event handler is to implement the C method itself. This method takes a single argument, an App::Info::Request object, and is expected to return true if it handled the request, and false if it did not. The App::Info::Request object contains all the meta data relevant to a request, including the type of event that triggered it; see L for its documentation. Use the App::Info::Request object however you like to handle the request however you like. You are, however, expected to abide by a a few guidelines: =over 4 =item * For error and info events, you are expected (but not required) to somehow display the info or error message for the user. How your handler chooses to do so is up to you and the handler. =item * For unknown and confirm events, you are expected to prompt the user for a value. If it's a confirm event, offer the known value (found in C<< $req->value >>) as a default. =item * For unknown and confirm events, you are expected to call C<< $req->callback >> and pass in the new value. If C<< $req->callback >> returns a false value, you are expected to display the error message in C<< $req->error >> and prompt the user again. Note that C<< $req->value >> calls C<< $req->callback >> internally, and thus assigns the value and returns true if C<< $req->callback >> returns true, and does not assign the value and returns false if C<< $req->callback >> returns false. =item * For unknown and confirm events, if you've collected a new value and C<< $req->callback >> returns true for that value, you are expected to assign the value by passing it to C<< $req->value >>. This allows App::Info to give the value back to the calling App::Info concrete subclass. =back Probably the easiest way to get started creating new App::Info event handlers is to check out the simple handlers provided with the distribution and follow their logical examples. Consult the App::Info documentation of the L for details on how App::Info constructs the App::Info::Request object for each event type. =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO L thoroughly documents the client interface for setting event handlers, as well as the event triggering interface for App::Info concrete subclasses. L documents the interface for the request objects passed to App::Info::Handler C methods. The following App::Info::Handler subclasses offer examples for event handler authors, and, of course, provide actual event handling functionality for App::Info clients. =over 4 =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-3.20.2/t/lib/App/Info/Handler/0000755000175000017500000000000015175422003015165 5ustar greggregDBD-Pg-3.20.2/t/lib/App/Info/Handler/Print.pm0000644000175000017500000001140315157052770016630 0ustar greggregpackage App::Info::Handler::Print; =head1 NAME App::Info::Handler::Print - Print App::Info event messages =head1 SYNOPSIS use App::Info::Category::FooApp; use App::Info::Handler::Print; my $stdout = App::Info::Handler::Print->new( fh => 'stdout' ); my $app = App::Info::Category::FooApp->new( on_info => $stdout ); # Or... my $app = App::Info::Category::FooApp->new( on_error => 'stderr' ); =head1 DESCRIPTION App::Info::Handler::Print objects handle App::Info events by printing their messages to a filehandle. This means that if you want event messages to print to a file or to a system filehandle, you can easily do it with this class. You'll find, however, that App::Info::Handler::Print is most effective for info and error events; unknown and prompt events are better handled by event handlers that know how to prompt users for data. See L for an example of that functionality. Upon loading, App::Info::Handler::Print registers itself with App::Info::Handler, setting up a couple of strings that can be passed to an App::Info concrete subclass constructor. These strings are shortcuts that tell App::Info how to create the proper App::Info::Handler::Print object for handling events. The registered strings are: =over 4 =item stdout Prints event messages to C. =item stderr Prints event messages to C. =back See the C constructor below for how to have App::Info::Handler::Print print event messages to different filehandle. =cut use strict; use App::Info::Handler; our $VERSION = '0.57'; our @ISA = qw(App::Info::Handler); # Register ourselves. for my $c (qw(stderr stdout)) { App::Info::Handler->register_handler ($c => sub { __PACKAGE__->new( fh => $c ) } ); } =head1 INTERFACE =head2 Constructor =head3 new my $stderr_handler = App::Info::Handler::Print->new; $stderr_handler = App::Info::Handler::Print->new( fh => 'stderr' ); my $stdout_handler = App::Info::Handler::Print->new( fh => 'stdout' ); my $fh = FileHandle->new($file); my $fh_handler = App::Info::Handler::Print->new( fh => $fh ); Constructs a new App::Info::Handler::Print and returns it. It can take a single parameterized argument, C, which can be any one of the following values: =over 4 =item stderr Constructs a App::Info::Handler::Print object that prints App::Info event messages to C. =item stdout Constructs a App::Info::Handler::Print object that prints App::Info event messages to C. =item FileHandle =item GLOB Pass in a reference and App::Info::Handler::Print will assume that it's a filehandle reference that it can print to. Note that passing in something that can't be printed to will trigger an exception when App::Info::Handler::Print tries to print to it. =back If the C parameter is not passed, C will default to creating an App::Info::Handler::Print object that prints App::Info event messages to C. =cut sub new { my $pkg = shift; my $self = $pkg->SUPER::new(@_); if (!defined $self->{fh} || $self->{fh} eq 'stderr') { # Create a reference to STDERR. $self->{fh} = \*STDERR; } elsif ($self->{fh} eq 'stdout') { # Create a reference to STDOUT. $self->{fh} = \*STDOUT; } elsif (!ref $self->{fh}) { # Assume a reference to a filehandle or else it's invalid. Carp::croak("Invalid argument to new(): '$self->{fh}'"); } # We're done! return $self; } ############################################################################## =head3 handler This method is called by App::Info to print out the message from events. =cut sub handler { my ($self, $req) = @_; print {$self->{fh}} $req->message, "\n"; # Return true to indicate that we've handled the request. return 1; } 1; __END__ =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO L documents the event handling interface. L handles events by passing their messages Carp module functions. L offers event handling more appropriate for unknown and confirm events. L describes how to implement custom App::Info event handlers. =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-3.20.2/t/lib/App/Info/Handler/Prompt.pm0000644000175000017500000001142515157052770017021 0ustar greggregpackage App::Info::Handler::Prompt; =head1 NAME App::Info::Handler::Prompt - Prompting App::Info event handler =head1 SYNOPSIS use App::Info::Category::FooApp; use App::Info::Handler::Print; my $prompter = App::Info::Handler::Print->new; my $app = App::Info::Category::FooApp->new( on_unknown => $prompter ); # Or... my $app = App::Info::Category::FooApp->new( on_confirm => 'prompt' ); =head1 DESCRIPTION App::Info::Handler::Prompt objects handle App::Info events by printing their messages to C and then accepting a new value from C. The new value is validated by any callback supplied by the App::Info concrete subclass that triggered the event. If the value is valid, App::Info::Handler::Prompt assigns the new value to the event request. If it isn't it prints the error message associated with the event request, and then prompts for the data again. Although designed with unknown and confirm events in mind, App::Info::Handler::Prompt handles info and error events as well. It will simply print info event messages to C and print error event messages to C. For more interesting info and error event handling, see L and L. Upon loading, App::Info::Handler::Print registers itself with App::Info::Handler, setting up a single string, "prompt", that can be passed to an App::Info concrete subclass constructor. This string is a shortcut that tells App::Info how to create an App::Info::Handler::Print object for handling events. =cut use strict; use App::Info::Handler; our $VERSION = '0.57'; our @ISA = qw(App::Info::Handler); # Register ourselves. App::Info::Handler->register_handler ('prompt' => sub { __PACKAGE__->new } ); =head1 INTERFACE =head2 Constructor =head3 new my $prompter = App::Info::Handler::Prompt->new; Constructs a new App::Info::Handler::Prompt object and returns it. No special arguments are required. =cut sub new { my $pkg = shift; my $self = $pkg->SUPER::new(@_); $self->{tty} = -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) ); # We're done! return $self; } my $get_ans = sub { my ($prompt, $tty, $def) = @_; # Print the message. local $| = 1; local $\; print $prompt; # Collect the answer. my $ans; if ($tty) { $ans = ; if (defined $ans ) { chomp $ans; } else { # user hit ctrl-D print "\n"; } } else { print "$def\n" if defined $def; } return $ans; }; sub handler { my ($self, $req) = @_; my $ans; my $type = $req->type; if ($type eq 'unknown' || $type eq 'confirm') { # We'll want to prompt for a new value. my $val = $req->value; my ($def, $dispdef) = defined $val ? ($val, " [$val] ") : ('', ' '); my $msg = $req->message or Carp::croak("No message in request"); $msg .= $dispdef; # Get the answer. $ans = $get_ans->($msg, $self->{tty}, $def); # Just return if they entered an empty string or we couldnt' get an # answer. return 1 unless defined $ans && $ans ne ''; # Validate the answer. my $err = $req->error; while (!$req->value($ans)) { print "$err: '$ans'\n"; $ans = $get_ans->($msg, $self->{tty}, $def); return 1 unless defined $ans && $ans ne ''; } } elsif ($type eq 'info') { # Just print the message. print STDOUT $req->message, "\n"; } elsif ($type eq 'error') { # Just print the message. print STDERR $req->message, "\n"; } else { # This shouldn't happen. Carp::croak("Invalid request type '$type'"); } # Return true to indicate that we've handled the request. return 1; } 1; __END__ =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO L documents the event handling interface. L handles events by passing their messages Carp module functions. L handles events by printing their messages to a file handle. L describes how to implement custom App::Info event handlers. =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-3.20.2/t/lib/App/Info/Util.pm0000644000175000017500000004007615157052770015104 0ustar greggregpackage App::Info::Util; =head1 NAME App::Info::Util - Utility class for App::Info subclasses =head1 SYNOPSIS use App::Info::Util; my $util = App::Info::Util->new; # Subclasses File::Spec. my @paths = $util->paths; # First directory that exists in a list. my $dir = $util->first_dir(@paths); # First directory that exists in a path. $dir = $util->first_path($ENV{PATH}); # First file that exists in a list. my $file = $util->first_file('this.txt', '/that.txt', 'C:\\foo.txt'); # First file found among file base names and directories. my $files = ['this.txt', 'that.txt']; $file = $util->first_cat_file($files, @paths); =head1 DESCRIPTION This class subclasses L and adds its own methods in order to offer utility methods to L classes. Although intended to be used by App::Info subclasses, in truth App::Info::Util's utility may be considered more general, so feel free to use it elsewhere. The methods added in addition to the usual File::Spec suspects are designed to facilitate locating files and directories on the file system, as well as searching those files. The assumption is that, in order to provide useful meta data 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; our @ISA = qw(File::Spec); our $VERSION = '0.57'; my %path_dems = ( MacOS => qr',', MSWin32 => qr';', os2 => qr';', VMS => undef, epoc => undef ); my $path_dem = exists $path_dems{$^O} ? $path_dems{$^O} : qr':'; =head1 CONSTRUCTOR =head2 new my $util = App::Info::Util->new; This is a very simple constructor that merely returns an App::Info::Util object. Since, like its File::Spec super class, App::Info::Util manages no internal data itself, all methods may be used as class methods, if one prefers to. The constructor here is provided merely as a convenience. =cut sub new { bless {}, ref $_[0] || $_[0] } ############################################################################## =head1 OBJECT METHODS In addition to all of the methods offered by its super class, L, App::Info::Util offers the following methods. =head2 first_dir my @paths = $util->paths; my $dir = $util->first_dir(@dirs); Returns the first file system directory in @paths that exists on the local file system. Only the first item in @paths that exists as a directory will be returned; any other paths leading to non-directories will be ignored. =cut sub first_dir { shift; foreach (@_) { return $_ if -d } return; } ############################################################################## =head2 first_path my $path = $ENV{PATH}; $dir = $util->first_path($path); Takes the $path string and splits it into a list of directory paths, based on the path delimiter on the local file system. Then calls C to return the first directory in the path list that exists on the local file system. The path delimiter is specified for the following file systems: =over 4 =item * MacOS: "," =item * MSWin32: ";" =item * os2: ";" =item * VMS: undef This method always returns undef on VMS. Patches welcome. =item * epoc: undef This method always returns undef on epoch. Patches welcome. =item * Unix: ":" All other operating systems are assumed to be Unix-based. =back =cut sub first_path { return unless $path_dem; shift->first_dir(split /$path_dem/, shift) } ############################################################################## =head2 first_file my $file = $util->first_file(@filelist); Examines each of the files in @filelist and returns the first one that exists on the file system. The file must be a regular file -- directories will be ignored. =cut sub first_file { shift; foreach (@_) { return $_ if -f } return; } ############################################################################## =head2 first_exe my $exe = $util->first_exe(@exelist); Examines each of the files in @exelist and returns the first one that exists on the file system as an executable file. Directories will be ignored. =cut sub first_exe { shift; foreach (@_) { return $_ if -f && -x } return; } ############################################################################## =head2 first_cat_path my $file = $util->first_cat_path('ick.txt', @paths); $file = $util->first_cat_path(['this.txt', 'that.txt'], @paths); The first argument to this method may be either a file or directory base name (that is, a file or directory name without a full path specification), or a reference to an array of file or directory base names. The remaining arguments constitute a list of directory paths. C processes each of these directory paths, concatenates (by the method native to the local operating system) each of the file or directory base names, and returns the first one that exists on the file system. For example, let us say that we were looking for a file called either F or F, and it could be in any of the following paths: F, F, F. The method call looks like this: my $httpd = $util->first_cat_path(['httpd', 'apache'], '/usr/local/bin', '/usr/bin/', '/bin'); If the OS is a Unix variant, C will then look for the first file that exists in this order: =over 4 =item /usr/local/bin/httpd =item /usr/local/bin/apache =item /usr/bin/httpd =item /usr/bin/apache =item /bin/httpd =item /bin/apache =back The first of these complete paths to be found will be returned. If none are found, then undef will be returned. =cut sub first_cat_path { my $self = shift; my $files = ref $_[0] ? shift() : [shift()]; foreach my $p (@_) { foreach my $f (@$files) { my $path = $self->catfile($p, $f); return $path if -e $path; } } return; } ############################################################################## =head2 first_cat_dir my $dir = $util->first_cat_dir('ick.txt', @paths); $dir = $util->first_cat_dir(['this.txt', 'that.txt'], @paths); Functionally identical to C, except that it returns the directory path in which the first file was found, rather than the full concatenated path. Thus, in the above example, if the file found was F, while C would return that value, C would return F instead. =cut sub first_cat_dir { my $self = shift; my $files = ref $_[0] ? shift() : [shift()]; foreach my $p (@_) { foreach my $f (@$files) { my $path = $self->catfile($p, $f); return $p if -e $path; } } return; } ############################################################################## =head2 first_cat_exe my $exe = $util->first_cat_exe('ick.exe', @paths); $exe = $util->first_cat_exe(['this.exe', 'that.exe'], @paths); Functionally identical to C, except that it returns the full path to the first executable file found, rather than simply the first file found. =cut sub first_cat_exe { my $self = shift; my $files = ref $_[0] ? shift() : [shift()]; foreach my $p (@_) { foreach my $f (@$files) { my $path = $self->catfile($p, $f); return $path if -f $path && -x $path; } } return; } ############################################################################## =head2 search_file my $file = 'foo.txt'; my $regex = qr/(text\s+to\s+find)/; my $value = $util->search_file($file, $regex); Opens C<$file> and executes the C<$regex> regular expression against each line in the file. Once the line matches and one or more values is returned by the match, the file is closed and the value or values returned. For example, say F contains the line "Version 6.5, patch level 8", and you need to grab each of the three version parts. All three parts can be grabbed like this: my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/; my @nums = $util->search_file($file, $regex); Now C<@nums> will contain the values C<(6, 5, 8)>. Note that in a scalar context, the above search would yield an array reference: my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/; my $nums = $util->search_file($file, $regex); So now C<$nums> contains C<[6, 5, 8]>. The same does not hold true if the match returns only one value, however. Say F contains the line "king of the who?", and you wish to know who the king is king of. Either of the following two calls would get you the data you need: my $minions = $util->search_file($file, qr/King\s+of\s+(.*)/); my @minions = $util->search_file($file, qr/King\s+of\s+(.*)/); In the first case, because the regular expression contains only one set of parentheses, C will simply return that value: C<$minions> contains the string "the who?". In the latter case, C<@minions> of course contains a single element: C<("the who?")>. Note that a regular expression without parentheses -- that is, one that doesn't grab values and put them into $1, $2, etc., will never successfully match a line in this method. You must include something to parenthetically match. If you just want to know the value of what was matched, parenthesize the whole thing and if the value returns, you have a match. Also, if you need to match patterns across lines, try using multiple regular expressions with C, instead. =cut sub search_file { my ($self, $file, $regex) = @_; return unless $file && $regex; open F, "<$file" or require Carp && Carp::croak("Cannot open $file: $!\n"); my @ret; while () { # If we find a match, we're done. (@ret) = /$regex/ and last; } close F; # If the match returned an more than one value, always return the full # array. Otherwise, return just the first value in a scalar context. return unless @ret; return wantarray ? @ret : $#ret <= 0 ? $ret[0] : \@ret; } ############################################################################## =head2 files_in_dir my @files = $util->files_in_dir($dir); @files = $util->files_in_dir($dir, $filter); my $files = $util->files_in_dir($dir); $files = $util->files_in_dir($dir, $filter); Returns an list or array reference of all of the files and directories in the file system directory C<$dir>. An optional second argument is a code reference that filters the files. The code reference should examine the C<$_> for a file name and return true if it's a file that you're interested and false if it's not. =cut sub files_in_dir { my ($self, $dir, $code) = @_; return unless $dir; local *DIR; opendir DIR, $dir or require Carp && Carp::croak("Cannot open $dir: $!\n"); my @files = $code ? grep { $code->() } readdir DIR : readdir DIR; closedir DIR; return wantarray ? @files : \@files; } ############################################################################## =head2 multi_search_file my @regexen = (qr/(one)/, qr/(two)\s+(three)/); my @matches = $util->multi_search_file($file, @regexen); Like C, this method opens C<$file> and parses it for regular expression 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 references, while those that match and return a single value will return just that single value. For example, say you are parsing a file with lines like the following: #define XML_MAJOR_VERSION 1 #define XML_MINOR_VERSION 95 #define XML_MICRO_VERSION 2 You need to get each of these numbers, but calling C for each of them would be wasteful, as each call to C opens the file and parses it. With C, on the other hand, the file will be opened only once, and, once all of the regular expressions have returned matches, the file will be closed and the matches returned. Thus the above values can be collected like this: my @regexen = ( qr/XML_MAJOR_VERSION\s+(\d+)$/, qr/XML_MINOR_VERSION\s+(\d+)$/, qr/XML_MICRO_VERSION\s+(\d+)$/ ); my @nums = $file->multi_search_file($file, @regexen); The result will be that C<@nums> contains C<(1, 95, 2)>. Note that C tries to do the right thing by only parsing the file until all of the regular expressions have been matched. Thus, a large file with the values you need near the top can be parsed very quickly. As with C, C can take regular expressions that match multiple values. These will be returned as array references. For example, say the file you're parsing has files like this: FooApp Version 4 Subversion 2, Microversion 6 To get all of the version numbers, you can either use three regular expressions, as in the previous example: my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/, qr/Subversion\s+(\d+),/, qr/Microversion\s+(\d$)$/ ); my @nums = $file->multi_search_file($file, @regexen); In which case C<@nums> will contain C<(4, 2, 6)>. Or, you can use just two regular expressions: my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/, qr/Subversion\s+(\d+),\s+Microversion\s+(\d$)$/ ); my @nums = $file->multi_search_file($file, @regexen); In which case C<@nums> will contain C<(4, [2, 6])>. Note that the two parentheses that return values in the second regular expression cause the matches to be returned as an array reference. =cut sub multi_search_file { my ($self, $file, @regexen) = @_; return unless $file && @regexen; my @each = @regexen; open F, "<$file" or require Carp && Carp::croak("Cannot open $file: $!\n"); my %ret; while (my $line = ) { my @splice; # Process each of the regular expresssions. for (my $i = 0; $i < @each; $i++) { if ((my @ret) = $line =~ /$each[$i]/) { # We have a match! If there's one match returned, just grab # it. If there's more than one, keep it as an array ref. $ret{$each[$i]} = $#ret > 0 ? \@ret : $ret[0]; # We got values for this regex, so not its place in the @each # array. push @splice, $i; } } # Remove any regexen that have already found a match. for (@splice) { splice @each, $_, 1 } # If there are no more regexes, we're done -- no need to keep # processing lines in the file! last unless @each; } close F; return unless %ret; return wantarray ? @ret{@regexen} : \@ret{@regexen}; } ############################################################################## =head2 lib_dirs my @dirs = $util->lib_dirs; Returns a list of possible library directories to be searched. These are gathered from the C and C Config settings. These are useful for passing to C to search typical directories for library files. =cut sub lib_dirs { grep { defined and length } map { split ' ' } grep { defined } # Quote Config access to work around # http://bugs.activestate.com/show_bug.cgi?id=89447 "$Config{libsdirs}", "$Config{loclibpth}", '/sw/lib'; } 1; __END__ =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO L, L, L L =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-3.20.2/t/lib/App/Info/RDBMS/0000755000175000017500000000000015175422003014457 5ustar greggregDBD-Pg-3.20.2/t/lib/App/Info/RDBMS/PostgreSQL.pm0000644000175000017500000006175615157052770017051 0ustar greggregpackage App::Info::RDBMS::PostgreSQL; =head1 NAME App::Info::RDBMS::PostgreSQL - Information about PostgreSQL =head1 SYNOPSIS use App::Info::RDBMS::PostgreSQL; my $pg = App::Info::RDBMS::PostgreSQL->new; if ($pg->installed) { print "App name: ", $pg->name, "\n"; print "Version: ", $pg->version, "\n"; print "Bin dir: ", $pg->bin_dir, "\n"; } else { print "PostgreSQL is not installed. :-(\n"; } =head1 DESCRIPTION App::Info::RDBMS::PostgreSQL supplies information about the PostgreSQL database server installed on the local system. It implements all of the methods defined by App::Info::RDBMS. Methods that trigger events will trigger them only the first time they're called (See L for documentation on handling events). To start over (after, say, someone has installed PostgreSQL) construct a new App::Info::RDBMS::PostgreSQL object to aggregate new meta data. Some of the methods trigger the same events. This is due to cross-calling of shared subroutines. However, any one event should be triggered no more than once. For example, although the info event "Executing `pg_config --version`" is documented for the methods C, C, C, C, and C, rest assured that it will only be triggered once, by whichever of those four methods is called first. =cut use strict; use App::Info::RDBMS; use App::Info::Util; our @ISA = qw(App::Info::RDBMS); our $VERSION = '0.57'; use constant WIN32 => $^O eq 'MSWin32'; my $u = App::Info::Util->new; my @EXES = qw(postgres createdb createlang createuser dropdb droplang dropuser initdb pg_dump pg_dumpall pg_restore postmaster vacuumdb psql); =head1 INTERFACE =head2 Constructor =head3 new my $pg = App::Info::RDBMS::PostgreSQL->new(@params); Returns an App::Info::RDBMS::PostgreSQL object. See L for a complete description of argument parameters. When it called, C searches the file system for an executable named for the list returned by C, usually F, in the list of directories returned by C. If found, F will be called by the object methods below to gather the data necessary for each. If F cannot be found, then PostgreSQL is assumed not to be installed, and each of the object methods will return C. C also takes a number of optional parameters in addition to those documented for App::Info. These parameters allow you to specify alternate names for PostgreSQL executables (other than F, which you specify via the C parameter). These parameters are: =over =item search_postgres_names =item search_createdb_names =item search_createlang_names =item search_createuser_names =item search_dropd_names =item search_droplang_names =item search_dropuser_names =item search_initdb_names =item search_pg_dump_names =item search_pg_dumpall_names =item search_pg_restore_names =item search_postmaster_names =item search_psql_names =item search_vacuumdb_names =back B =over 4 =item info Looking for pg_config =item confirm Path to pg_config? =item unknown Path to pg_config? =back =cut sub new { # Construct the object. my $self = shift->SUPER::new(@_); # Find pg_config. $self->info("Looking for pg_config"); my @paths = $self->search_bin_dirs; my @exes = $self->search_exe_names; if (my $cfg = $u->first_cat_exe(\@exes, @paths)) { # We found it. Confirm. $self->{pg_config} = $self->confirm( key => 'path to 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 => 'path to pg_config', prompt => "Path to pg_config?", callback => sub { -x }, error => 'Not an executable'); } # Set up search defaults. for my $exe (@EXES) { my $attr = "search_$exe\_names"; if (exists $self->{$attr}) { $self->{$attr} = [$self->{$attr}] unless ref $self->{$attr} eq 'ARRAY'; } else { $self->{$attr} = []; } } return $self; } # We'll use this code reference as a common way of collecting data. my $get_data = sub { return unless $_[0]->{pg_config}; $_[0]->info(qq{Executing `"$_[0]->{pg_config}" $_[1]`}); my $info = `"$_[0]->{pg_config}" $_[1]`; chomp $info; return $info; }; ############################################################################## =head2 Class Method =head3 key_name my $key_name = App::Info::RDBMS::PostgreSQL->key_name; Returns the unique key name that describes this class. The value returned is the string "PostgreSQL". =cut sub key_name { 'PostgreSQL' } ############################################################################## =head2 Object Methods =head3 installed print "PostgreSQL is ", ($pg->installed ? '' : 'not '), "installed.\n"; Returns true if PostgreSQL is installed, and false if it is not. App::Info::RDBMS::PostgreSQL determines whether PostgreSQL is installed based on the presence or absence of the F application on the file system as found when C constructed the object. If PostgreSQL does not appear to be installed, then all of the other object methods will return empty values. =cut sub installed { return $_[0]->{pg_config} ? 1 : undef } ############################################################################## =head3 name my $name = $pg->name; Returns the name of the application. App::Info::RDBMS::PostgreSQL parses the name from the system call C<`pg_config --version`>. B =over 4 =item info Executing `pg_config --version` =item error Failed to find PostgreSQL version with `pg_config --version` Unable to parse name from string Unable to parse version from string Failed to parse PostgreSQL version parts from string =item unknown Enter a valid PostgreSQL name =back =cut # This code reference is used by name(), version(), major_version(), # minor_version(), and patch_version() to aggregate the data they need. my $get_version = sub { my $self = shift; $self->{'--version'} = 1; my $data = $get_data->($self, '--version'); unless ($data) { $self->error("Failed to find PostgreSQL version with ". "`$self->{pg_config} --version`"); return; } chomp $data; my ($name, $version) = split /\s+/, $data, 2; # Check for and assign the name. $name ? $self->{name} = $name : $self->error("Unable to parse name from string '$data'"); # Parse the version number. if ($version) { my ($x, $y, $z) = $version =~ /^(\d+)\.(\d+)\.(\d+)/; if (defined $x and defined $y and defined $z) { # Pre-v10 normal releases @{$self}{qw(version major minor patch)} = ($version, $x, $y, $z); } elsif ($version =~ /^(\d)\.(\d+)/) { # < v10 # New versions, such as "7.4", are treated as patch level "0" @{$self}{qw(version major minor patch)} = ($version, $1, $2, 0); } elsif ($version =~ /^(\d{2,})\.(\d+)/) { # >= v10 @{$self}{qw(version major minor patch)} = ($version, $1, 0, $2); # from v10 onwards, $2 will be patch level } elsif ($version =~ /^(\d{2,})(devel|beta|rc|alpha)/) { # Beta/devel/release candidates are treated as minor/patch level "0" @{$self}{qw(version major minor patch)} = ($version, $1, 0, 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 => 'postgres name' ); # Return the name. return $self->{name}; } ############################################################################## =head3 version my $version = $pg->version; Returns the PostgreSQL version number. App::Info::RDBMS::PostgreSQL parses the version number from the system call C<`pg_config --version`>. B =over 4 =item info Executing `pg_config --version` =item error Failed to find PostgreSQL version with `pg_config --version` Unable to parse name from string Unable to parse version from string Failed to parse PostgreSQL version parts from string =item unknown Enter a valid PostgreSQL version number =back =cut sub version { my $self = shift; return unless $self->{pg_config}; # Load data. $get_version->($self) unless $self->{'--version'}; # Handle an unknown value. unless ($self->{version}) { # Create a validation code reference. my $chk_version = sub { # Try to get the version number parts. my ($x, $y, $z); if ( /^(\d{2,})/) { ($x, $y, $z ) = ($1, 0, 0); # >= v10 } else { ($x, $y, $z) = /^(\d)\.(\d+).(\d+)$/; # < v10 } # 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 => 'postgres 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, if C returns "7.1.2", then this method returns "7". B =over 4 =item info Executing `pg_config --version` =item error Failed to find PostgreSQL version with `pg_config --version` Unable to parse name from string Unable to parse version from string Failed to parse PostgreSQL version parts from string =item unknown Enter a valid PostgreSQL major version number =back =cut # This code reference is used by major_version(), minor_version(), and # patch_version() to validate a version number entered by a user. my $is_int = sub { /^\d+$/ }; sub major_version { my $self = shift; return unless $self->{pg_config}; # Load data. $get_version->($self) unless exists $self->{'--version'}; # Handle an unknown value. $self->{major} = $self->unknown( key => 'postgres major version number', callback => $is_int) unless $self->{major}; return $self->{major}; } ############################################################################## =head3 minor version my $minor_version = $pg->minor_version; Returns the PostgreSQL minor version number. App::Info::RDBMS::PostgreSQL parses the minor version number from the system call C<`pg_config --version`>. For example, if C returns "7.1.2", then this method returns "2". B =over 4 =item info Executing `pg_config --version` =item error Failed to find PostgreSQL version with `pg_config --version` Unable to parse name from string Unable to parse version from string Failed to parse PostgreSQL version parts from string =item unknown Enter a valid PostgreSQL minor version number =back =cut sub minor_version { my $self = shift; return unless $self->{pg_config}; # Load data. $get_version->($self) unless exists $self->{'--version'}; # Handle an unknown value. $self->{minor} = $self->unknown( key => 'postgres minor version number', callback => $is_int) unless defined $self->{minor}; return $self->{minor}; } ############################################################################## =head3 patch version my $patch_version = $pg->patch_version; Returns the PostgreSQL patch version number. App::Info::RDBMS::PostgreSQL parses the patch version number from the system call C<`pg_config --version`>. For example, if C returns "7.1.2", then this method returns "1". B =over 4 =item info Executing `pg_config --version` =item error Failed to find PostgreSQL version with `pg_config --version` Unable to parse name from string Unable to parse version from string Failed to parse PostgreSQL version parts from string =item unknown Enter a valid PostgreSQL minor version number =back =cut sub patch_version { my $self = shift; return unless $self->{pg_config}; # Load data. $get_version->($self) unless exists $self->{'--version'}; # Handle an unknown value. $self->{patch} = $self->unknown( key => 'postgres patch version number', callback => $is_int) unless defined $self->{patch}; return $self->{patch}; } ############################################################################## =head3 executable my $exe = $pg->executable; Returns the full path to the PostgreSQL server executable, which is named F. This method does not use the executable names returned by C; those executable names are used to search for F only (in C). When it called, C checks for an executable named F in the directory returned by C. Note that C is simply an alias for C. B =over 4 =item info Looking for postgres executable =item confirm Path to postgres executable? =item unknown Path to postgres executable? =back =cut my $find_exe = sub { my ($self, $key) = @_; my $exe = $key . (WIN32 ? '.exe' : ''); my $meth = "search_$key\_names"; # Find executable. $self->info("Looking for $key"); unless ($self->{$key}) { my $bin = $self->bin_dir or return; if (my $exe = $u->first_cat_exe([$self->$meth(), $exe], $bin)) { # We found it. Confirm. $self->{$key} = $self->confirm( key => "path to $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 => "path to $key", prompt => "Path to $key executable?", callback => sub { -x }, error => 'Not an executable' ); } } return $self->{$key}; }; for my $exe (@EXES) { no strict 'refs'; *{$exe} = sub { shift->$find_exe($exe) }; *{"search_$exe\_names"} = sub { @{ shift->{"search_$exe\_names"} } } } *executable = \&postgres; ############################################################################## =head3 bin_dir my $bin_dir = $pg->bin_dir; Returns the PostgreSQL binary directory path. App::Info::RDBMS::PostgreSQL gathers the path from the system call C<`pg_config --bindir`>. B =over 4 =item info Executing `pg_config --bindir` =item error Cannot find bin directory =item unknown Enter a valid PostgreSQL bin directory =back =cut # This code reference is used by bin_dir(), lib_dir(), and so_lib_dir() to # validate a directory entered by the user. my $is_dir = sub { -d }; sub bin_dir { my $self = shift; return unless $self->{pg_config}; unless (exists $self->{bin_dir} ) { if (my $dir = $get_data->($self, '--bindir')) { $self->{bin_dir} = $dir; } else { # Handle an unknown value. $self->error("Cannot find bin directory"); $self->{bin_dir} = $self->unknown( key => 'postgres bin dir', callback => $is_dir) } } return $self->{bin_dir}; } ############################################################################## =head3 inc_dir my $inc_dir = $pg->inc_dir; Returns the PostgreSQL include directory path. App::Info::RDBMS::PostgreSQL gathers the path from the system call C<`pg_config --includedir`>. B =over 4 =item info Executing `pg_config --includedir` =item error Cannot find include directory =item unknown Enter a valid PostgreSQL include directory =back =cut sub inc_dir { my $self = shift; return unless $self->{pg_config}; unless (exists $self->{inc_dir} ) { if (my $dir = $get_data->($self, '--includedir')) { $self->{inc_dir} = $dir; } else { # Handle an unknown value. $self->error("Cannot find include directory"); $self->{inc_dir} = $self->unknown( key => 'postgres include dir', callback => $is_dir) } } return $self->{inc_dir}; } ############################################################################## =head3 lib_dir my $lib_dir = $pg->lib_dir; Returns the PostgreSQL library directory path. App::Info::RDBMS::PostgreSQL gathers the path from the system call C<`pg_config --libdir`>. B =over 4 =item info Executing `pg_config --libdir` =item error Cannot find library directory =item unknown Enter a valid PostgreSQL library directory =back =cut sub lib_dir { my $self = shift; return unless $self->{pg_config}; unless (exists $self->{lib_dir} ) { if (my $dir = $get_data->($self, '--libdir')) { $self->{lib_dir} = $dir; } else { # Handle an unknown value. $self->error("Cannot find library directory"); $self->{lib_dir} = $self->unknown( key => 'postgres library dir', callback => $is_dir) } } return $self->{lib_dir}; } ############################################################################## =head3 so_lib_dir my $so_lib_dir = $pg->so_lib_dir; Returns the PostgreSQL shared object library directory path. App::Info::RDBMS::PostgreSQL gathers the path from the system call C<`pg_config --pkglibdir`>. B =over 4 =item info Executing `pg_config --pkglibdir` =item error Cannot find shared object library directory =item unknown Enter a valid PostgreSQL shared object library directory =back =cut # Location of dynamically loadable modules. sub so_lib_dir { my $self = shift; return unless $self->{pg_config}; unless (exists $self->{so_lib_dir} ) { if (my $dir = $get_data->($self, '--pkglibdir')) { $self->{so_lib_dir} = $dir; } else { # Handle an unknown value. $self->error("Cannot find shared object library directory"); $self->{so_lib_dir} = $self->unknown( key => 'postgres so directory', callback => $is_dir) } } return $self->{so_lib_dir}; } ############################################################################## =head3 configure options my $configure = $pg->configure; Returns the options with which the PostgreSQL server was configured. App::Info::RDBMS::PostgreSQL gathers the configure data from the system call C<`pg_config --configure`>. B =over 4 =item info Executing `pg_config --configure` =item error Cannot find configure information =item unknown Enter PostgreSQL configuration options =back =cut sub configure { my $self = shift; return unless $self->{pg_config}; unless (exists $self->{configure} ) { if (my $conf = $get_data->($self, '--configure')) { $self->{configure} = $conf; } else { # Configure can be empty, so just make sure it exists and is # defined. Don't prompt. $self->{configure} = ''; } } return $self->{configure}; } ############################################################################## =head3 home_url my $home_url = $pg->home_url; Returns the PostgreSQL home page URL. =cut sub home_url { "http://www.postgresql.org/" } ############################################################################## =head3 download_url my $download_url = $pg->download_url; Returns the PostgreSQL download URL. =cut sub download_url { "http://www.postgresql.org/mirrors-ftp.html" } ############################################################################## =head3 search_exe_names my @search_exe_names = $app->search_exe_names; Returns a list of possible names for F executable. By default, only F is returned (or F on Win32). Note that this method is not used to search for the PostgreSQL server executable, only F. =cut sub search_exe_names { my $self = shift; my $exe = 'pg_config'; $exe .= '.exe' if WIN32; return ($self->SUPER::search_exe_names, $exe); } ############################################################################## =head3 search_bin_dirs my @search_bin_dirs = $app->search_bin_dirs; Returns a list of possible directories in which to search an executable. Used by the C constructor to find an executable to execute and collect application info. The found directory will also be returned by the C method. The list of directories by default consists of the path as defined by C<< File::Spec->path >>, as well as the following directories: =over 4 =item $ENV{POSTGRES_HOME}/bin (if $ENV{POSTGRES_HOME} exists) =item $ENV{POSTGRES_LIB}/../bin (if $ENV{POSTGRES_LIB} exists) =item /usr/local/pgsql/bin =item /usr/local/postgres/bin =item /opt/pgsql/bin =item /usr/local/bin =item /usr/local/sbin =item /usr/bin =item /usr/sbin =item /bin =item C:\Program Files\PostgreSQL\bin =back =cut sub search_bin_dirs { return shift->SUPER::search_bin_dirs, ( exists $ENV{POSTGRES_HOME} ? ($u->catdir($ENV{POSTGRES_HOME}, "bin")) : () ), ( exists $ENV{POSTGRES_LIB} ? ($u->catdir($ENV{POSTGRES_LIB}, $u->updir, "bin")) : () ), $u->path, qw(/usr/local/pgsql/bin /usr/local/postgres/bin /usr/lib/postgresql/bin /opt/pgsql/bin /usr/local/bin /usr/local/sbin /usr/bin /usr/sbin /bin), 'C:\Program Files\PostgreSQL\bin'; } ############################################################################## =head2 Other Executable Methods These methods function just like the C method, except that they return different executables. PostgreSQL comes with a fair number of them; we provide these methods to provide a path to a subset of them. Each method, when called, checks for an executable in the directory returned by C. The name of the executable must be one of the names returned by the corresponding C method. The available executable methods are: =over =item postgres =item createdb =item createlang =item createuser =item dropdb =item droplang =item dropuser =item initdb =item pg_dump =item pg_dumpall =item pg_restore =item postmaster =item psql =item vacuumdb =back And the corresponding search names methods are: =over =item search_postgres_names =item search_createdb_names =item search_createlang_names =item search_createuser_names =item search_dropd_names =item search_droplang_names =item search_dropuser_names =item search_initdb_names =item search_pg_dump_names =item search_pg_dumpall_names =item search_pg_restore_names =item search_postmaster_names =item search_psql_names =item search_vacuumdb_names =back B =over 4 =item info Looking for executable =item confirm Path to executable? =item unknown Path to executable? =back =cut 1; __END__ =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler based on code by Sam Tregar . =head1 SEE ALSO L documents the event handling interface. L is the App::Info::RDBMS::PostgreSQL parent class. L is the L driver for connecting to PostgreSQL databases. L is the PostgreSQL home page. =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-3.20.2/t/lib/App/Info/Request.pm0000644000175000017500000002024315157052770015611 0ustar greggregpackage App::Info::Request; =head1 NAME App::Info::Request - App::Info event handler request object =head1 SYNOPSIS # In an App::Info::Handler subclass: sub handler { my ($self, $req) = @_; print "Event Type: ", $req->type; print "Message: ", $req->message; print "Error: ", $req->error; print "Value: ", $req->value; } =head1 DESCRIPTION Objects of this class are passed to the C method of App::Info event handlers. Generally, this class will be of most interest to App::Info::Handler subclass implementers. The L in App::Info each construct a new App::Info::Request object and initialize it with their arguments. The App::Info::Request object is then the sole argument passed to the C method of any and all App::Info::Handler objects in the event handling chain. Thus, if you'd like to create your own App::Info event handler, this is the object you need to be familiar with. Consult the L documentation for details on creating custom event handlers. Each of the App::Info event triggering methods constructs an App::Info::Request object with different attribute values. Be sure to consult the documentation for the L in App::Info, where the values assigned to the App::Info::Request object are documented. Then, in your event handler subclass, check the value returned by the C method to determine what type of event request you're handling to handle the request appropriately. =cut use strict; use Carp; our $VERSION = '0.57'; ############################################################################## =head1 INTERFACE The following sections document the App::Info::Request interface. =head2 Constructor =head3 new my $req = App::Info::Request->new(%params); This method is used internally by App::Info to construct new App::Info::Request objects to pass to event handler objects. Generally, you won't need to use it, other than perhaps for testing custom App::Info::Handler classes. The parameters to C are passed as a hash of named parameters that correspond to their like-named methods. The supported parameters are: =over 4 =item type =item message =item error =item value =item callback =back See the object methods documentation below for details on these object attributes. =cut sub new { my $pkg = shift; # Make sure we've got a hash of arguments. Carp::croak("Odd number of parameters in call to " . __PACKAGE__ . "->new() when named parameters expected" ) if @_ % 2; my %params = @_; # Validate the callback. if ($params{callback}) { Carp::croak("Callback parameter '$params{callback}' is not a code ", "reference") unless UNIVERSAL::isa($params{callback}, 'CODE'); } else { # Otherwise just assign a default approve callback. $params{callback} = sub { 1 }; } # Validate type parameter. if (my $t = $params{type}) { Carp::croak("Invalid handler type '$t'") unless $t eq 'error' or $t eq 'info' or $t eq 'unknown' or $t eq 'confirm'; } else { $params{type} = 'info'; } # Return the request object. bless \%params, ref $pkg || $pkg; } ############################################################################## =head2 Object Methods =head3 key my $key = $req->key; Returns the key stored in the App::Info::Request object. The key is used by the App::Info subclass to uniquely identify the information it is harvesting, such as the path to an executable. It might be used by request handlers, for example, to see if an option was passed on the command-line. =cut sub key { $_[0]->{key} } ############################################################################## =head3 message my $message = $req->message; Returns the message stored in the App::Info::Request object. The message is typically informational, or an error message, or a prompt message. =cut sub message { $_[0]->{message} } ############################################################################## =head3 error my $error = $req->error; Returns any error message associated with the App::Info::Request object. The error message is typically there to display for users when C returns false. =cut sub error { $_[0]->{error} } ############################################################################## =head3 type my $type = $req->type; Returns a string representing the type of event that triggered this request. The types are the same as the event triggering methods defined in App::Info. As of this writing, the supported types are: =over =item info =item error =item unknown =item confirm =back Be sure to consult the App::Info documentation for more details on the event types. =cut sub type { $_[0]->{type} } ############################################################################## =head3 callback if ($req->callback($value)) { print "Value '$value' is valid.\n"; } else { print "Value '$value' is not valid.\n"; } Executes the callback anonymous subroutine supplied by the App::Info concrete base class that triggered the event. If the callback returns false, then C<$value> is invalid. If the callback returns true, then C<$value> is valid and can be assigned via the C method. Note that the C method itself calls C if it was passed a value to assign. See its documentation below for more information. =cut sub callback { my $self = shift; my $code = $self->{callback}; local $_ = $_[0]; $code->(@_); } ############################################################################## =head3 value my $value = $req->value; if ($req->value($value)) { print "Value '$value' successfully assigned.\n"; } else { print "Value '$value' not successfully assigned.\n"; } When called without an argument, C simply returns the value currently stored by the App::Info::Request object. Typically, the value is the default value for a confirm event, or a value assigned to an unknown event. When passed an argument, C attempts to store the the argument as a new value. However, C calls C on the new value, and if C returns false, then C returns false and does not store the new value. If C returns true, on the other hand, then C goes ahead and stores the new value and returns true. =cut sub value { my $self = shift; if ($#_ >= 0) { # grab the value. my $value = shift; # Validate the value. if ($self->callback($value)) { # The value is good. Assign it and return true. $self->{value} = $value; return 1; } else { # Invalid value. Return false. return; } } # Just return the value. return $self->{value}; } 1; __END__ =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO L documents the event triggering methods and how they construct App::Info::Request objects to pass to event handlers. L documents how to create custom event handlers, which must make use of the App::Info::Request object passed to their C object methods. The following classes subclass App::Info::Handler, and thus offer good exemplars for using App::Info::Request objects when handling events. =over 4 =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-3.20.2/t/lib/App/Info/RDBMS.pm0000644000175000017500000000245615157052770015036 0ustar greggregpackage App::Info::RDBMS; use strict; use App::Info; our @ISA = qw(App::Info); our $VERSION = '0.57'; 1; __END__ =head1 NAME App::Info::RDBMS - Information about databases on a system =head1 DESCRIPTION This class is an abstract base class for App::Info subclasses that provide information about relational databases. Its subclasses are required to implement its interface. See L for a complete description and L for an example implementation. =head1 INTERFACE Currently, App::Info::RDBMS adds no more methods than those from its parent class, App::Info. =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO L, L =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBD-Pg-3.20.2/t/01keywords.t0000644000175000017500000001457115166170753013650 0ustar greggreg#!perl use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use Test::More; select(($|=1,select(STDERR),$|=1)[1]); use DBD::Pg (); for ( # BEGIN GENERATED KEYWORDS 'abort', 'absent', 'absolute', 'access', 'action', 'add', 'admin', 'after', 'aggregate', 'all', 'also', 'alter', 'always', 'analyse', 'analyze', 'and', 'any', 'array', 'as', 'asc', 'asensitive', 'assertion', 'assignment', 'asymmetric', 'at', 'atomic', 'attach', 'attribute', 'authorization', 'backward', 'before', 'begin', 'between', 'bigint', 'binary', 'bit', 'boolean', 'both', 'breadth', 'by', 'cache', 'call', 'called', 'cascade', 'cascaded', 'case', 'cast', 'catalog', 'chain', 'char', 'character', 'characteristics', 'check', 'checkpoint', 'class', 'close', 'cluster', 'coalesce', 'collate', 'collation', 'column', 'columns', 'comment', 'comments', 'commit', 'committed', 'compression', 'concurrently', 'configuration', 'conflict', 'connection', 'constraint', 'constraints', 'content', 'continue', 'conversion', 'copy', 'cost', 'create', 'cross', 'csv', 'cube', 'current', 'current_catalog', 'current_date', 'current_role', 'current_schema', 'current_time', 'current_timestamp', 'current_user', 'cursor', 'cycle', 'data', 'database', 'day', 'deallocate', 'dec', 'decimal', 'declare', 'default', 'defaults', 'deferrable', 'deferred', 'definer', 'delete', 'delimiter', 'delimiters', 'depends', 'depth', 'desc', 'detach', 'dictionary', 'disable', 'discard', 'distinct', 'do', 'document', 'domain', 'double', 'drop', 'each', 'else', 'enable', 'encoding', 'encrypted', 'end', 'enum', 'escape', 'event', 'except', 'exclude', 'excluding', 'exclusive', 'execute', 'exists', 'explain', 'expression', 'extension', 'external', 'extract', 'false', 'family', 'fetch', 'filter', 'finalize', 'first', 'float', 'following', 'for', 'force', 'foreign', 'format', 'forward', 'freeze', 'from', 'full', 'function', 'functions', 'generated', 'global', 'grant', 'granted', 'greatest', 'group', 'grouping', 'groups', 'handler', 'having', 'header', 'hold', 'hour', 'identity', 'if', 'ilike', 'immediate', 'immutable', 'implicit', 'import', 'in', 'include', 'including', 'increment', 'indent', 'index', 'indexes', 'inherit', 'inherits', 'initially', 'inline', 'inner', 'inout', 'input', 'insensitive', 'insert', 'instead', 'int', 'integer', 'intersect', 'interval', 'into', 'invoker', 'is', 'isnull', 'isolation', 'join', 'json', 'json_array', 'json_arrayagg', 'json_object', 'json_objectagg', 'json_scalar', 'json_serialize', 'key', 'keys', 'label', 'language', 'large', 'last', 'lateral', 'leading', 'leakproof', 'least', 'left', 'level', 'like', 'limit', 'listen', 'load', 'local', 'localtime', 'localtimestamp', 'location', 'lock', 'locked', 'logged', 'mapping', 'match', 'matched', 'materialized', 'maxvalue', 'merge', 'method', 'minute', 'minvalue', 'mode', 'month', 'move', 'name', 'names', 'national', 'natural', 'nchar', 'new', 'next', 'nfc', 'nfd', 'nfkc', 'nfkd', 'no', 'none', 'normalize', 'normalized', 'not', 'nothing', 'notify', 'notnull', 'nowait', 'null', 'nullif', 'nulls', 'numeric', 'object', 'of', 'off', 'offset', 'oids', 'old', 'on', 'only', 'operator', 'option', 'options', 'or', 'order', 'ordinality', 'others', 'out', 'outer', 'over', 'overlaps', 'overlay', 'overriding', 'owned', 'owner', 'parallel', 'parameter', 'parser', 'partial', 'partition', 'passing', 'password', 'placing', 'plans', 'policy', 'position', 'preceding', 'precision', 'prepare', 'prepared', 'preserve', 'primary', 'prior', 'privileges', 'procedural', 'procedure', 'procedures', 'program', 'publication', 'quote', 'range', 'read', 'real', 'reassign', 'recheck', 'recursive', 'ref', 'references', 'referencing', 'refresh', 'reindex', 'relative', 'release', 'rename', 'repeatable', 'replace', 'replica', 'reset', 'restart', 'restrict', 'return', 'returning', 'returns', 'revoke', 'right', 'role', 'rollback', 'rollup', 'routine', 'routines', 'row', 'rows', 'rule', 'savepoint', 'scalar', 'schema', 'schemas', 'scroll', 'search', 'second', 'security', 'select', 'sequence', 'sequences', 'serializable', 'server', 'session', 'session_user', 'set', 'setof', 'sets', 'share', 'show', 'similar', 'simple', 'skip', 'smallint', 'snapshot', 'some', 'sql', 'stable', 'standalone', 'start', 'statement', 'statistics', 'stdin', 'stdout', 'storage', 'stored', 'strict', 'strip', 'subscription', 'substring', 'support', 'symmetric', 'sysid', 'system', 'system_user', 'table', 'tables', 'tablesample', 'tablespace', 'temp', 'template', 'temporary', 'text', 'then', 'ties', 'time', 'timestamp', 'to', 'trailing', 'transaction', 'transform', 'treat', 'trigger', 'trim', 'true', 'truncate', 'trusted', 'type', 'types', 'uescape', 'unbounded', 'uncommitted', 'unencrypted', 'union', 'unique', 'unknown', 'unlisten', 'unlogged', 'until', 'update', 'user', 'using', 'vacuum', 'valid', 'validate', 'validator', 'value', 'values', 'varchar', 'variadic', 'varying', 'verbose', 'version', 'view', 'views', 'volatile', 'when', 'where', 'whitespace', 'window', 'with', 'within', 'without', 'work', 'wrapper', 'write', 'xml', 'xmlattributes', 'xmlconcat', 'xmlelement', 'xmlexists', 'xmlforest', 'xmlnamespaces', 'xmlparse', 'xmlpi', 'xmlroot', 'xmlserialize', 'xmltable', 'year', 'yes', 'zone', # END GENERATED KEYWORDS ) { # This tests only positive results. # Negative results should be foolproof, because is_keyword always ends with a strcmp() ok (DBD::Pg::db::_is_keyword($_), $_); } # ...but why not test just one negative result ok (!DBD::Pg::db::_is_keyword('notakeyword'), 'notakeyword'); ## nospellcheck done_testing; DBD-Pg-3.20.2/t/01connect.t0000644000175000017500000002131115174656376013431 0ustar greggreg#!perl ## Make sure we can connect and disconnect cleanly ## All tests are stopped if we cannot make the first connect use 5.008001; use strict; use warnings; use lib 'blib/lib', 'blib/arch', 't'; use DBI; use DBD::Pg; use Test::More; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); ## Define this here in case we get to the END block before a connection is made. our ($t, $pgversion, $pglibversion, $pgvstring, $pgdefport, $helpconnect, $dbh, $connerror, %setting); BEGIN { ($pgversion,$pglibversion,$pgvstring,$pgdefport) = ('?','?','?','?'); } eval { ($helpconnect,$connerror,$dbh) = connect_database(); }; if ($@ =~ /Invalid initdb/) { BAIL_OUT 'Could not connect: no initdb found'; } if (! defined $dbh or $connerror) { plan skip_all => "Connection to database failed, cannot continue testing ($connerror) (dbh=" . (defined($dbh) ? $dbh : '') . ')'; } plan tests => 24; pass ('Connection to test database works'); $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(), 'Calling $dbh->disconnect() works'); # Connect two times. From this point onward, do a simpler connection check $t=q{Second database connection works}; (undef,$connerror,$dbh) = connect_database(); is ($connerror, '', $t); if ($connerror ne '') { BAIL_OUT 'Second connection to database failed, bailing out'; } ## Grab some important values used for debugging my @vals = qw/array_nulls backslash_quote server_encoding client_encoding standard_conforming_strings/; my $SQL = 'SELECT name,setting FROM pg_settings WHERE name IN (' . (join ',' => map { qq{'$_'} } @vals) . ')'; for (@{$dbh->selectall_arrayref($SQL)}) { my ($name, $value) = @$_; ## Skip 'normal' settings next if $name eq 'array_nulls' and $value eq 'on'; next if $name eq 'standard_conforming_strings' and $value eq 'on'; next if $name eq 'backslash_quote' and $value ne 'off'; next if $name =~ /encoding/ and $value eq 'UTF8'; $setting{$name} = $value; } my $dbh2 = connect_database(); pass ('Connect with second database handle'); my $sth = $dbh->prepare('SELECT 123'); ok ($dbh->disconnect(), 'Disconnect first database handle'); ok ($dbh2->disconnect(), 'Disconnect second database handle (first attempt)'); ok ($dbh2->disconnect(), 'Disconnect second database handle (second attempt)'); $t=q{Calling execute() fails on a disconnected statement}; eval { $sth->execute() }; ok ($@, $t); ## A failure to produce a valid arg for libpq will give a message like this: ## DBI connect('dbname=dbdpg_test;baldrick=0','',...) failed: ## invalid connection option "baldrick" $t=q{Calling DBI->connect() with an invalid option fails}; my $bad_dsn = 'dbi:Pg:dbname=dbdpg_test;baldrick=0'; eval { DBI->connect($bad_dsn, '', '', {RaiseError=>1}) }; like ($@, qr/DBI.*baldrick/, $t); $t=q{Calling DBI->connect with database as "XXX" works}; for my $opt (qw/db dbname database/) { $bad_dsn = "dbi:Pg:$opt=dbdpg_test;edmund=1"; eval { DBI->connect($bad_dsn, '', '', {RaiseError=>1}) }; (my $tt = $t) =~ s/XXX/$opt/; like ($@, qr/DBI.*edmund/, $tt); } $t=q{Calling DBI->connect() with forced uppercase 'DBI:' works}; my ($testdsn,$testuser,undef,$su,$uid,$testdir,$pg_ctl,$initdb,$error,$version) ## no critic (Variables::ProhibitUnusedVarsStricter) = get_test_settings(); $testdsn =~ s/^dbi/DBI/i; my $ldbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}); ok (ref $ldbh, $t); $ldbh->disconnect(); $t=q{Calling DBI->connect() with mixed case 'DbI:' works}; ## nospellcheck $testdsn =~ s/^dbi/DbI/i; $ldbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}); ok (ref $ldbh, $t); $ldbh->disconnect(); $t=q{Calling DBI->connect() with an improperly quoted dbname fails}; ## A failure to produce a valid arg for libpq will give a message like this: ## failed: missing "=" after "s" in connection info string $bad_dsn = q{dbi:Pg:dbname=dbdpg space name;port=1}; eval { DBI->connect($bad_dsn, '', '', {RaiseError=>1}) }; like ($@, qr/=/, $t); $t=q{Calling DBI->connect() with proper quoting but bad port gives expected error}; ## An otherwise correct call but to an invalid port gives a message like this: ## DBI connect('dbname='dbdpg \'spacey\' name';port=1','',...) failed: ## could not connect to server: No such file or directory ## Is the server running locally and accepting ## connections on Unix domain socket "/tmp/.s.PGSQL.1"? $bad_dsn = q{dbi:Pg:dbname='dbdpg \'spacey\' name';port=1}; eval { DBI->connect($bad_dsn, '', '', {RaiseError=>1}) }; like ($@, ($^O =~ /Win/ ? qr/DBI/s : qr/DBI.*\Q.s.PGSQL.1\E\b/s), $t); SKIP: { if ($pglibversion < 100000) { skip ('Multiple host names requires libpq >= 10', 1); } $t=q{Calling DBI->connect() with multiple host names works}; (my $tempdsn = $testdsn) =~ s/host=/host=foo.invalid,/; $ldbh = DBI->connect($tempdsn, $testuser, $ENV{DBI_PASS}); ok (ref $ldbh, $t); $ldbh->do('select 1'); $ldbh->disconnect(); } SKIP: { my @names = ('foo', 'foo bar', ';foo;bar;', 'foo\'bar', 'foo\\\'bar', 'foo\';bar\';', '\\foo\\'); if ($pgversion < 90000) { skip ('Calling DBI->connect() with an application_name requires Postgres >= 9.0', @names * 2); } for my $aname (@names) { $t=qq{Calling DBI->connect() with aname=$aname}; (my $escaped_name = $aname) =~ s/(['\\])/\\$1/g; my $adbh = DBI->connect("$testdsn;application_name='$escaped_name'", $testuser, $ENV{DBI_PASS}); if (! ref $adbh) { fail ("Failed to connect: $DBI::errstr"); next; } my $returned_name = $adbh->selectrow_array('show application_name'); $t=qq{Setting application_name on connect() returns correct value for: $aname}; is ($returned_name, $aname, $t); $adbh->disconnect; } } END { my $pv = sprintf('%vd', $^V); my $schema = 'dbd_pg_testschema'; my $dsn = exists $ENV{DBI_DSN} ? $ENV{DBI_DSN} : '?'; ## Don't show current dir to the world via CPAN::Reporter results $dsn =~ s{host=/.*(testdb)}{host=/$1}; my $ver = defined $DBD::Pg::VERSION ? $DBD::Pg::VERSION : '?'; my $user = exists $ENV{DBI_USER} ? $ENV{DBI_USER} : ''; my $offset = 27; my $extra = ''; for (sort qw/HOST HOSTADDR PORT DATABASE USER PASSWORD PASSFILE OPTIONS REALM REQUIRESSL KRBSRVNAME CONNECT_TIMEOUT SERVICE SSLMODE SYSCONFDIR CLIENTENCODING/) { my $name = "PG$_"; if (exists $ENV{$name} and defined $ENV{$name}) { $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name; } } for my $name (qw/DBI_DRIVER DBI_AUTOPROXY LANG/) { if (exists $ENV{$name} and defined $ENV{$name} and $ENV{$name}) { $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name; } } for my $name (grep { /^DBDPG/ } sort keys %ENV) { $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name; } for my $name (qw/ RELEASE_TESTING AUTHOR_TESTING /) { if (exists $ENV{$name} and defined $ENV{$name}) { $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name; } } ## More helpful stuff for (sort keys %setting) { $extra .= sprintf "\n%-*s %s", $offset, $_, $setting{$_}; } if ($helpconnect) { $extra .= sprintf "\n%-*s ", $offset, 'Adjusted:'; if ($helpconnect & 1) { $extra .= 'DBI_DSN '; } if ($helpconnect & 4) { $extra .= 'DBI_USER'; } if ($helpconnect & 8) { $extra .= 'DBI_USERx2'; } if ($helpconnect & 16) { $extra .= 'initdb'; } } if (defined $connerror and length $connerror) { $connerror =~ s/.+?failed: ([^\n]+).*/$1/s; $connerror =~ s{\n at t/dbdpg.*}{}m; if ($connerror =~ /create semaphores/) { $connerror =~ s/.*(FATAL.*?)HINT.*/$1/sm; } $extra .= "\nError was: $connerror"; } diag "\nDBI Version $DBI::VERSION\n". "DBD::Pg Version $ver\n". "Perl Version $pv\n". "OS $^O\n". "PostgreSQL (compiled) $pglibversion\n". "PostgreSQL (target) $pgversion\n". "PostgreSQL (reported) $pgvstring\n". "Default port $pgdefport\n". "DBI_DSN $dsn\n". "DBI_USER $user\n". "Test schema $schema$extra\n"; if ($extra =~ /Error was/ and $extra !~ /probably not available/) { BAIL_OUT "Cannot continue: connection failed\n"; } } DBD-Pg-3.20.2/README0000644000175000017500000003154715175421115012061 0ustar greggreg DBD::Pg is Copyright (C) 1994-2026, Greg Sabino Mullane DBD::Pg -- the DBI PostgreSQL interface for Perl DESCRIPTION: ------------ This is version 3.20.2 of DBD::Pg, the Perl interface to Postgres using DBI. The web site for this interface, and the latest version, can be found at: https://metacpan.org/pod/DBD::Pg The mailing list is at: https://www.nntp.perl.org/group/perl.dbd.pg/ Subscribe with an email to dbd-pg-subscribe@perl.org The development of DBD::Pg can be tracked at: git://github.com/bucardo/dbdpg.git For information about PostgreSQL, visit: https://www.postgresql.org/ For information on what has changed for each version, see the Changes files. REQUIREMENTS: ------------- build, test, and install Perl 5 (at least 5.8.1) build, test, and install the DBI module (at least 1.614) build, test, and install PostgreSQL (at least 8.0) build, test, and install Test::Simple (at least 0.47) DBD::Pg needs to know where to find the libpq libraries: this is usually done by checking the output of the pg_config executable. If pg_config is not available, then you may need to install the development package for PostgreSQL. To do this on Debian and Ubuntu, use: apt-get install libpq-dev; on RedHat, CentOS, etc. use: yum install postgresql-devel; on Mac use: brew install postgresql. Note that the development libraries and header files are needed even if you already have PostgreSQL up and running. IF YOU HAVE PROBLEMS OR COMMENTS: --------------------------------- Please send any problems and comments to Please include what OS you are using, and the version of Perl, DBI, and DBD::Pg you are using. Also tell which version of PostgreSQL DBD::Pg was compiled against, and which version you are connecting to. The easiest way to gather all of this information is to run "make test", which outputs it all early in the tests. View the archive at http://www.nntp.perl.org/group/perl.dbd.pg/ To subscribe, email dbd-pg-subscribe@perl.org To unsubscribe, email dbd-pg-unsubscribe@perl.org To get help regarding your subscription, email dbd-pg-help@perl.org You can also try the #postgresql channel on irc.libera.chat, which usually (but not always) has people who can help you with DBD::Pg. BUG REPORTS: ----------- Bug reports are welcome at: https://github.com/bucardo/dbdpg/issues PATCHES: -------- Patches are always welcome: the best way is to create a Pull Request at https://github.com/bucardo/dbdpg INSTALLATION: ------------- Before installing, please use the "cpansign -v" program to cryptographically verify that your copy of DBD::Pg is complete and valid. The program "cpansign" is part of Module::Signature, available from CPAN. By default Makefile.PL uses App::Info to find the location of the PostgreSQL library and include directories. However, if you want to control it yourself, define the environment variables POSTGRES_INCLUDE and POSTGRES_LIB, or define just POSTGRES_HOME. Note that if you have compiled PostgreSQL with SSL support, you must define the POSTGRES_LIB environment variable and add "-lssl" and "-lcrypto" to it, like this: export POSTGRES_LIB="/usr/local/pgsql/lib -lssl -lcrypto" The usual steps to install DBD::Pg: 1. perl Makefile.PL 2. make 3. make test 4. make install Do steps 1 to 2 as a normal user, not as root! If the script cannot find the pg_config information itself, it will ask you for the path to it. Enter the complete path to the pg_config file here, including the name of the file itself. TESTING: -------- The tests rely on being able to connect to a valid Postgres database. The easiest way to ensure this is to set the following environment variables: DBI_DSN=dbi:Pg:dbname= DBI_USER= DBI_PASS= If you are running on a non-standard port, you must set PGPORT or add the port to the DBI_DSN variable like this: DBI_DSN='dbi:Pg:dbname=;port=' Put double quotes around the dbname if it has a semicolon or a space inside of it: DBI_DSN='dbi:Pg:dbname=""' If no valid connection is found, the tests will use the "initdb" program to try and create a Postgres database cluster to test with. The first available port starting at 5440 will be used. If your directory path is long, Postgres may fail to start as there is a maximum length to socket directory paths. If this happens, please set the environment variable DBDPG_TEMPDIR to something short, such as "/tmp". You can increase the verbosity of the tests by setting the environment variable TEST_VERBOSE. You can also enable tracing within the tests themselves by setting DBD_TRACE to whatever trace level you want. Be aware that setting the trace level can result in extremely verbose output. When reporting test failures, please use TEST_VERBOSE=1, but do *not* set DBD_TRACE unless requested, and send only the relevant sections. Please consider installing CPAN::Reporter so that your tests are automatically gathered and reported, which helps the development of DBD::Pg. TROUBLESHOOTING: ---------------- * Placeholder issues If you find that some of your queries containing placeholders are no longer working, this may because DBD::Pg now uses the native PostgreSQL placeholders on the server itself whenever possible. Previously, DBD::Pg did a simple emulation of placeholders, so the rules were not as strict. You should either rewrite your queries to make them legal SQL syntax for PostgreSQL, or turn off server-side prepares. To change your queries, make sure that the type of each placeholder can be determined by the PostgreSQL parser. So instead of: SELECT ? use something like: SELECT ?::int To turn off server-side prepares completely (with a loss of some performance and features), do this at the top of your scripts: $dbh->{pg_server_prepare} = 0; This can also be set for individual queries at the statement handle level: see the documentation section on "Placeholders" for more details. * PostgreSQL library issues: DBD::Pg uses the libpq library that comes with Postgres. If the shared libpq library is not available, DBD::Pg will error with a message that usually mentions a file names libpq.so, like this: Can't load './blib/arch/auto/DBD/Pg/Pg.so' for module DBD::Pg: libpq.so.5: cannot open shared object file: No such file or directory at .../DynaLoader.pm line 230. This means that the libraries are not installed in a place where the system can find them when it tries to load the Pg.so file. On some systems, you can run /sbin/ldconfig -v to see a list of shared modules, or just search the system for the file with "locate libpq.so". If it exists but is not being loaded, you may need to add the directory it is in to /etc/ld.so.conf file and run the ldconfig command. Otherwise, you may need to add the path to the environment variable LD_LIBRARY_PATH. If you get an error message like: perl: error while loading shared libraries: /usr/lib/perl5/site_perl/5.6.1/i386-linux/auto/DBD/Pg/Pg.so: undefined symbol: PQconnectdb when you call DBI->connect, then your libpq.so was probably not seen at build-time. This should have caused 'make test' to fail; did you really run it and look at the output? * Mac installation issues Modern Mac software has a feature called Software Integrity Protection that strips out all LD_* and DYLD_* environment variables when a program starts, which means DBD::Pg will not compile. One solution is to use the install_name_tool program to modify the relative paths to absolute ones. As an example: sudo install_name_tool -change \ libpq.5.dylib /Library/PostgreSQL/11/lib/libpq.5.dylib \ ~/perl5/lib/perl5/darwin-thread-multi-2level/auto/DBD/Pg/Pg.bundle * Perl issues: Some Linux distributions have incomplete perl installations. If you have compile errors like "XS_VERSION_BOOTCHECK undeclared", do: find .../lib/perl5 -name XSUB.h -print If this file is not present, you need to recompile and re-install perl. If you get a message about "use of uninitialized value in -d" when doing a "make install_vendor", you can work around this by adding a dummy value to the INSTALLVENDORBIN environment variable: make install_vendor INSTALLVENDORBIN=/tmp (thanks to Peter Eisentraut ) * Strawberry Perl issues: You'll need to create a .a library from the .dll before running the Makefile.PL, by running pexports and dlltool as shown below, within the C:\Program Files\PostgreSQL\8.3\bin directory: C:\Windows\> C:\MinGW\bin\pexports libpq.dll > libpq.def C:\Windows\> C:\MinGW\bin\dlltool -dllname libpq.dll --def libpq.def --output-lib "C:\Program Files\PostgreSQL\12\lib\libpq.a" pexports and dlltool are included with MinGW - Minimalist Gnu for Windows, found here: https://osdn.net/projects/mingw/releases/ Once you have installed MinGW you can install pexports and dlltool as follows: C:\Windows\> C:\MinGW\bin\mingw-get.exe install pexports C:\Windows\> C:\MinGW\bin\mingw-get.exe install dlltool Then you'll need to set the required environment: set PATH=C:\PROGRA~1\PostgreSQL\8.3\bin;%PATH% set DBI_DSN=dbi:Pg:dbname=testdb set DBI_USER=*PostgreSQL username* set DBI_PASS=*PostgreSQL password* set POSTGRES_HOME=C:/PROGRA~1/PostgreSQL/8.3 set POSTGRES_INCLUDE=C:/PROGRA~1/PostgreSQL/8.3/include set POSTGRES_LIB=C:/PROGRA~1/PostgreSQL/8.3/lib Note that the username and password are the ones for PostgreSQL, NOT the ones for the Windows account that the PostgreSQL installer creates to run the service safely. (You may wish to set these variables on the system level, by going to Control Panel > System > Advanced tab > Environment Variables button and adding the environment variables there.) Now the Makefile.PL can be ran: perl Makefile.PL dmake dmake test dmake install * SGI issues: If you get segmentation faults, make sure you are using the malloc which comes with perl when compiling perl (the default is not to). (thanks to "David R. Noble" ) * HP issues: If you get error messages like: can't open shared library: .../lib/libpq.sl No such file or directory when running the test script, try to replace the 'shared' option in the LDDFLAGS with 'archive'. (thanks to Dan Lauterbach ) * FreeBSD issues: If you get during "make test" the error message: 'DBD driver has not implemented the AutoCommit attribute' recompile the DBI module and the DBD-Pg module and disable optimization. This error message is due to the broken optimization in gcc-2.7.2.1. If you get compiler errors like: In function `XS_DBD__Pg__dr_discon_all_' `sv_yes' undeclared (first use in this function) it may be because there is a 'patchlevel.h' file from another package (such as 'hdf') in your POSTGRES_INCLUDE dir. The presence of this file prevents the compiler from finding the perl include file 'mach/CORE/patchlevel.h'. Do 'pg_config --includedir' to identify the POSTGRES_INCLUDE dir. Rename patchlevel.h whilst you build DBD::Pg. * Sun issues: If you get compile errors like: /usr/include/string.h:57: parse error before `]' then you need to remove from pgsql/include/libpq-fe.h the define for strerror, which clashes with the definition in the standard include file. * Win32 issues: For installation, please see the README.win32 file. Running DBD-Pg scripts on Win32 needs some configuration work on the server side: o add a postgres user with the same name as the NT-User (e.g. Administrator) o make sure, that your pg_hba.conf on the server is configured, such that a connection from another host will be accepted * OS X issues: You may need to add "-lssl" and "-lcrypto" to your LIB variable before compiling. (thanks to ) If having problems compiling, try running: env -i command This trick stops 'command' from inheriting environment variables from the shell process, which more often than not fixes up such weird build errors without having to do anything else in particular. (thanks to David Landgren ) * SCO issues: If the 'make test' gives an error about a symbol not being found, you can correct the problem by manually running ld after the 'make' command: LD_RUN_PATH="/usr/local/pgsql/lib" ld -G -L/usr/local/lib Pg.o \ dbdimp.o -o blib/arch/auto/DBD/Pg/Pg.so -L/usr/local/pgsql/lib -lpq \ -L/opt/K/SKUNK2000/Gcc/2.95.2pl1/usr/local/lib/gcc-lib/i386-pc-sco3.2v5.0.5/2.95.2/ \ -lgcc Once this is done, 'make test' succeeds properly. (thanks to ) COPYRIGHT: ---------- Copyright (c) 2002-2026 Greg Sabino Mullane and others: see the Changes file Portions Copyright (c) 2002 Jeffrey W. Baker Portions Copyright (c) 1997-2001 Edmund Mergl Portions Copyright (c) 1994-1997 Tim Bunce LICENSE INFORMATION: -------------------- This module (DBD::Pg) is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For more details, see the full text of the licenses in the directory LICENSES. DBD-Pg-3.20.2/Changes0000644000175000017500000023345615175421010012471 0ustar greggregChanges for the DBD::Pg module RT items can be found by using: https://rt.cpan.org/Public/Bug/Display.html?id=XXX Github items can be found by using: https://github.com/bucardo/dbdpg/issues/XXX Version 3.20.2 (released May 1, 2026) - Fix incorrect path separator which may impede Mac compilation. [Ed Sabol, reported by Éric Cholet] (Github pull request #191) Version 3.20.1 (released April 30, 2026) - Set imp_dbh->async_sth when a prepare is successfully sent from pg_st_prepare_statement Don't execute "result auto-retrieve" code for a successful async prepare Increment imp_dbh->prepare_number when success of an async prepare is detected in handle_old_async [Rainer Weikusat, reported by Michael Kröll] (Github issue #183, pull request #184) - Fix hangup of queries like "COPY TO STDOUT" in async mode [Ed Sabol, Alexander Gorlov] (Github issue #98, pull request #101 and #163) - Improve documentation about sslmode options [Ed Sabol, reported by Alexander Karelas] (Github issue #180, pull request #186) - Drop ExtUtils::MakeMaker requirement back to 6.58, but recommend 7.64 [Greg Sabino Mullane, Ed Sabol, reported by Peter Tribble] (Github issue #170) - Shorten path for test database to reduce OS errors [Greg Sabino Mullane, Ed Sabol, reported by Gianni Ceccarelli and Peter Dyballa] (Github issue #78 and #185) (RT ticket #157598) Version 3.20.0 (released March 19, 2026) - Cleanup and improve the statistics_info() function. We no longer return "clustered" as a "TYPE" [Greg Sabino Mullane] - Ensure FetchHashKeyName cannot affect internal functions [Greg Sabino Mullane] (Github issue #174) - Fix compilation warning with gcc 15.2.0 [Ed Sabol] (Github issue #165) (Github pull request #167) - Fix failing test due to localized error messages. [Ed Sabol, reported by Slaven Rezić] (Github issue #169) (Github pull request #164) - Add a security policy via the SECURITY.md file [Ed Sabol] (Github issue #146) (Github pull request #172) - Cleanup and improve the primary_key_info() function. [Greg Sabino Mullane] (Github pull request #175) Version 3.19.0 (released March 14, 2026) - Support for asynchronous connect via PQconnectStart/ PQconnectPoll [Rainer Weikusat] (Github pull request #141) - Fix async query ownership and data preservation [Tobias Oetiker] (Github pull request #105) - Use PQsendPrepare instead of PQprepare for async queries [Rainer Weikusat] (Github pull request #142) - Many cleanups and improvements to the cancel functions [Rainer Weikusat] (Github pull requests #145 and #152) - Prevent pg_error_field() from modifying string [Lukas Mai] (Github issue #157 and pull request #158) - Speed up quote_name using binary search Also a new test t/01keywords.t [Michael Conrad] (Github pull request #124) - Cleanup and improve the column_info() function. Added a new field, pg_database Split numeric type sizes across COLUMN_SIZE and DECIMAL_DIGITS [Greg Sabino Mullane] (Github pull request #162) - Support binding native boolean false on Perl 5.36 and newer [Dagfinn Ilmari Mannsåker] - Respect pg_bool_tf when binding native booleans on Perl 5.36 and newer [Dagfinn Ilmari Mannsåker] (Github issue #125 and pull request #129) - Clean up and clarify $dbh->data_sources behavior [Greg Sabino Mullane] - Require ExtUtils::MakeMaker 7.64 [brian d foy] [Rainer Weikusat] (Github issue #69) (Github pull requests #137 #155) - C23 compliance for functions taking variable number of arguments [Rainer Weikusat] (Github pull request #148) - Separate $username and $password from DSN parameters in POD [Daniel Böhmer] (Github pull request #149) - Add example for using RETURNING in "insert into foo (...) returning id" [H.Merijn Brand] (Github pull request #134) - Do not use TMPDIR if we are providing a path via DBDPG_TEMPDIR environment variable. [Greg Sabino Mullane] (RT ticket #157598) - Switch from netstat to ss for finding free ports during testing [Greg Sabino Mullane] Version 3.18.0 (released December 6, 2023) - Support new PQclosePrepared function, added in Postgres 17 [Greg Sabino Mullane] - Better docs about ping always returning a value (Github issue #121) Version 3.17.0 (released August 23, 2023) - New database handle attribute pg_skip_deallocate Prevents any deallocation of automatically prepared statements to support new pgBouncer feature [Greg Sabino Mullane] - Fix to handle escaped quotes in connection string [Dagfinn Ilmari Mannsåker] - Return number of affected rows from a MERGE command [Greg Sabino Mullane] (Github issue #118) - Add support for Github CI actions [Gábor Szabó] (Github pull request #115) - Remove undocumented internal-only pg_pid_number attribute [Greg Sabino Mullane] (Github issue #102) - Small warning in docs about PG_CHAR [Greg Sabino Mullane] (Github issue #103) Version 3.16.3 (released April 4, 2023) - Fix to remove MYMETA files added by mistake to tarball Version 3.16.2 (released April 4, 2023) - Force test suite to use a specific shell for the initdb command [Ed Sabol] (Github issue #104) - Revert to using META.yml, and generate MYMETA.* files (Github issue #111) (Github issue #113) Version 3.16.1 (released March 5, 2023) - Add new attribute "pg_int8_as_string", for backwards compatibility. [Alexander Gorlov] (Github pull request #100) - Add a META.json file; rename META.yml to META.yaml - Fix 03smethod.t $sth->last_insert_id skip count for DBI < 1.642 [Dagfinn Ilmari Mannsåker] (Github issue #99) - Documentation improvements for service files [Erik Rijkers] Version 3.16.0 (released August 8, 2022) - Automatically use 64-bit versions of large object functions when available [Dagfinn Ilmari Mannsåker, David Christensen] - Set UTF8 flag as needed for error messages [Github user olafgw] (Github issue #97) - In tests, do not assume what the default transaction isolation level will be [Rene Schickbauer] (Github issue #94) - Make tests smarter about detecting pg_ctl results in different locales [Greg Sabino Mullane] (Github issue #95) Version 3.15.1 (released February 13, 2022) - Fix missing "use File::Temp" [Greg Sabino Mullane] (Github issue #79) - Switch from DynaLoader to XSLoader [Todd Rinaldo ] (Github pull request #76) - Replace use of "vars" with "our" [James Raspass ] (Github pull request #75) - Documentation improvements [Ed Sabol] [Nicholas Clark ] - Use non-root user when calling pg_resetwal [Greg Sabino Mullane] - Allow use of $ENV{DBDPG_TEMPDIR} to shorten test directory paths. (Github issue #78) Version 3.15.0 (released May 21, 2021) - Correctly pull back pg_async status from statement handle. Previously, $dbh->{pg_async} would return undef. [Greg Sabino Mullane] (RT ticket #136553) - Adjust tests for the fact that reltuples can be -1 in Postgres version 14 and later. This is mostly reflected in the CARDINALITY column for $dbh->statistics_info. [Greg Sabino Mullane] - Remove the experimental 'fulltest' Makefile target. [Greg Sabino Mullane] (RT ticket #136567) Version 3.14.2 (released August 13, 2020) - Fix ENV typo in the test suite [Gregor Herrmann] - Renamed and enhanced test helper script: dbdpg_test_postgres_versions.pl [Greg Sabino Mullane] Version 3.14.1 (released August 12, 2020) - Force the version string so undefined errors in the "driver" sub go away. [Greg Sabino Mullane] (RT ticket #83057) Version 3.14.0 (released July 19, 2020) - The $dbh->primary_key_info and $dbh->foreign_key_info methods will now always return a statement handle, even with no matches. Previously, they returned undef directly. Callers can check if the returned handle contains any rows. [Greg Sabino Mullane] - The $dbh->tables method will always return a list, even if it is empty. [Greg Sabino Mullane] - Add pg_lo_tell64, pg_lo_seek64, and pg_lo_truncate64, for anyone dealing with really, really, really large 'large objects'. Requires Postgres 9.3 or better. [Greg Sabino Mullane] (RT ticket #123561) - Allow test to run again when using a non-superuser to connect [Greg Sabino Mullane] (RT ticket #132865) - Adjust tests to force loading proper version of DBD::Pg every time. [Greg Sabino Mullane] - Removed the long-deprecated _pg_use_catalog method. [Greg Sabino Mullane] - Many improvements and changes to the test suite. [Greg Sabino Mullane] Version 3.13.0 (released June 17, 2020) - Redo the "last_result" internals in dbdimp.c, which fixes a memory leak. [Greg Sabino Mullane] (RT ticket #132812) - Fix regression in Perl length() for returned query results [Jon Jensen] (Github issue #72) - Make $sth->finish() do a little less. Notably, even after calling finish(), pg_error_field will still work on the last action performed. [Greg Sabino Mullane] - Tweak tests so Windows boxes pass [Greg Sabino Mullane] Version 3.12.3 (released June 5, 2020) - Prevent DBI from flipping AutoCommit to 'on' after a failed commit [Greg Sabino Mullane] (Github issue #71) Version 3.12.2 (released June 4, 2020) - Revert overly aggressive testing shortcut as it can cause installs to fail [Greg Sabino Mullane, with apologies] Version 3.12.1 (released June 3, 2020) - Remove test that assumed '(12,34)' is an invalid entry for type "circle", as the Postgres source code changed this behavior on April 7, 2020 [Greg Sabino Mullane] (RT ticket #132740) Version 3.12.0 (released May 7, 2020) - Add CONTRIBUTING.md file - Return the table info row last in statistics_info. This fixes statistics_info on pre-8.3 servers. [Dagfinn Ilmari Mannsåker] - Fix ASC_OR_DESC field in statistics_info [Dagfinn Ilmari Mannsåker] - Indicate NULL ordering in statistics_info [Dagfinn Ilmari Mannsåker] Version 3.11.1 (released April 28, 2020) - Adjust Makefile to fix failing 'fulltest' target on BSD systems [Slaven Rezić] (RT ticket #132412) Version 3.11.0 (released April 23, 2020) - Indicate non-key index columns (INCLUDE) in statistics_info [Dagfinn Ilmari Mannsåker] - Return an empty result set instead of undef from statistics_info when the requested table doesn't exist and $unique_only is false. [Dagfinn Ilmari Mannsåker] - Fix segfault during st destroy [Gregory Oschwald] (Github pull request #66) (Github issue #57) - Improve testing for table_info() [Greg Sabino Mullane] (Github issue #67) - Improve UTF-8 wording in docs [Felipe Gasper] (Github pull request #65) Version 3.10.5 (released March 23, 2020) - Minor adjustment for Windows build (RT ticket #131752) - Allow test suite to work on an EnterpriseDB server [H.Merijn Brand] (RT ticket #132203) - Add small warning regarding ShowErrorStatement (RT ticket #120268) Version 3.10.4 (released February 3, 2020) - Allow localtime from Time::Piece to be used directly as a bind value again. This applies to all "magical" arrays. [Greg Sabino Mullane] (Github issue #63) - Force tests to NOT run in parallel. [Greg Sabino Mullane] (RT ticket #130834) Version 3.10.3 (released January 20, 2020) - Set things cleared via PQclear to NULL as soon as possible, to remove race conditions [Greg Sabino Mullane] (RT ticket #131522) Version 3.10.2 (released January 17, 2020) - Adjust tests to pass on 32-bit machines [Greg Sabino Mullane] (RT ticket #131482) Version 3.10.1 (released January 13, 2020) - Prevent double-free memory errors [Greg Sabino Mullane] (RT ticket #130681) - Fix crash when pg_error_field is called [Greg Sabino Mullane] (RT ticket #130721) - Update the list of Postgres reserved words in quote.c Version 3.10.0 (released September 3, 2019) - Prevent memory leak related to pg_error_field [Greg Sabino Mullane] (RT ticket #130430) - Fix for bug by making sure pg_error_field works properly when switching between do-with-params and do-without-params. [Greg Sabino Mullane] (Github issue #57) - If a commit or rollback fails, do not set BegunWork [Greg Sabino Mullane] (Github issue #40) - Treat partitioned tables same as regular tables for column_info, table_info, and foreign_key_info (i.e. support pg_class.relkind = 'p') [Octavian R. Corlade] (Github pull request #55) - Allow last_insert_id() to work against inherited tables [Greg Sabino Mullane] (RT ticket #52441) - Add DBI SQL_BLOB, SQL_BINARY and SQL_LONGVARBINARY types as alias for PG_BYTEA [Pali] (Github pull request #58) Version 3.9.1 (released August 15, 2019) - Bug fix for pg_error_field: make sure we do not feed null to newSVpv, handle older versions of Postgres better. [Greg Sabino Mullane] Version 3.9.0 (released August 13, 2019) - ShowErrorStatement works for "quickexec" do() calls [Dmitry Karasik] (RT ticket #120268) (Github issue #44) - Add :pg_limits to add constants such as PG_MAX_SMALLINT [Greg Sabino Mullane] (Github issue #51) - Add $dbh->pg_error_field() function [Greg Sabino Mullane] - Fix failing tests due to incorrect 'initdb' check [Greg Sabino Mullane] (Github issue #54) (RT ticket #130279) Version 3.8.1 (released July 6, 2019) - Fix encoding of SQL_VARBINARY type in $dbh->quote() function [Pali] - Fix encoding in $dbh->do() function [Pali] (RT ticket #122991) - Fix E'' string escape handling on architectures with unsigned chars (Github issue #46) - Minor fix to allow DBD::Pg to connect to internal 'pgbouncer' database that is created by PgBouncer [Greg Sabino Mullane] (Github issue #47) - Fix so table_info test works on non-empty databases [Matt Buchanan] (RT ticket #127906) Version 3.8.0 (released April 25, 2019) - Increase minimum supported PostgreSQL version to 8.0 [Dagfinn Ilmari Mannsåker] - Add support for foreign tables in table_info() and column_info() [Dagfinn Ilmari Mannsåker] - Return the current database name as TABLE_CAT in info methods [Dagfinn Ilmari Mannsåker] - Handle backslash-escaped quotes in E'' strings [Dagfinn Ilmari Mannsåker] - Fix typo in Makefile.PL (RT ticket #127097) - Fix parsing of PostgreSQL versions >= 10 on Debian/Ubuntu [Dagfinn Ilmari Mannsåker] - Fix client_min_messages=FATAL test when PostgreSQL caps it to ERROR [Dagfinn Ilmari Mannsåker] (RT ticket #128529) - Fix ->ping error detection on PostgreSQL 12 [Dagfinn Ilmari Mannsåker] - Adjust tests for new pg_ctl output [Erik Rijkers er at xs4all.nl] (RT ticket #128966) - Adjust tests for removal of WITH OIDS in PostgreSQL 12 [Dagfinn Ilmari Mannsåker] - Fix support for PostgreSQL versions back to 8.0 [Dagfinn Ilmari Mannsåker] - Remove usage of deprecated pg_attrdef.adsrc and pg_constraint.consrc columns [Dagfinn Ilmari Mannsåker] - Fix typo in pg_placeholder_colons example (Github issue #41) - Support GENERATED ... AS IDENTITY columns in last_insert_id() [Dagfinn Ilmari Mannsåker] Version 3.7.4 (released February 12, 2018) - Fix typo in META.yml (RT ticket #124405) Version 3.7.3 (released February 12, 2018) - Test tweak so we don't try to use jsonb on older versions. (RT ticket #124934) Version 3.7.2 (released February 11, 2018) - Remove Data::Peek dependency accidentally left in t/12placeholders.t (RT ticket #124393) Version 3.7.1 (released February 11, 2018) - Fixed problem when using placeholders and escaped question marks, the recopied string was not terminated correctly. [Greg Sabino Mullane] (Github issue #33) (RT tickets #121630, #123187, #123999) - Make sure nulls in our self-generated arrays are not set as read-only in some Perls. [Greg Sabino Mullane] (RT ticket #107556) - If the server returns no error message, and an "unknown" code from libpq, supply a custom message mentioning client_min_messages may be to blame. [Greg Sabino Mullane] (RT ticket #109591) - Declare VERSION with 'our' in seldom-used Bundle module (RT ticket #123218) Version 3.7.0 (released September 24, 2017) - If no placeholders, use PQexec instead of PQexecParams [Greg Sabino Mullane] - Fix running tests with non-UTF8 server_encoding [Dagfinn Ilmari Mannsåker] (Github issue #26) - Fix crash with missing client_encoding [David Christensen, reported by Marko Tiikkaja] (Github issue #29) - Fix crash with missing server_version [David Christensen] - Fix leak in ->state methods [Dagfinn Ilmari Mannsåker] (Github issue #30) - Add $sth->{pg_async_status} to determine async status of a statement handle. Values can be 0 (no async), 1 (async), or -1 (cancelled) [Greg Sabino Mullane, as requested by Dmytro Zagashev (ZDM)] (RT ticket #116172) Version 3.6.2 (released May 23, 2017) - Remove errant debugging aid from test suite Version 3.6.1 (released May 22, 2017) - Various fixes to support testing against Postgres 10beta [David Christensen] Version 3.6.0 (released April 17, 2017) - Make sure we do not inadvertently modify the string passed to prepare() when doing the new backslash escape manipulation. [Greg Sabino Mullane] (RT ticket #114000) - Fix bug where $DBD::Pg::DBDPG_DEFAULT not picked up as a magic string first time it is used in a script. [Greg Sabino Mullane] (RT ticket #112309) - Fix UTF8 flag handling in pg_(get|put)copydata [Dagfinn Ilmari Mannsåker] - Fix UTF8 double-encoding with pg_enable_utf8 = 0 [Serge Pushkin] (RT ticket #103137) - Fix bug in quote_name which would fail to quote in some circumstances (Github issue #22) - Allow clean parsing of new Postgres X.Y version format [Erik Rijkers er at xs4all.nl] - Add pg_canonical_ids() and pg_canonical_names(), which returns information about each column in the result set. [Warstone warstone at list.ru] (RT ticket #106858) - Map SQL_NUMERIC to PG_NUMERIC (instead of PG_FLOAT8) [Alice Maz alice at alizemaz.com] (RT ticket #120358) - Force real, float, and double precision into SvNVs [Greg Sabino Mullane] (RT ticket #113683 and other places) - Support for number of rows greater than an "int". Requires support for same from a future version of libpq before it will work completely. [Greg Sabino Mullane] (RT ticket #102444) - Fix skipped test counts in Win32 builds [Andy Grundman] - Allow tests to work against Postgres 8.4 by tweaking client_encoding calls. [Pavel Raiskup praiskup at redhat.com] (RT ticket #116179) - Silence warnings in t/02attribs.t and t/04misc.t [Dagfinn Ilmari Mannsåker] - Support binary COPY format [Dagfinn Ilmari Mannsåker] - Ensure tests do not use $ENV{PGSERVICE} or $ENV{PGDATABASE} [Erik Rijkers] - Switched canonical repo to git://github.com/bucardo/dbdpg.git Version 3.5.3 (released October 1, 2015) - Minor fix in the test file t/03dbmethod.t Version 3.5.2 (released September 29, 2015) - Fix enum value ordering on Postgres servers 9.1 and greater [Dagfinn Ilmari Mannsåker] - Return bigint values as plain integer values when they fit [Dagfinn Ilmari Mannsåker] - Fix typo in sprintf for get_info() SQL_DATA_SOURCE_NAME [Craig A. James] (RT ticket #106604) - Set the repository in META.yml to github Version 3.5.1 (released February 17, 2015) - Prevent core dump if the second argument to the quote() method is anything but a hashref [Greg Sabino Mullane] (RT ticket #101980) - Better "support" for SQL_ASCII servers in the tests. Allow env var DBDPG_TEST_ALWAYS_ENV to force use of DBI_DSN and DBI_USER in tests. [Greg Sabino Mullane] - Fix client_encoding detection on pre-9.1 servers [Dagfinn Ilmari Mannsåker] - Fix operator existence check in tests on pre-8.3 servers [Dagfinn Ilmari Mannsåker] - Documentation fix [Stuart A Johnston] - Fix pg_switch_prepared database handle documentation [Dagfinn Ilmari Mannsåker] Version 3.5.0 (released January 6, 2015) - Allow "placeholder escaping" by the use of a backslash directly before it, e.g. "SELECT 1 FROM jsontable WHERE foo \\? ?" will contain a single placeholder, and the first question mark will be sent directly to the backend to be parsed as an operator. [Greg Sabino Mullane, Tim Bunce] (RT ticket #101030) - Improve the workings of the ping() method, so it always tests for a valid database backend and returns the correct true/false. [Greg Sabino Mullane, with help from Andrew Gierth and Tim Bunce] (RT ticket #100648) - Add get_info(9000) => 1 to indicate driver can escape placeholders. [Tim Bunce] - In tests, force the client_encoding to UTF8, skip tests that involve characters not supported by the server_encoding [Dagfinn Ilmari Mannsåker] - Fix memory leak when selecting from arrays [Dagfinn Ilmari Mannsåker, reported by Krystian Samp] - Make get_info much more efficient and slightly simpler. [Tim Bunce] Version 3.4.2 (released September 25, 2014) - Fix bug where single-quoted type arguments to the table_info() method were causing a SQL error. [Greg Sabino Mullane] (RT ticket #99144) Version 3.4.1 (released August 20, 2014) - Allow '%' again for the type in table_info() and thus tables() It's not documented or tested in DBI, but it used to work until DBD::Pg 3.4.0, and the change broke DBIx::Class::Schema::Loader, which uses type='%'. [Dagfinn Ilmari Mannsåker] Version 3.4.0 (released August 16, 2014) - Cleanup and improve table_info() [Mike Pomraning ] (Github issue #7) Method table_info() type searching now supports TABLE, VIEW, SYSTEM TABLE, SYSTEM VIEW, and LOCAL TEMPORARY Method table_info() object searching fully supports the above types. Method table_info() object searching no longer ignores invalid types - a filter of 'NOSUCH' will return no rows, and 'NOSUCH,LOCAL TEMPORARY' will return only temp objects. Method tableinfo() type filters are strictly matched now ... previously a search for SYSTEM TABLE would have fetched plain TABLE objects. Method table_info() now treats temporary tables and temporary views as LOCAL TEMPORARY - Make sure column_info() and table_info() can handle materialized views. [Greg Sabino Mullane] (RT ticket #97032) Version 3.3.0 (released May 31, 2014) - Major cleanup of UTF-8 support: Fix quoting of UTF-8 values Add support for UTF-8 statement strings Fix UTF-8 support in placeholders and return values [Dagfinn Ilmari Mannsåker] (RT tickets #95214 and #91655) - Test that the Pg server agrees with us about the lengths of input strings. Refactor Unicode test to use anon hashes to describe the tests to run. Test pg_enable_utf8 of -1, in addition to 0 and 1. Extend the Unicode round-trip tests to verify ASCII, BMP and non-BMP code points. Test that characters created in the server reach the client correctly. [Nicholas Clark] - Rewrite foreign_key_info to be just one query [Dagfinn Ilmari Mannsåker] - Remove ODBC support from foreign_key_info [Dagfinn Ilmari Mannsåker] - Remove use of dTHX in functions in quote.c and types.c [Nicholas Clark] Version 3.2.1 (released May 20, 2014) - Stricter testing for array slices: disallow number-colon-number from being parsed as a placeholder. [Greg Sabino Mullane] (RT ticket #95713) - Fix for small leak with AutoInactiveDestroy [David Dick] (RT ticket #95505) - Adjust test regex to fix failing t/01_connect.t on some platforms [Greg Sabino Mullane] - Further tweaks to get PGINITDB working for test suite. [Nicholas Clark] Version 3.2.0 (released May 15, 2014) - Add new attribute pg_placeholder_nocolons to turn off all parsing of colons into placeholders. [Graham Ollis] (RT ticket #95173) - Fix incorrect skip count for HandleSetErr [Greg Sabino Mullane] (RT ticket #94841) - Don't attempt to use the POSIX signaling stuff if the OS is Win [Greg Sabino Mullane] (RT ticket #94841) - Fix missing check for PGINITDB in the test suite. [Nicholas Clark] Version 3.1.1 (released April 6, 2014) - Minor adjustments so tests pass in varying locales. Version 3.1.0 (released April 4, 2014) - Make sure UTF-8 enabled notifications are handled correctly [Greg Sabino Mullane] - Allow "WITH" and "VALUES" as valid words starting a DML statement [Greg Sabino Mullane] (RT ticket #92724) Version 3.0.0 (released February 3, 2014) - Major change in UTF-8 handling. If client_encoding is set to UTF-8, always mark returned Perl strings as utf8. See the pg_enable_utf8 docs for more information. [Greg Sabino Mullane, David E. Wheeler, David Christensen] - Bump DBI requirement to 1.614 - Bump Perl requirement to 5.8.1 - Add new handle attribute, switch_prepared, to control when we stop using PQexecParams and start using PQexecPrepared. The default is 2: in previous versions, the effective behavior was 1 (i.e. PQexecParams was never used). [Greg Sabino Mullane] - Better handling of items inside of arrays, particularly bytea arrays. [Greg Sabino Mullane] (RT ticket #91454) - Map SQL_CHAR back to bpchar, not char [Greg Sabino Mullane, reported by H.Merijn Brand] - Do not force oids to Perl ints [Greg Sabino Mullane] (RT ticket #85836) - Return better sqlstate codes on fatal errors [Rainer Weikusat] - Better prepared statement names to avoid bug [Spencer Sun] (RT ticket #88827) - Add pg_expression field to statistics_info output to show functional index information [Greg Sabino Mullane] (RT ticket #76608) - Adjust lo_import_with_oid check for 8.3 (RT ticket #83145) - Better handling of libpq errors to return SQLSTATE 08000 [Stephen Keller] - Make sure CREATE TABLE .. AS SELECT returns rows in non do() cases - Add support for AutoInactiveDestroy [David Dick] (RT ticket #68893) - Fix ORDINAL_POSITION in foreign_key_info [Dagfinn Ilmari Mannsåker] (RT ticket #88794) - Fix foreign_key_info with unspecified schema [Dagfinn Ilmari Mannsåker] (RT ticket #88787) - Allow foreign_key_info to work when pg_expand_array is off [Greg Sabino Mullane and Tim Bunce] (RT ticket #51780) - Remove math.h linking, as we no longer need it (RT ticket #79256) - Spelling fixes (RT ticket #78168) - Better wording for the AutoCommit docs (RT ticket #82536) - Change NOTICE to DEBUG1 in t/02attribs.t test for handle attribute "PrintWarn": implicit index creation is now quieter in Postgres. [Erik Rijkers] - Use correct SQL_BIGINT constant for int8 [Dagfinn Ilmari Mannsåker] - Fix assertion when binding array columns on debug perls >= 5.16 [Dagfinn Ilmari Mannsåker] - Adjust test to use 3 digit exponential values [Greg Sabino Mullane] (RT ticket #59449) - Avoid reinstalling driver methods in threads [Dagfinn Ilmari Mannsåker] (RT ticket #83638) - Make sure App::Info does not prompt for pg_config location if AUTOMATED_TESTING or PERL_MM_USE_DEFAULT is set [David E. Wheeler] (RT ticket #90799) - Fix typo in docs for pg_placeholder_dollaronly [Bryan Carpenter] (RT ticket #91400) - Cleanup dangling largeobjects in tests [Fitz Elliott] (RT ticket #92212) - Fix skip test counting in t/09arrays.t [Greg Sabino Mullane] (RT ticket #79544) - Explicitly specify en_US for spell checking [Dagfinn Ilmari Mannsåker] (RT ticket #91804) Version 2.19.3 (released August 21, 2012) - Fix bug in pg_st_split_statement causing segfaults (RT ticket #79035) - Make sure table_info() and other functions use pg_tablespace_location() instead of spclocation for Postgres servers 9.2 and greater. [Greg Sabino Mullane + others] (RT ticket #77042) Version 2.19.2 (released March 12, 2012) - Fix errors when multiple same-named placeholders are used. [Greg Sabino Mullane] (RT ticket #75713) Version 2.19.1 (released March 10, 2012) - Fix crash when passing in an array with undefined elements. [Greg Sabino Mullane] Version 2.19.0 (released March 9, 2012) - Use proper formatting for warn() and croak() [Niko Tyni] (RT ticket #75642) - Fix localized regex in test (RT ticket #70759) - Fix for named placeholders [Jan Pazdziora] (RT ticket #70953) - Various fixes to the array-marshaling code [Noah Misch, Mark Stosberg, and David Christensen] (RT ticket #58552) - Allow hi-bit chars in dollar-quoted identifiers [David Christensen] (RT ticket #73832) - Have do() return count for things such as CREATE TABLE .. AS SELECT Will only work on 9.0 or better. [Pavel Stehule] (RT ticket #71073) - Better error message when trying to do things post-disconnect [Greg Sabino Mullane] - Always respect pg_server_prepare=0 by using PQexec not PQexecParams. [Greg Sabino Mullane] - Fix error in async docs (RT ticket #72812) - Switch from subversion to git Install with: git clone git://bucardo.org/dbdpg.git [Greg Sabino Mullane] Version 2.18.1 (released May 9, 2011) - Fix LANG testing issue [Greg Sabino Mullane] (RT ticket #56705) - Fix bug when async commands issued immediately after a COPY. [Greg Sabino Mullane] (RT ticket #68041) Version 2.18.0 (released March 28, 2011) - Thanks to 123people.com for sponsoring work on this release [Greg Sabino Mullane] - New cancel() method per DBI spec. [Eric Simon] (RT ticket #63516) - Fix memory leak when binding arrays [Greg Sabino Mullane] (RT ticket #65734) - Fix memory leak with ParamValues. [Martin J. Evans] (RT ticket #60863) - Fix memory leak in handle_old_async (missing PQclear) [Rainer Weikusat] (RT ticket #63408) - Fix memory leak in pg_db_cancel (missing PQclear) [Rainer Weikusat] (RT ticket #63441) - Mark pg_getcopydata strings as UTF8 as needed (RT ticket #66006) - Function dequote_bytea returning void should not try to return something [Dagobert Michelsen] (RT ticket #63497) - Fix the number of tests to skip in t/01connect.t when the $DBI_DSN environment variable lacks a database specification. [David E. Wheeler] - Fix algorithm for skipping tests in t/06bytea.t when running on a version of PostgreSQL lower than 9.0. [David E. Wheeler] - Small tweaks to get tests working when compiled against Postgres 7.4 [Greg Sabino Mullane] (RT ticket #61713) - Fix failing test when run as non-superuser [Greg Sabino Mullane] (RT ticket #61534) Version 2.17.2 (released November 21, 2010) - Support dequoting of hex bytea format for 9.0. [Dagfinn Ilmari Mannsåker] (RT ticket #60200) - Don't PQclear on execute() if there is an active async query [rweikusat at mssgmbh.com] (RT ticket #58376) - Allow data_sources() to accept any case-variant of 'dbi:Pg' (RT ticket #61574) - Fix failing test in t/04misc.t on Perl 5.12. [Eric Simon] - Fix for some 7.4 failing tests [Dagfinn Ilmari Mannsåker] - Return bare instead of undef in test connections (RT ticket #61574) Version 2.17.1 (released April 8, 2010) - Only use lo_import_with_oid if Postgres libraries are 8.4 or better [Greg Sabino Mullane] (RT ticket #56363) Version 2.17.0 (released April 6, 2010) - Do not automatically ROLLBACK on a failed pg_cancel [Greg Sabino Mullane] (RT ticket #55188) - Added support for new lo_import_with_oid function. [Greg Sabino Mullane] (RT ticket #53835) - Don't limit stored user name to \w in tests [Greg Sabino Mullane] (RT ticket #54372) - Allow tests to support versions back to Postgres 7.4 [Greg Sabino Mullane] Version 2.16.1 (released January 20, 2010) - Output error messages in UTF-8 as needed. Reported by Michael Hofmann. [Greg Sabino Mullane] (RT ticket #53854) Version 2.16.0 (released December 17, 2009) - Put in a test for high-bit characters in bytea handling. [Bryce Nesbitt] (RT ticket #39390) - Better SQLSTATE code on connection failure [Chris Travers with help from Andrew Gierth] (RT ticket #52863) - Fixed POD escapes [FWIE at cpan.org] (RT ticket #51856) Version 2.15.1 (released August 7, 2009) - Release to fix the SIGNATURE file. [Greg Sabino Mullane] Version 2.15.0 (released August 4, 2009) - Use PQexecPrepared even when no placeholders [Greg Sabino Mullane] (RT ticket #48155) - Allow execute_array and bind_param_array to take oddly numbered items, such that DBI will make missing entries undef/null [Greg Sabino Mullane] (RT ticket #39829) - Put single quotes around array literals when quoting arrays via the quote() method. Per report from David Garamond [Greg Sabino Mullane] (RT ticket #48420) Version 2.14.1 (released July 28, 2009) - Remove invalid bigint assignment [Tim Bunce] Version 2.14.0 (released July 27, 2009) - Make quoting of int, floats, and names much safer. [Greg Sabino Mullane] (RT ticket #41565) - Make quoting of geometric types respect all valid chars [Greg Sabino Mullane] (RT ticket #41565) - Fix quoting of booleans to respect more Perlish variants [Greg Sabino Mullane] (RT ticket #41565) - Return ints and bools-cast-to-number from the db as true Perlish numbers. [Greg Sabino Mullane] (RT ticket #47619) - Fix backslash quoting of arrays [Greg Sabino Mullane] (RT ticket #46732) - Fix error when destringifying array starting with '[x:y]='. Per report from Jeff Trout [Greg Sabino Mullane] - Fix problem with foreign_key_info() and NAME_uc [Greg Sabino Mullane] (RT ticket #46109) - Make foreign_key_info() respect FetchHashKeyName [Greg Sabino Mullane] (RT ticket #46103) - Fix Makefile.PL to apply POSTGRES_INCLUDE in a saner way. [GAURAV at cpan.org] (RT ticket #45769) - Improve Win32 README notes [Curtis Jewell] - Fix spelling error in type_info [justin.d.hunter at gmail.com] (RT ticket #47786) - Add functions to support MS VC++ 7.0 [Taro Nishino] (RT ticket #47858) Version 2.13.1 (released April 23, 2009) - Fix leak in pg_warn [rweikusat at mssgmbh.com] (RT ticket #45163) Version 2.13.0 (released April 13, 2009) - Ensure we always set sqlstate inside of pg_st_prepare_statement [rweikusat at mssgmbh.com] (RT ticket #44732) - When libpq has a connection error, return SQLSTATE 08000 ( "CONNECTION EXCEPTION" ) instead of the more generic 02000 ( "DATA EXCEPTION" ) [rweikusat at mssgmbh.com] (RT ticket #44744) - Fix minor Perl::Critic nags (RT ticket #44704) (Debian bug #521969) [Greg Sabino Mullane] - Clarify change of $dbh->{Name} behavior [Greg Sabino Mullane] (RT ticket #44985) Version 2.12.0 (released March 28, 2009) - Change large object interface from lo_* to pg_lo_* and make them accessible via direct $dbh calls (e.g. $dbh->pg_lo_import instead of $dbh->func(..,'pg_lo_import'). The use of $dbh->func(... 'lo_*') is deprecated. [Greg Sabino Mullane] (RT ticket #44467) - Throw an exception for large_object functions called when AutoCommit is on, but allow pg_lo_import and pg_lo_export to work. Reported by Kynn Jones. [Greg Sabino Mullane] (RT ticket #44461) - Fix a memory leak when parsing returned arrays. Reported by Bálint Szilakszi. [Greg Sabino Mullane] (RT ticket #44225) - Do proper dequoting of boolean arrays [Armando Santos, Greg Sabino Mullane] (RT ticket #43768) - Use pg_get_expr in column_info when available [Adam Sjøgren] - Fix minor bugs in POD docs. [Frank Wiegand] (RT ticket #44242) - Fix minor bug in POD docs. [Tim Mattison] Version 2.11.8 (released December 28, 2008) - Fix minor bug in t/12placeholders.t test (RT ticket #41723) Version 2.11.7 (released December 13, 2008) - Fix placeholder parsing logic (RT ticket #41582) Version 2.11.6 (released November 30, 2008) - Only set UTF8 flag on array items after UTF8 test. [Armando Santos] (RT ticket #41253) Version 2.11.5 (released November 24, 2008) - Clear prepared_statement name on failure to prepare: prevents the wrong error when using prepare_cached. [Greg Sabino Mullane] Version 2.11.4 (released November 12, 2008) - Don't set LC_MESSAGES unless superuser in tests. Remove all language-specific string checking for tests. (RT ticket #40604) Version 2.11.3 (released November 3, 2008) - Force LC_MESSAGES to 'C' inside tests (RT ticket #40604) - Minor compiler tweaks. - Fix small POD error (RT ticket #40209) - Tweak Perl::Critic policy list (RT ticket #40130) Version 2.11.2 (released October 15, 2008) - Fix core dump when invalid placeholders used. [Greg Sabino Mullane] (RT ticket #40075) Version 2.11.1 (released October 14, 2008) - Attribute $sth->{ParamTypes} returns 'TYPE' when possible. Version 2.11.0 (released October 13, 2008) - Attribute $sth->{ParamTypes} now returns a hashref per the DBI docs. [Greg Sabino Mullane] - Adjustment of Makefile.PL to fix problem with Strawberry Perl. Thanks to Martin Evan and Brian on the dbi-users list. Version 2.10.7 (released September 22, 2008) - Fix test issue when dbname contains dashes. [Rainer Tammer] - Revert META.yml to 1.0, until such time as tools can handle 1.1 [Taro Nishino] (RT ticket #39461) Version 2.10.6 (released September 19, 2008) - Correctly quote all bytea characters. [Rod Taylor] (RT ticket #39390) - Prevent core dump when checking $dbh->{standard_conforming_strings} on older servers. [Greg Sabino Mullane] - Skip unicode tests if server is set to 'LATIN1' [Greg Sabino Mullane] Version 2.10.5 (released September 16, 2008) - Fix SIGNATURE file Version 2.10.4 (released September 16, 2008) - Force use of math library when compiling. Per report of AIX problems by Rainer Tammer. Version 2.10.3 (released August 31, 2008) - Previous version had wrong SIGNATURE file Version 2.10.2 (released August 31, 2008) - Fix minor problem in t/99_yaml.t Version 2.10.1 (released August 31, 2008) - Minor testing fix. Version 2.10.0 (released August 26, 2008) - Add the 'DBD' trace setting to output only non-DBI trace messages, and allow 'dbd_verbose' as a connection attribute for the same effect. [Greg Sabino Mullane] - Fix a minor problem with testing against 7.4 databases [Greg Sabino Mullane] - Allow multi-statement do() calls with parameters to work if pg_server_prepare is set to 0 [Greg Sabino Mullane] (RT ticket #38623) Version 2.9.2 (released August 18, 2008) - Empty Postgres arrays should return empty Perl arrays, not undef. [David E. Wheeler] (RT ticket #38552) Version 2.9.1 (released August 17, 2008) - Return undef when mapping Postgres array to Perl array and the array is empty '{}' [Greg Sabino Mullane] (RT ticket #38552) - Minor documentation improvements. [Greg Sabino Mullane] Version 2.9.0 (released August 3, 2008) - Add support for database handle attribute "ReadOnly". This allows use of $dbh->{ReadOnly} = 1 to enforce read only mode at the server level. [Greg Sabino Mullane] - Move PQexec structures to statement handle, to prevent excessive malloc and free within execute function. [Greg Sabino Mullane] - Add more attribute tests, improve testing system. [Greg Sabino Mullane] - Many documentation improvements. [Greg Sabino Mullane] - Win32 build improvements [T.J. Ferraro] Version 2.8.8 (released December 17, 2009) - Security release to fix high bit character problem in bytea (RT ticket #51153) (Debian bug #554489) Version 2.8.7 (released July 24, 2008) - Modify test scripts to work better on FreeBSD boxes. [Greg Sabino Mullane] - Much documentation improvement and POD tweaking. [Greg Sabino Mullane] Version 2.8.6 (released July 21, 2008) - More testing improvements to increase odds of all tests being run, especially when testing as root. [Greg Sabino Mullane] Version 2.8.5 (released July 13, 2008) - Fix an obscure bug in which a coredump occurs if client_min_messages is set to DEBUG3 or greater, and we then exit without disconnecting while AutoCommit is off. The new behavior is to simply not attempt to output the debugging information about the final 'rollback'. [Greg Sabino Mullane] - More documentation improvements. [Greg Sabino Mullane] Version 2.8.4 (released July 10, 2008) - Minor Perl::Critic test adjustments. [Greg Sabino Mullane] - Documentation enhancements. [Greg Sabino Mullane] - Yet more minor testing tweaks. [Greg Sabino Mullane] Version 2.8.3 (released July 6, 2008) - Minor testing functionality tweaks, lots of test cleanups, minor doc enhancements. [Greg Sabino Mullane] Version 2.8.2 (released June 29, 2008) - Minor testing tweaks, doc fixes. [Greg Sabino Mullane] Version 2.8.1 (released June 11, 2008) - Force testing to use a custom socket dir, to avoid permission problems. Thanks to Frank Wiegand for help in uncovering this. [Greg Sabino Mullane] Version 2.8.0 (released June 1, 2008) - Added in payload strings for LISTEN/NOTIFY in 9.0 via $dbh->pg_notifies() [Greg Sabino Mullane] - Fixed problem preventing some pg_type bind_arrays from working [Greg Sabino Mullane] - Fix tests in t.04misc.t to handle Windows newlines. [Ian Macdonald] (RT ticket #36237) - Clean up get_info() information. [Greg Sabino Mullane] Version 2.7.2 (released May 14, 2008) - Handle embedded commas in quotes properly when destringifying arrays. [Greg Sabino Mullane] (RT ticket #35862) - Fix typo in docs with trace_parser_flags() [Martin J. Evans] - More testing tweaks [Greg Sabino Mullane] Version 2.7.1 (released May 11, 2008) - Yet more minor testing tweaks. [Greg Sabino Mullane] Version 2.7.0 (released May 10, 2008) - Have $dbh->quote() return E'' when server is >= 8.1 and string contains backslashes. Fixes any problems with standard_conforming_strings. [Greg Sabino Mullane] (RT ticket #27538) Version 2.6.6 (released May 7, 2008) - Fix minor problem in t/99_spellcheck.t [Greg Sabino Mullane] Version 2.6.5 (released May 7, 2008) - Add spell checker to tests. [Greg Sabino Mullane] - More tweaks to the testing suite. [Greg Sabino Mullane] Version 2.6.4 (released May 2, 2008) - More tweaks to the test suite. [Greg Sabino Mullane] Version 2.6.3 (released May 1, 2008) - Minor tweaks to the test suite. [Greg Sabino Mullane] Version 2.6.2 (released April 30, 2008) - Fix coredump when pg_getcopydata copies 0 rows into a freshly created var. [David Harris] (RT ticket #35556) - Allow 'make test' create a test database from scratch if it cannot find an existing one to use. [Greg Sabino Mullane] Version 2.6.1 (released April 22, 2008) - Don't free placeholder section, fixes problem when using more than one named placeholder with the same name. [Greg Sabino Mullane] (RT ticket #35303) Version 2.6.0 (released April 16, 2008) - Make pg_notifies a true function, so that you can now use $dbh->pg_notifies instead of $dbh->func('pg_notifies') [Greg Sabino Mullane] - Various performance improvements [Greg Sabino Mullane] - Fix minor build and compilation issues with Strawberry Perl [Greg Sabino Mullane] - Add Bundle::DBD::Pg [Greg Sabino Mullane] Version 2.5.1 (released April 7, 2008) - Correctly handle negative PID numbers on Win32 systems when generating prepared statement names [Greg Sabino Mullane] (RT ticket #34738) Version 2.5.0 (released March 23, 2008) - Add pg_enum_values to $dbh->column_info() [Dave Rolsky] (RT ticket #34351) - Minor test fixes. [Greg Sabino Mullane] Version 2.4.0 (released March 21, 2008) - Remove problematic and unneeded Test::Warn test from 00basic.t. - Add $sth->{pg_current_row} [Greg Sabino Mullane] Version 2.3.0 (released March 19, 2008) - Add $sth->{pg_bound} and $sth->{pg_numbound} [Greg Sabino Mullane] - Fix broken call to $sth->{pg_segments} [Greg Sabino Mullane] Version 2.2.2 (released March 3, 2008) - Remove non-working tracing from types.c and quote.c [Greg Sabino Mullane] - Add parse_trace_flag as statement handle method. [Greg Sabino Mullane] Version 2.2.1 (released March 1, 2008) - Fix memory leaks in dbdimp.c [Alexey Tourbin] (RT ticket #33743) - Fix strlen problems in dbdimp.c [Alexey Tourbin] (RT ticket #33737) - Fix char count in Renew() [Alexey Tourbin] (RT ticket #33738) - Change local trace_flags to lowercase. [Greg Sabino Mullane] Version 2.2.0 (released February 27, 2008) - Introduce enhanced trace flags. See the documentation on parse_trace_flags() for details. [Greg Sabino Mullane] - Remove version.pm dependency from Makefile.PL (RT ticket #33429) Version 2.1.3 (released February 20, 2008) - Do not assume POSTGRES_LIB is a plain dirname, as it may have " -lssl". Version 2.1.2 (released February 19, 2008) - Do not build if environment variables POSTGRES_HOME, POSTGRES_LIB, or POSTGRES_INCLUDE are set but not valid. - Fix dependency requirements, especially version.pm [Greg Sabino Mullane] Version 2.1.1 (released February 19, 2008) - Better URLs to cpan.org resources. [Greg Sabino Mullane] Version 2.1.0 (released February 18, 2008) - Use version.pm [Greg Sabino Mullane] (RT ticket #33206) - Add PERL_NO_GET_CONTEXT #define to improve performance on threaded Perls [Greg Sabino Mullane] - Raise the minimum DBI version to 1.52. [Greg Sabino Mullane] - Allow arrayrefs into bind_col [Greg Sabino Mullane] (RT ticket #33193) - Remove '//' style comments to make strict ANSI compilers happy. [Trevor Inman] (RT ticket #33089) - Force client encoding of UTF8 for some tests. [Greg Sabino Mullane] - Make 03dbmethod.t pass minor test for version 8.1.9 (RT ticket #33282) [Greg Sabino Mullane] - Add a local copy of dbivport.h [Greg Sabino Mullane] Version 2.0.0 (released February 10, 2008) - Make minimum supported server 7.4. [Greg Sabino Mullane] - Overhaul COPY functions: deprecate pg_getline, pg_putline, and pg_endcopy. The new functions are pg_getcopydata, pg_getcopydata_async, pg_putcopydata, and pg_putcopyend. [Greg Sabino Mullane] - Add support for arrays: can pass in arrayrefs to execute, and they are automatically returned as arrays when fetching. [Greg Sabino Mullane] - Add support for asynchronous queries. [Greg Sabino Mullane] - Allow raw transaction statements through - in other words, do not croak if $dbh->prepare("COMMIT") is attempted. Not only was this a little too controlling, there is a growing host of other commands such as "COMMIT PREPARED" that we need to allow. [Greg Sabino Mullane] - Check transaction status after each command, to allow things such as 'PREPARE TRANSACTION' to work properly. [Greg Sabino Mullane] (RT ticket #32423) - Overhauled the data type system. [Greg Sabino Mullane] - Switch from cvs to subversion. Switch from gborg to perl.org. [Greg Sabino Mullane] - Change versioning system to three numbered system. [Greg Sabino Mullane] - Add $dbh->{pg_placeholder_dollaronly} to allow '?' and other symbols to be used in prepared statements without getting interpreted as placeholders, i.e. the geometric operator '?#' [Greg Sabino Mullane] (RT ticket #24124) - Fix memory leaks in bytea quoting and in pg_notifies. [Stephen Marshall smarshall at wsi.com] (RT ticket #21392) - Fix memory leak when using savepoints. [airwave at cpan.org] (RT ticket #29791) - Use adbin, not adsrc, when figuring out the sequence name for the last_insert_id() method. This allows the function to work properly if the sequence name is changed. Note that {pg_cache=>0} should be passed to the function if you expect this might happen. [Greg Sabino Mullane] (RT ticket #30924) - Use unsigned chars when parsing passed-in queries, preventing UTF-8 strings from ruining the prepare. UTF-16 may still cause problems. [Greg Sabino Mullane] (RT ticket #31577) - Fix crash when executing query with two placeholders side by side. Thanks to Daniel Browning for spotting this. [Greg Sabino Mullane] - Skip item if no matching key in foreign_key_info. [Greg Sabino Mullane] (RT ticket #32308) - Fix bug in last_insert_id. [orentocy at gmail.com] (RT ticket #15918) - Fix pg_description join in table_info(). [Max Cohan max at cohan.biz] - Make sure arrays handle UTF-8 smoothly [Greg Sabino Mullane] (RT ticket #32479) - Force column names to respect utf8-ness. Per report from Ch Lamprect. [Greg Sabino Mullane] - Make sure array items are marked as UTF as needed. [Greg Sabino Mullane] (RT ticket #29656) - Force SQL_REAL and SQL_NUMERIC to be float8 not float4. [Greg Sabino Mullane] (RT ticket #30010) - Allow objects with stringification overloading to work with quote(). [David E. Wheeler and Greg Sabino Mullane] (RT ticket #32868) - Use prepare_cached in last_insert_id function. (RT ticket #24313) - Switch from pow to powf to support AIX compiler issue. [Greg Sabino Mullane] (RT ticket #24579) - Complain loudly and fail to proceed if Makefile.PL finds no -lpq [Greg Sabino Mullane] - Add three new columns to column_info, to return unquoted version: pg_schema, pg_table, and pg_columns. Add all three to primary_key_info, and the first two to table_info [Greg Sabino Mullane] (RT ticket #20282) - Change $dbh->{User} to $dbh->{Username} [Greg Sabino Mullane] - Change $dbh->{Name} to return the entire DSN string, minus the 'dbi:Pg:' part. Thanks to Mark Stosberg for the idea. [Greg Sabino Mullane] - Allow data_sources to accept optional arguments. [Greg Sabino Mullane] - Add private_attribute_info() method. [Greg Sabino Mullane] - Add SQL_INTERVAL and others to types.c [Greg Sabino Mullane] - Added statistics_info function [Brandon Black blblack at gmail.com] - Be much more flexible in test connection options. [Greg Sabino Mullane] - Overhaul test suite, allow tests to be run individually. [Greg Sabino Mullane] - Support for named trace level 'SQL' [Greg Sabino Mullane] - Experimental support for bind_param_inout. [Greg Sabino Mullane] - Fix bad PG_INTEGER example in docs, thanks to Xavi Drudis Ferran. [Greg Sabino Mullane] (RT ticket #31545) - Fix META.yml file. [Greg Sabino Mullane] (RT ticket #25759) Version 1.49 (released May 7, 2006) - Thanks to Backcountry.com for sponsoring work on this release. [Greg Sabino Mullane] - Add the statement handle attribute ParamTypes, and fix an error in ParamValues. ParamTypes requires DBI 1.49 or better. [Greg Sabino Mullane] - Strip the final newline from error messages, so that die can add in the line number. [Greg Sabino Mullane] (RT ticket #18900) - Make workaround for PQresultErrorField not returning proper result when an error is set and we are connecting via TCP/IP. This allows correct $dbh->state() values. [Greg Sabino Mullane] - Fix incorrect quoting preventing compiling. (RT ticket #18640) - Add support for quoting and binding of geometric types: POINT, LINE, LSEG, BOX, PATH, POLYGON, and CIRCLE. Also added the TID type. [Greg Sabino Mullane] Version 1.48 (released April 5, 2006) - Bump minimum DBI version to 1.45 [Greg Sabino Mullane] (RT ticket #18260) - Fix typo in Pg.pm code [marc at sssonline.com] (RT ticket #18537) - Ensure begin_work is properly set before err. [Greg Sabino Mullane] (RT ticket #18387) - Force PQexecParams to only run with DML. [Greg Sabino Mullane] (RT ticket #18258) - Fix bytea encoding problem [Greg Sabino Mullane] (RT ticket #18264) - Add documentation about connection service files (pg_service.conf). [David Fetter] Version 1.47 (released March 20, 2006) - Fix problem with selecting arrays. [Greg Sabino Mullane] (RT tickets #18128 and #18177) - Fix problem with dollar-sign placeholders. [Greg Sabino Mullane] Version 1.46 (released March 16, 2006) - Fix problem with dollar-sign placeholders. [husseinp at gmail.com] (RT ticket #18209) Version 1.45 (released February 27, 2006) - Fix bug preventing bytea values over 20 characters from showing. Spotted by Igor Shevchenko. [Greg Sabino Mullane] Version 1.44 (released February 21, 2006) - Make sure pg_warn does not warn if the database attribute PrintWarn is off. [Tyler MacDonald tyler at yi.org] [Greg Sabino Mullane] - Add SIGNATURE file for Module::Signature verification. [Greg Sabino Mullane] - Fix error in documentation for pg_errorlevel. (RT ticket #17434) - Add experimental support for using DEFAULT values inside of execute with $DBDPG_DEFAULT. [Greg Sabino Mullane] - Return the proper SQLSTATE codes on connection failures. (RT ticket #17115) [Greg Sabino Mullane] - Fix parser to handle leading parens. (RT ticket #15481) [Greg Sabino Mullane] - Make statement handles destruction abort early if InactiveDestroy is set (RT ticket #14978) [Greg Sabino Mullane] - Make quote work properly for time/date types (RT ticket #15082) [Greg Sabino Mullane] - Ensure all lo_ functions begin a transaction as needed if they are the first action in a script (RT ticket #13810) [Greg Sabino Mullane] - Fix memory leak in dbdimp.c [Kenchi Sawada] - Fix memory leak in dbdimp.c [dmitri at karasik.eu.org] (RT ticket #16054) - Move package declaration lines to fix RPM parser problems [Greg Sabino Mullane] (RT ticket #14509) - Add support for dollar quoting [Greg Sabino Mullane] (RT ticket #13608) - Added $dbh->{pg_default_port} method [Greg Sabino Mullane] - Overhaul get_info data, add many more values [Greg Sabino Mullane] - Overhaul type_info data [Greg Sabino Mullane] (RT ticket #13806) - Rewrite some of the quoting functions, reduce dependence on libpq versions [Greg Sabino Mullane] - Rewrite and optimize the do() method. Should be much faster when called without placeholders. Thanks to Tom Lane for suggesting this. [Greg Sabino Mullane] - Double check PQserverVersion return and use alternate method if it returns 0 (RT ticket #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 (RT ticket #13942) [Greg Sabino Mullane] - Fix pg_notifies() bug [door at lcpi.ru] (RT ticket #14232) - Add pg_ping() method [Greg Sabino Mullane] - Make sure ping returns true, even if in failed transaction state (thanks to Bill Moseley) [Greg Sabino Mullane] - Fix COPY-related core dump [Greg Sabino Mullane] - Fix strncpy bug in quote.c (RT ticket #14897) [Jun Kuriyama] - Fix error in is_high_bit_set() (RT ticket #13406) [Alexey Tourbin] Version 1.43 (released June 23, 2005) - Added README.dev file. [Greg Sabino Mullane] - Fix statement-name related core dump. [Greg Sabino Mullane] - Ensure state() returns an empty string, not 00000 on success. [michael.bell at web.de of OpenCA] [Greg Sabino Mullane] (RT ticket #13237) - Fix rare core dump when $sth still in scope after disconnect [Greg Sabino Mullane] - Enhancements to README.win32 [fenlisesi at gmail.com] - Fix incorrect sprintf calls [Jakub Jelinek] (RT ticket #12204) - Fix get_info(18) ("ODBCVERSION") [szinger at lanl.gov] [Greg Sabino Mullane] (RT ticket #12968) Version 1.42 (released May 21, 2005) - Fix minor issues with copying and bytea quoting on older servers. Fix some other memory leaks. [Greg Sabino Mullane] - Fix backslash parsing in statements [felix.klee at inka.de] [Greg Sabino Mullane] (RT ticket #12870) - Make rollback/commit reset copy state [imb at rentrak.com] [Greg Sabino Mullane] (RT ticket #12866) - Make sure lo_creat issues a BEGIN if necessary [Greg Sabino Mullane] - Fix incorrect behavior when AutoCommit switched on (thanks to Vivek Khera) [Greg Sabino Mullane] (RT ticket #12748) - Have last_insert_id use set_err, not die (thanks to Alexandra Walford) [Greg Sabino Mullane] (RT ticket #12503) - Fixed tests to correctly handle older DBI versions reporting failures on last_insert_id() [jpo at di.uminho.pt] [Greg Sabino Mullane] (RT ticket #12204) - Re-enable REMARKS field on column_info (thanks to morni at cpan.org) (RT ticket #12399) [Greg Sabino Mullane] - Many minor compiler optimizations and cleanups [Greg Sabino Mullane] - 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 [Greg Sabino Mullane] Version 1.41 (released April 6, 2005) - Make sure tests remove all temporary tables. [Frank Bax] [Greg Sabino Mullane] - Preserve sqlstate if rolling back on deallocate, fix potential segfault. [Stephen Clouse] - Both commit and rollback now return true (thanks to ivan-dbdpg at 420.am) [Greg Sabino Mullane] (RT ticket #12004) - Overhaul and update COPY support; use new protocol. New dbh methods: pg_putline, pg_getline, pg_endcopy. [Greg Sabino Mullane] - Rewrote version detection code. Compiled version and target version are now available via $dbh->{pg_lib_version} and $dbh->{pg_server_version} [Greg Sabino Mullane] - Set our default type_id to 0, not 1043 (VARCHAR) when possible. Suggested by Abhijit Menon-Sen via David Wheeler. [Greg Sabino Mullane] - Add $dbh methods pg_savepoint(), pg_rollback_to(), and pg_release() [Stephen Clouse] [Greg Sabino Mullane] Version 1.40 (released February 22, 2005) - Raise required DBI version to 1.38 - Execute returns 0 (0E0) not -1 for successful DDL commands. [Robert Treat] [Greg Sabino Mullane] - Change all string lengths to use STRLEN [rink at stack.nl] - Added $dbh->pg_server_trace($fh) [Greg Sabino Mullane] - Added $dbh->{pg_errorlevel}. [Greg Sabino Mullane] - Fix utf8 quote() support [Dominic Mitchell ] - Added explicit support for types SQL_BOOLEAN, DATE, TIME, TIMESTAMP, and TIMESTAMPTZ. Return correct values for DATEOID and TIMEOID. [Greg Sabino Mullane] - Added tablespace support for table_info and primary_key_info. [Greg Sabino Mullane] - Added new attributes to $dbh: pg_db, pg_user, pg_pass, pg_host, pg_port, pg_options, pg_socket, pg_pid [Greg Sabino Mullane] - 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 [Greg Sabino Mullane] - Major overhaul of prepare/execute to handle new server-side prepare system. See Pg.pm for details. [Greg Sabino Mullane] - Make the tests honor the DBD_SCHEMA variable instead of assuming that the "public" schema is available. [Rainer Weikusat] - Cleanup of dbdimp.c: better error messages, ensure commit is only called once after a transaction fails. [Alexey Slynko] - The primary_key() method returns empty list not undef if no match. [Julian Mehnle] - Added the pg_protocol database handle attribute [Greg Sabino Mullane] - Changed "noprefix" to pg_noprefix Version 1.32 (released February 25, 2004) - Bug fix for memory allocation problems on win systems [Rafael Kitover ] - Rewrote the foreign_key_info() method to handle multi-column keys. [Greg Sabino Mullane] - 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. [Greg Sabino Mullane] - Switched commit behavior from commit->execute->begin to begin->execute->commit [xelah-junk at xelah.com] [Greg Sabino Mullane] - Made the _pg_use_catalog subroutine use {private_dbgpg}. [Greg Sabino Mullane] (RT ticket #4841) - Changed strdup to safemalloc/strcpy in dbdimp.c (RT ticket #4578) - Made the data_sources method escape the database names as needed. Added support for databases with spaces in their names. [Greg Sabino Mullane] - Added the "noprefix" attribute to prevent the tables() method from prepending the schema name. [Greg Sabino Mullane] - Rewrote the testing suite. Many more tests are performed. Servers with a low client_min_messages are handled correctly. [Greg Sabino Mullane] - Fixed bug causing '$\d' to be picked up as a placeholder. [Greg Sabino Mullane] (RT ticket #4799) - The pg_notifies() method now catches and reports when PQconsumeInput fails. [nmueller at cs.wisc.edu] (RT ticket #4027) - Enabled the "pg_bool_tf" database handle [Greg Sabino Mullane] - Added required fields to the type_info() method: SQL_DATA_TYPE, SQL_DATETIME_SUB, and INTERVAL PRECISION [Greg Sabino Mullane] - Fixed bug where the table_attributes() method was incorrectly removing the NULLABLE column. [Greg Sabino Mullane] - Fixed bug where case was not being preserved by the foreign_key_info() method [Greg Sabino Mullane] - Calling fetch on any column that had a type that did not have an entry in the type_info array would segfault DBD::Pg. [Rudy Lippan] (RT tickets #4818,4432) - 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 (RT ticket #4419) [Rudy Lippan] - Changed get_info(29) to return (") instead of (\") (RT ticket #4829) [Greg Sabino Mullane] Version 1.31 (released November 17, 2003) - Calling $dbh->{TYPE} now returns SQL_TYPE_TIMESTAMP instead of 1114 for timestamp columns. In 1.31_x {x| x<8} $sth->{TYPE} returned 0 [Joachim Hirche ] - Raised required versions to Perl 5.6.1 and DBI 1.35 - Fix syntax error related to pg_server_version (RT tickets #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 ] - The $dbh->prepare() method now rewrites the SQL statement into an internal form, stripping out comments and whitespace, and if PostgreSQL > 7.3 it 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::execute. - 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. - The pg_error() method removes newlines 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. - Fixed use of :veryverylongplaceholdername - The quote() method is now in C and uses same code as bind_param. - Quoting and dequoting now use libpq quoting functions where available - The bind_param() method 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 [Greg Sabino Mullane] - 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] - Fixed column_info so REMARKS field works properly [Mark Stosberbg] - Various fixes to column_info: COLUMN_DEF, COLUMN_SIZE - The pg_constraint column added to display column constraints - The make test command is now more intelligent and will bail out early if db connection fails. [Greg Sabino Mullane] Version 1.22 (released March 26, 2003) - Win32 compile fix for snprintf [Joe Spears] - Fix memory allocation problem in bytea escaping [Barrie Slaymaker] - Add utf8 support [Dominic Mitchell ] - Transform Perl arrays into PostgreSQL arrays [Alexey Slynko] - Fix for foreign_key_info() [Keith Keller] - Fix PG_TEXT parameter binding - Doc cleanups [Greg Sabino Mullane] - Fix warning from func($table, 'table_attributes') [Greg Sabino Mullane] - Added support for schemas [Greg Sabino Mullane] - Fix binary to a bytea field conversion [Chris Dunlop ] Version 1.21 (released January 12, 2003) - System tables no longer returned by tables() [Dave Rolsky] - Fix table_attributes to handle removal of pg_relcheck in 7.3 [Ian Barwick ] - Properly reset transaction status after failed transaction when autocommit is off. Properly report transaction failure message. [Kai ] - New pg_bool_tf database handle that when set to true booleans are returned as 't'/'f' rather than 1/0. Version 1.20 (released November 27, 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. [Garth Webb] - Added LISTEN/NOTIFY functionality. [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] Version 1.15 (released April 27, 2002) - Add default at end of switch statement for pg_type attrib, along with tests. [Jeffrey W. Baker] Version 1.12 (released April 9, 2002) - Applied patch from Thomas A. Lowery concerning metadata in table_info and so forth. [Jeffrey W. Baker] Version 1.10 (released March 6, 2002) - Applied patch from David Wheeler to simplify and speed up quoting. [Jeffrey W. Baker] - Added tests for quoting changes above. - Added tests for placeholder parsing in quoted strings. Version 1.01 (released June 27, 2001) - Fixed core dump when trying to use a BYTEA value with a byte outside 0..127 [Alex Pilosov ] Version 1.00 (released May 27, 2001) - Fetching all records now resets Active flag as it should. Version 0.99 (released May 24, 2001) - Fix the segmentation fault in pg_error. Version 0.98 (released April 25, 2001) - Bug fix for core-dump after any failed function call. - Applied patch from Alex Pilosov which adds support for the datatype bytea Version 0.97 (released April 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 , which removed the special handling of a backslash when used for octal presentation. Now a backslash always will be escaped. Version 0.96 (released April 09, 2001) - Remove memory-leak in ping function [Doug Perham ] - Correct the recognition of primary keys in table_attributes(). [Brian Powell ] - Fix a segmentation fault in DBD::pg::blob_read() when reading LOBs that required perl to reallocate space for the variable holding the scalar value [David D. Kilzer ] - Updated test.pl to create a test blob larger than 256 bytes (now 128 Kbytes) - Fix a segmentation fault when inserting large amounts of text. [Tom Lane] - Removes the newlines from the error messages and which quotes date placeholders. [Peter Haworth ] Version 0.95 (released July 10, 2000) - Add Win32 port [Bob Kline ] Version 0.94 (released July 07, 2000) - Fix a memory-leak with failed connections. [Rudy Lippan ] - Fix a bug with escaping a backslash except for octal presentation [Hein Roehrig ] Fix a segmentation fault when all bound parameters are NULL [Francis J. Lacoste ] Version 0.93 (released September 29, 1999) - It is required now to set the environment variables POSTGRES_INCLUDE and POSTGRES_LIB for compiling the module. - Add Win32 port [Bob Kline ] - Support for all large-object functions via the func interface. - Fixed bug with placeholders and casts [spotted by bymschout at gkg.net] - Replaced the method attributes by the method table_attributes, [Scott Williams ] - Fix type definitions for type_info_all(). [spotted by "carlos" ] - Now the Pg-specific quote() method also evaluates the data-type parameter. Version 0.92 (released June 16, 1999) - Increase BUFSIZE from 1024 to 32768 in order to improve I/O performance. [Philip Warner ] - Fix in Makefile.PL for $POSTGRES_HOME not defined [spotted by Mark Dalphin mdalphin at amgen.com] - Fix for data-type datetime in type_info_all [spotted by Alan Grover ] - Fix for escaped 's [spotted by Hankin ] - Removed 'large objects' related tests from test.pl Version 0.91 (released February 14, 1999) - Removed restriction for commercial use in copyright - Corrected DATA_TYPE in type_info_all() Version 0.90 (released January 15, 1998) - Discard parameter authtype from connect string - Remove work-around for bug in the large object interface of postgresql Version 0.89 (released November 05, 1998) - Fix problem with quoting Null in bind variables. [Jan Iven ] Version 0.88 (released October 10, 1998) - Fixed blob_read - Suppressed warning when testing DBI::errstr Version 0.87 (released September 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 - Documentation and tests added for blob_read - Added support for attr parameter in bind_param() Version 0.86 (released August 21, 1998) - Added /usr/lib/ to search path for libpq. - Added ChopBlanks, patch from Victor Krasinsky - Changed test.pl to test multiple database handles Version 0.85 (released July 19, 1998) - Non-printable characters in parameters will not be converted to '.'. They are passed unchanged to the database. Version 0.84 (released July 18, 1998) - Check for \xxx presentation before escaping backslash in parameters. [Max Cohan max at cohan.biz] - 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. Version 0.83 (released July 10, 1998) - Bug fix for core dump when using traces together with undef [Max Cohan max at cohan.biz] Version 0.82 (released June 20, 1998) - Corrected include path in Makefile.PL . [Matthew Lenz ] - Added 'use strict;' to test.pl Version 0.81 (released June 13, 1998) - 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. [Rolf Grossmann ] - Change ping method to use libpq-interface. Version 0.80 (released 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. Version 0.73 (released 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] Quote method also doubles backslash. [Junio Hamano ] Version 0.72 (released April 20, 1998) - Fix bug with queries containing the cast operator. [Michael J Schout ] - Fix memory leak [Irving Reid ] Version 0.71 (released April 04, 1998) - Fix problem with InactiveDestroy [Irving Reid ] Version 0.70 (released March 28, 1998) - Linking again with the shared version of libpq due to problems on several operating systems. Version 0.69 (released March 6, 1998) - Expanded the search path for include files - Module is now linked with static libpq.a Version 0.68 (released March 3, 1998) - Return to UNIX domain sockets in test-scripts Version 0.67 (released February 21, 1998) - Remove part of Driver.xst due to compile error on some systems. Version 0.66 (released February 19, 1998) - Remove defines in Pg.h so that it compiles also with postgresql-6.2.1 - Changed ping method: set RaiseError=0 Version 0.65 (released 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. Version 0.64 (released February 01, 1998) - Changed syntax of data_source (ODBC-conformant): 'dbi:Pg:dbname=dbname;host=host;port=port' - 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 Version 0.63 (released October 05, 1997) - Adapted to PostgreSQL-6.2: $sth->rows as well as $sth->execute and $sth->do return the number of affected rows even for non-Select statements. 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! Version 0.62 (released August 26, 1997) - Added blobs/README Version 0.61 (released August 23, 1997) - Adapted to DBI-0.89/Driver.xst - Added support for blob_read Version 0.52 (released August 15, 1997) - Added support for literal $sth->{'TYPE'}, pg_type.pl / pg_type.pm. Version 0.51 (released August 12, 1997) - Changed attributes to be DBI conformant: OID_STATUS to pg_oid_status, CMD_STATUS to pg_cmd_status Version 0.5 (released August 05, 1997) - Support for user authentication - Support for bind_columns - Added $dbh->tables Version 0.4 (released June 24, 1997) - Adapted to DBI-0.84: new syntax for DBI->connect. Method 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'} Version 0.3 (released April 24, 1997) - Bug fix release, ( still alpha ! ) Version 0.2 (released March 13, 1997) - Complete rewrite, ( still alpha ! ) Version 0.1 (released February 15, 1997) - Creation, ( totally pre-alpha ! ) DBD-Pg-3.20.2/.dir-locals.el0000644000175000017500000000033115116315266013621 0ustar greggreg((nil . ((indent-tabs-mode . nil))) ; all modes (cperl-mode . ((cperl-indent-level . 4) (cperl-merge-trailing-else . nil))) (c-mode . ((c-indentation-style . bsd) (c-basic-offset . 4)))) DBD-Pg-3.20.2/quote.h0000644000175000017500000000261715166170753012514 0ustar greggreg char * null_quote(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_string(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_bytea(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_sql_binary(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_bool(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_integer(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_int(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_float(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_name(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_geom(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_path(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); char * quote_circle(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring); void dequote_char(pTHX_ char *string, STRLEN *retlen); void dequote_string(pTHX_ char *string, STRLEN *retlen); void dequote_bytea(pTHX_ char *string, STRLEN *retlen); void dequote_sql_binary(pTHX_ char *string, STRLEN *retlen); void dequote_bool(pTHX_ char *string, STRLEN *retlen); void null_dequote(pTHX_ char *string, STRLEN *retlen); bool is_keyword(const char *string); DBD-Pg-3.20.2/TODO0000644000175000017500000000407015173034044011657 0ustar greggregPossible items to do, in no particular order Feature requests can be entered at https://github.com/bucardo/dbdpg/issues - Address that "XXX Wrong" in types.c - Consider support for PQchangePassword - Support pipeline mode: https://www.postgresql.org/docs/14/libpq-pipeline-mode.html - Consider adding pg_application_name - Evaluate if we really need strtod in the code - Have docs describe various ways to set client_encoding - Change license to Artistic 2 - Remove the "goto" calls in the tests - Force a test database rebuild when a git branch switch is detected - Make all tests work when server and/or client encoding is SQL_ASCII - Enable native JSON decoding, similar to arrays, perhaps with JSON::PP - Allow partial result sets, either via PQsetSingleRowMode or something better - Hack libpq to make user-defined number of rows returned - Map hstore to hashes similar to the array/array mapping - Fix ping problem: http://www.cpantesters.org/cpan/report/53c5cc72-6d39-11e1-8b9d-82c3d2d9ea9f - Use WITH HOLD for cursor work - Devise a way to automatically create ppm for Windows builds - I8N docs and error messages - Change quote and dequote functions to take Sv instead of string so that things like arrays can be serialized by the quote function. This will take care of broken chopblanks and pg_bool_tf (pass the quote/dequote options struct to function quote/dequote functions) - Allow user callbacks to quote user-defined types - Revisit the use of version.pm - Test heavily with a thread-enabled Perl - Remove libpq dependency - Handle and/or better tests for different encoding, especially those not supported as a server encoding (e.g. BIG5) - Support passing hashrefs in and out for custom types. - Support a flag for behind-the-scenes CURSOR to emulate partial fetches. - Composite type support: http://www.postgresql.org/docs/current/interactive/rowtypes.html - Full support for execute_array, e.g. the return values - Fix array support: execute([1,2]) not working as expected, deep arrays not returned correctly. - Support RaiseError on $sth from closed $dbh (GH #28) DBD-Pg-3.20.2/types.h0000644000175000017500000002324515166170753012523 0ustar greggreg/* Do not edit this file directly - it is generated by types.c */ typedef struct sql_type_info { int type_id; char* type_name; bool bind_ok; char array_delimiter; char* arrayout; char* (*quote)(pTHX_ const char *, STRLEN, STRLEN *, int); void (*dequote)(pTHX_ char *, STRLEN *); union { int pg; int sql; } type; int svtype; } sql_type_info_t; sql_type_info_t* pg_type_data(int); sql_type_info_t* sql_type_data(int); #define PG_ACLITEM 1033 #define PG_ANY 2276 #define PG_ANYCOMPATIBLE 5077 #define PG_ANYCOMPATIBLEMULTIRANGE 4538 #define PG_ANYCOMPATIBLERANGE 5080 #define PG_ANYELEMENT 2283 #define PG_ANYENUM 3500 #define PG_ANYMULTIRANGE 4537 #define PG_ANYRANGE 3831 #define PG_BIT 1560 #define PG_BOOL 16 #define PG_BOX 603 #define PG_BPCHAR 1042 #define PG_BYTEA 17 #define PG_CHAR 18 #define PG_CID 29 #define PG_CIDR 650 #define PG_CIRCLE 718 #define PG_CSTRING 2275 #define PG_DATE 1082 #define PG_DATEMULTIRANGE 4535 #define PG_DATERANGE 3912 #define PG_EVENT_TRIGGER 3838 #define PG_FDW_HANDLER 3115 #define PG_FLOAT4 700 #define PG_FLOAT8 701 #define PG_GTSVECTOR 3642 #define PG_INDEX_AM_HANDLER 325 #define PG_INET 869 #define PG_INT2 21 #define PG_INT2VECTOR 22 #define PG_INT4 23 #define PG_INT4MULTIRANGE 4451 #define PG_INT4RANGE 3904 #define PG_INT8 20 #define PG_INT8MULTIRANGE 4536 #define PG_INT8RANGE 3926 #define PG_INTERNAL 2281 #define PG_INTERVAL 1186 #define PG_JSON 114 #define PG_JSONB 3802 #define PG_JSONPATH 4072 #define PG_LANGUAGE_HANDLER 2280 #define PG_LINE 628 #define PG_LSEG 601 #define PG_MACADDR 829 #define PG_MACADDR8 774 #define PG_MONEY 790 #define PG_NAME 19 #define PG_NUMERIC 1700 #define PG_NUMMULTIRANGE 4532 #define PG_NUMRANGE 3906 #define PG_OID 26 #define PG_OID8 8256 #define PG_OIDVECTOR 30 #define PG_PATH 602 #define PG_PG_ATTRIBUTE 75 #define PG_PG_BRIN_BLOOM_SUMMARY 4600 #define PG_PG_BRIN_MINMAX_MULTI_SUMMARY 4601 #define PG_PG_CLASS 83 #define PG_PG_DDL_COMMAND 32 #define PG_PG_DEPENDENCIES 3402 #define PG_PG_LSN 3220 #define PG_PG_MCV_LIST 5017 #define PG_PG_NDISTINCT 3361 #define PG_PG_NODE_TREE 194 #define PG_PG_PROC 81 #define PG_PG_SNAPSHOT 5038 #define PG_PG_TYPE 71 #define PG_POINT 600 #define PG_POLYGON 604 #define PG_RECORD 2249 #define PG_REFCURSOR 1790 #define PG_REGCLASS 2205 #define PG_REGCOLLATION 4191 #define PG_REGCONFIG 3734 #define PG_REGDATABASE 8326 #define PG_REGDICTIONARY 3769 #define PG_REGNAMESPACE 4089 #define PG_REGOPER 2203 #define PG_REGOPERATOR 2204 #define PG_REGPROC 24 #define PG_REGPROCEDURE 2202 #define PG_REGROLE 4096 #define PG_REGTYPE 2206 #define PG_TABLE_AM_HANDLER 269 #define PG_TEXT 25 #define PG_TID 27 #define PG_TIME 1083 #define PG_TIMESTAMP 1114 #define PG_TIMESTAMPTZ 1184 #define PG_TIMETZ 1266 #define PG_TRIGGER 2279 #define PG_TSMULTIRANGE 4533 #define PG_TSM_HANDLER 3310 #define PG_TSQUERY 3615 #define PG_TSRANGE 3908 #define PG_TSTZMULTIRANGE 4534 #define PG_TSTZRANGE 3910 #define PG_TSVECTOR 3614 #define PG_TXID_SNAPSHOT 2970 #define PG_UNKNOWN 705 #define PG_UUID 2950 #define PG_VARBIT 1562 #define PG_VARCHAR 1043 #define PG_VOID 2278 #define PG_XID 28 #define PG_XID8 5069 #define PG_XML 142 #define PG_ACLITEMARRAY 1034 #define PG_ANYARRAY 2277 #define PG_ANYCOMPATIBLEARRAY 5078 #define PG_ANYCOMPATIBLENONARRAY 5079 #define PG_ANYNONARRAY 2776 #define PG_BITARRAY 1561 #define PG_BOOLARRAY 1000 #define PG_BOXARRAY 1020 #define PG_BPCHARARRAY 1014 #define PG_BYTEAARRAY 1001 #define PG_CHARARRAY 1002 #define PG_CIDARRAY 1012 #define PG_CIDRARRAY 651 #define PG_CIRCLEARRAY 719 #define PG_CSTRINGARRAY 1263 #define PG_DATEARRAY 1182 #define PG_DATEMULTIRANGEARRAY 6155 #define PG_DATERANGEARRAY 3913 #define PG_FLOAT4ARRAY 1021 #define PG_FLOAT8ARRAY 1022 #define PG_GTSVECTORARRAY 3644 #define PG_INETARRAY 1041 #define PG_INT2ARRAY 1005 #define PG_INT2VECTORARRAY 1006 #define PG_INT4ARRAY 1007 #define PG_INT4MULTIRANGEARRAY 6150 #define PG_INT4RANGEARRAY 3905 #define PG_INT8ARRAY 1016 #define PG_INT8MULTIRANGEARRAY 6157 #define PG_INT8RANGEARRAY 3927 #define PG_INTERVALARRAY 1187 #define PG_JSONARRAY 199 #define PG_JSONBARRAY 3807 #define PG_JSONPATHARRAY 4073 #define PG_LINEARRAY 629 #define PG_LSEGARRAY 1018 #define PG_MACADDR8ARRAY 775 #define PG_MACADDRARRAY 1040 #define PG_MONEYARRAY 791 #define PG_NAMEARRAY 1003 #define PG_NUMERICARRAY 1231 #define PG_NUMMULTIRANGEARRAY 6151 #define PG_NUMRANGEARRAY 3907 #define PG_OID8ARRAY 8261 #define PG_OIDARRAY 1028 #define PG_OIDVECTORARRAY 1013 #define PG_PATHARRAY 1019 #define PG_PG_ATTRIBUTEARRAY 270 #define PG_PG_CLASSARRAY 273 #define PG_PG_LSNARRAY 3221 #define PG_PG_PROCARRAY 272 #define PG_PG_SNAPSHOTARRAY 5039 #define PG_PG_TYPEARRAY 210 #define PG_POINTARRAY 1017 #define PG_POLYGONARRAY 1027 #define PG_RECORDARRAY 2287 #define PG_REFCURSORARRAY 2201 #define PG_REGCLASSARRAY 2210 #define PG_REGCOLLATIONARRAY 4192 #define PG_REGCONFIGARRAY 3735 #define PG_REGDATABASEARRAY 8327 #define PG_REGDICTIONARYARRAY 3770 #define PG_REGNAMESPACEARRAY 4090 #define PG_REGOPERARRAY 2208 #define PG_REGOPERATORARRAY 2209 #define PG_REGPROCARRAY 1008 #define PG_REGPROCEDUREARRAY 2207 #define PG_REGROLEARRAY 4097 #define PG_REGTYPEARRAY 2211 #define PG_TEXTARRAY 1009 #define PG_TIDARRAY 1010 #define PG_TIMEARRAY 1183 #define PG_TIMESTAMPARRAY 1115 #define PG_TIMESTAMPTZARRAY 1185 #define PG_TIMETZARRAY 1270 #define PG_TSMULTIRANGEARRAY 6152 #define PG_TSQUERYARRAY 3645 #define PG_TSRANGEARRAY 3909 #define PG_TSTZMULTIRANGEARRAY 6153 #define PG_TSTZRANGEARRAY 3911 #define PG_TSVECTORARRAY 3643 #define PG_TXID_SNAPSHOTARRAY 2949 #define PG_UUIDARRAY 2951 #define PG_VARBITARRAY 1563 #define PG_VARCHARARRAY 1015 #define PG_XID8ARRAY 271 #define PG_XIDARRAY 1011 #define PG_XMLARRAY 143 DBD-Pg-3.20.2/testme.tmp.pl0000755000175000017500000003274715173231074013645 0ustar greggreg#!/usr/bin/env perl ## This is a test file, used by the DBD::Pg developers to duplicate and debug issues ## Helpful install tip: yum install libyaml-perl libdata-peek-perl libdevel-leak-perl BEGIN { use lib '.', 'blib/lib', 'blib/arch'; system 'make'; } use 5.008001; use strict; use warnings; use DBI ':sql_types'; use utf8; use Data::Dumper; $Data::Dumper::Sortkeys = 1; use YAML; use DBD::Pg qw/:pg_types/; use Data::Peek; use Devel::Leak; use Time::HiRes qw/ sleep /; my $DBPORT = shift || 6432; our ($sth, $info, $count, $SQL); my $tracelevel = shift || 0; $ENV{DBI_TRACE} = $tracelevel; my $DSN = "DBI:Pg:dbname=postgres;port=$DBPORT"; my $dbh; eval { $dbh = DBI->connect($DSN, '', '', {AutoCommit=>0,RaiseError=>1,PrintError=>0}); }; if ($@) { print "Connection failed!\n\n$@\n"; if ($@ =~ /socket/) { print "HINT: Port number can be sent as first argument to this script\n"; } exit 0; } my $me = $dbh->{Driver}{Name}; my $sversion = $dbh->{pg_server_version}; print "DBI is version $DBI::VERSION, I am $me, version of DBD::Pg is $DBD::Pg::VERSION, server is $sversion\n"; my $port = $dbh->{pg_port}; print "Port: $port\n"; print "Name: $dbh->{Name}\n"; $dbh->{RaiseError} = 0; $dbh->{PrintError} = 1; $dbh->{AutoCommit} = 1; exit; #update_rule_return(); #column_types_github_issue_24(); #read_only_arrays(); # bad_string_length(); # jsonb_placeholder(); #fatal_client(); #user_arrays(); #commit_return_test(); #utf8_print_test(); #memory_leak_test_bug_65734(); #memory_leak_arrays(); sub update_rule_return { my @statements = ( q[DROP TABLE IF EXISTS test CASCADE], q[CREATE TABLE test(id int primary key, animal text, sound text)], q[CREATE VIEW test_view AS SELECT * FROM test], q[CREATE OR REPLACE RULE test_fallback AS ON UPDATE TO test_view DO INSTEAD NOTHING], q[CREATE RULE test_deny AS ON UPDATE TO test_view WHERE NEW.animal = OLD.animal DO INSTEAD (SELECT true)], q[CREATE OR REPLACE RULE test_allow AS ON UPDATE TO test_view WHERE NEW.animal <> OLD.animal DO INSTEAD ( UPDATE test SET animal = NEW.animal, sound = NEW.sound WHERE id = OLD.id; SELECT true; )], q[INSERT into test VALUES (1,'rabbit','purr'),(2,'fox','shriek')], ); foreach my $statement (@statements) { $dbh->do($statement); } sub is { my ($got, $expected, $name) = @_; warn "OK: $name\n" and return if $got eq $expected; warn "Failed test: got ($got) expected ($expected) for $name\n"; } my ($found,$animal,$sound); my $sth_s = $dbh->prepare('SELECT animal,sound FROM test WHERE id = ?'); my $sth_u = $dbh->prepare('UPDATE test_view SET animal = ?, sound = ? WHERE id = ?', {}); #,{ pg_server_prepare => 0} makes a difference ??? ## PGRES_TUPLES_OK vs PGRES_COMMAND_OK ## How does psql do the right thing? # Test update that will be allowed by rule print "Normal UPDATE\n"; my ($rv2) = $sth_u->execute('bear','roar',1); $sth_s->execute(1); ($animal,$sound) = $sth_s->fetchrow_array(); $sth_s->finish; is($animal,'bear','animal ok'); is($sound,'roar','sound was changed'); is($sth_u->state,'','state ok'); is($sth_u->rows,1,'1 rows'); is($rv2,1,'rv is 1'); is($sth_u->{Active},1,'Sth active'); is($sth_u->fetch->[0],1,'Row was found: TWO'); $sth_u->finish(); exit; # Test update that will be denied by rule # psql> kalidb_test=# UPDATE test_view SET animal = 'rabbit', sound = 'roar' WHERE id = 1; # psql> bool # psql> ------ # psql> t # psql> (1 row) # psql> # psql> UPDATE 0 my ($rv1) = $sth_u->execute('rabbit','roar',1); #$sth_s->execute(1); #($animal,$sound) = $sth_s->fetchrow_array(); #$sth_s->finish;is($animal,'rabbit','animal ok'); #is($sound,'purr','sound was not changed'); is($sth_u->state,'','state ok'); is($sth_u->rows,0,'0 rows'); is($rv1,'0E0','rv is 0E0'); is($sth_u->{Active},1,'Sth active'); is($sth_u->fetch->[0],1,'Row was found'); # dies here # DBD::Pg::st fetch failed: no statement executing $sth_u->finish(); #die "Made it past!\n"; # Test update that will be acepted # psql> kalidb_test=# UPDATE test_view SET animal = 'bear', sound = 'roar' WHERE id = 1; # psql> bool # psql> ------ # psql> t # psql> (1 row) # psql> # psql> UPDATE 1 $rv2 = $sth_u->execute('bear','roar',1); $sth_s->execute(1); ($animal,$sound) = $sth_s->fetchrow_array(); $sth_s->finish; is($animal,'bear','animal ok'); is($sound,'roar','sound was changed'); is($sth_u->state,'','state ok'); is($sth_u->rows,1,'1 rows'); is($rv2,1,'rv is 1'); is($sth_u->{Active},1,'Sth active'); is($sth_u->fetch->[0],1,'Row was found: TWO'); $sth_u->finish(); exit; # Test update on non-existant record # psql> kalidb_test=# UPDATE test_view SET animal = 'wolf', sound = 'howl' WHERE id = 99; # psql> bool # psql> ------ # psql> (0 rows) # psql> # psql> UPDATE 0 my ($rv3) = $sth_u->execute('wolf','howl',99); $sth_s->execute(3); ($animal,$sound) = $sth_s->fetchrow_array(); $sth_s->finish; is($animal,undef,'no animal'); is($sth_u->state,'','state ok'); is($sth_u->rows,0,'0 rows'); is($rv3,'0E0','rv is 0E0'); is($sth_u->{Active},'','Sth active'); $sth_u->finish(); } sub column_types_github_issue_24 { ## Code from https://gist.githubusercontent.com/jef-sure/9a28e7c12f0c03d32080456afd4dafd3/raw/4ada2362371d930c9b035bd749f7b93a6d75cfc1/column-types.pl sub table_columns { my $table = $_[0]; my @columnlist; my $cih = $dbh->column_info(undef, undef, $table, undef) or die "no table $table"; my $i = 0; while (my $chr = $cih->fetchrow_hashref) { my $cn = $chr->{COLUMN_NAME}; $cn =~ s/\"//g; push @columnlist, [$cn, $chr->{TYPE_NAME}]; } return \@columnlist; } sub query_columns { my $query = $_[0]; my $sth = $dbh->prepare($query) or die "query $query error: " . $dbh->errstr; $sth->execute or die "query $query error: " . $dbh->errstr; my @columnlist; for (my $cn = 0; $cn < @{$sth->{NAME}}; ++$cn) { my $ti = $dbh->type_info($sth->{TYPE}->[$cn]); my $cn = $sth->{NAME}->[$cn]; $cn =~ s/\"//g; push @columnlist, [$cn, $ti->{TYPE_NAME} // 'UNKNOWN']; } return \@columnlist; } sub print_columns { my ($name, $cref) = @_; print "\n$name:\n"; for my $ci (@$cref) { print "$ci->[0]: $ci->[1]\n"; } } #anton=> \d todo # Table "public.todo" # Column | Type | Modifiers #-----------+---------+--------------------------------------------------- # id | integer | not null default nextval('todo_id_seq'::regclass) # title | text | # completed | boolean | # misc | jsonb | #Indexes: # "todo_pkey" PRIMARY KEY, btree (id) $SQL = 'CREATE TABLE todo ( id SERIAL PRIMARY KEY, title text, completed boolean, misc jsonb )'; $dbh->do($SQL); print_columns("todo", table_columns("todo")); print_columns("select * from todo", query_columns("select * from todo")); #output: # #todo: #id: integer #title: text #completed: boolean #misc: jsonb # #select * from todo: #id: int4 #title: UNKNOWN #completed: bool #misc: unknown exit; } ## end of column_types_github_issue_24 sub read_only_arrays { ## For RT ticket #107556 $SQL = 'SELECT 5, NULL, ARRAY[1,2,3], ARRAY[1,NULL,3]'; $sth = $dbh->prepare($SQL); $sth->execute; while( my $row = $sth->fetchrow_arrayref ) { $row->[0] += 0; # ok $row->[1] += 0; # ok $_ += 0 foreach @{ $row->[2] }; # ok $_ += 0 foreach @{ $row->[3] }; # error: Modification of a read-only value attempted } exit; } ## end of read_only_arrays sub bad_string_length { ## RT Ticket 114548 $SQL = 'SELECT md5(x::text) FROM generate_series(1,5) x'; $sth = $dbh->prepare($SQL); $sth->execute(); my $md5size; $sth->bind_columns(\$md5size); while ($sth->fetch()) { print "\n"; DDump $md5size; print $md5size , "\n"; printf "%vx\n", $md5size; print '.' x 32, '-' x 32 . "\n"; print substr($md5size, 0, 32), " (" . length($md5size) . ' -- ' . length(substr($md5size, 0, 32)) . ")\n"; } } ## end of bad_string_length sub jsonb_placeholder { ## Github #33 ## https://github.com/bucardo/dbdpg/issues/33 print "Starting jsonb placeholder test\n"; $SQL = q{ SELECT '{"a":1}'::jsonb \? 'abc' and 1=$1 }; for ( my $i=0; $i<100; $i++ ) { print "$i.. "; $sth = $dbh->prepare($SQL); $sth->execute(2); $sth->finish(); } print "\n"; } sub fatal_client { ## RT 109591 print "Test of client_min_messages FATAL and resulting errstr\n"; $dbh->do(q{SET client_min_messages = 'FATAL'}); eval { $dbh->do('SELECT 1 FROM nonesuch'); }; printf "\$@ is: %s\n", $@; printf "errstr is: %s\n", $dbh->errstr; printf "state is: %s\n", $dbh->state; exit; } ## end of fatal_client sub memory_leak_arrays { # $dbh->{pg_expand_array} = 0; $dbh->do('CREATE TABLE leaktest ( id TEXT, arr TEXT[] )'); $dbh->do('TRUNCATE TABLE leaktest'); for my $var (qw/ a b c/ ) { $dbh->do(qq{INSERT INTO leaktest VALUES ( '$var', '{"a","b","c"}' )}); } my $sth = $dbh->prepare( 'SELECT arr FROM leaktest' ); my $count0 = 0; { my $handle; my $count1 = Devel::Leak::NoteSV( $handle ); $sth->execute(); my $r = $sth->fetchall_arrayref( {} ); my $count2 = Devel::Leak::NoteSV( $handle ); $count0 ||= $count1; my $diff = $count2 - $count0; printf "New SVs: %4d Total: %d\n", $diff, $count2; sleep 0.2; last if $diff > 100; redo; } } ## end of memory_leak_arrays sub user_arrays { print "User arrays!\n"; print Dumper $dbh->type_info(-5); $dbh->do ("create table xx_test (c_test bigint)"); my $sth = $dbh->prepare ("select * from xx_test"); $sth->execute; DDumper ($sth->{TYPE}[0], $dbh->type_info ($sth->{TYPE}[0])); $dbh->do ("drop table xx_test"); exit; $dbh->do('drop table if exists domodomo'); $dbh->do('create domain domo as int[][]'); $dbh->do('create table domodomo (id serial, foo domo)'); $SQL = 'INSERT INTO domodomo(foo) VALUES (?)'; $sth = $dbh->prepare($SQL); $sth->execute(q!{{1},{2}}!); $SQL = 'SELECT foo FROM domodomo'; my $f = $dbh->prepare($SQL); $f->execute(); my $res = $f->fetchall_arrayref(); print Dumper $res; print $res->[0]; $dbh->do("CREATE TYPE customint AS ENUM('1','2')"); my $q2 = $dbh->prepare("SELECT '{1,2}'::customint[]"); $q2->execute(); print Dumper $q2->fetchrow_array(); # prints "{1,2}", not an array exit; } ## end of user_arrays sub commit_return_test { $dbh->{RaiseError} = 0; $dbh->{PrintError} = 1; $dbh->{AutoCommit} = 0; ## Test value returned by the commit() method my $res = $dbh->commit(); print "-->Initial commit returns a value of $res\n"; $res = $dbh->commit(); print "-->When called twice, commit returns a value of $res\n"; $dbh->do('SELECT 123'); $dbh->do('SELECT fail'); $dbh->do('SELECT 111'); $res = $dbh->commit(); print "-->After exception, commit returns a value of $res\n"; $dbh->do('SELECT 456'); return; } ## end of commit_return_test sub utf8_print_test { ## Set things up $dbh->do('CREATE TEMPORARY TABLE ctest (c TEXT)'); ## Add some UTF-8 content $dbh->do("INSERT INTO ctest VALUES ('*JIHOMORAVSKÝ*')"); $dbh->do("INSERT INTO ctest VALUES ('*Špindlerův Mlýn*')"); ## Pull data back out via execute/bind/fetch $SQL = 'SELECT c FROM ctest'; my $result; for my $loop (1..4) { my $onoff = 'off'; if ($loop == 1 or $loop==3) { $dbh->{pg_enable_utf8} = 0; } else { $dbh->{pg_enable_utf8} = 1; $onoff = 'on'; } if ($loop>2) { binmode STDOUT, ':utf8'; } $sth = $dbh->prepare($SQL); $sth->execute(); $sth->bind_columns(\$result); while ($sth->fetch() ) { print DPeek $result; print "\n Print with pg_enable_utf8 $onoff: $result\n"; warn " Warn with pg_enable_utf8 $onoff: $result\n\n"; utf8::upgrade($result); print DPeek $result; print "\n\n"; } } } ## end of utf8_print_test sub memory_leak_test_bug_65734 { ## Memory leak when an array appears in the bind variables ## Set things up $dbh->do('CREATE TEMPORARY TABLE tbl1 (id SERIAL PRIMARY KEY, val INTEGER[])'); $dbh->do('CREATE TEMPORARY TABLE tbl2 (id SERIAL PRIMARY KEY, val INTEGER)'); ## Subroutine that performs the leaking action sub leakmaker1 { $dbh->do('INSERT INTO tbl1(val) VALUES (?)', undef, [123]); } ## Control subroutine that does not leak sub leakmaker2 { $dbh->do('INSERT INTO tbl2(val) VALUES (?)', undef, 123); } leakcheck(\&leakmaker1,1000); exit; } ## end of memory_leak_test_bug_65734 sub leakcheck { my $sub = shift; my $count = shift || 1000; my $maxsize = shift || 100000; ## Safety check: if (exists $ENV{DBI_TRACE} and $ENV{DBI_TRACE} != 0 and $ENV{DBI_TRACE} != 42) { $maxsize = 1; } my $runs = 0; while (1) { last if $runs++ >= $maxsize; &$sub(); unless ($runs % $count) { printf "Cycles: %d\tProc size: %uK\n", $runs, (-f "/proc/$$/stat") ? do { local @ARGV="/proc/$$/stat"; (split (/\s/, <>))[22] / 1024 } : -1; } } } ## end of leakcheck __END__ DBD-Pg-3.20.2/.perlcriticrc0000644000175000017500000001517315173033575013673 0ustar greggregverbose = %f [%p] %m at line %l, column %c. (Severity: %s)\n profile-strictness = quiet exclude = Mardem [Documentation::PodSpelling] stop_words = ActiveKids afterwards arrayref arrayrefs attr autocommit AutoCommit AutoInactiveDestroy backend bitmask bool boolean Bunce bytea CachedKids cancelled ChildHandles ChopBlanks CompatMode CursorName datatype Datatype datatypes dbd DBD dbdpg dbh DBI deallocation deallocated dev dr DSN enum ErrCount errstr fd FetchHashKeyName filename func getfd getline github HandleError HandleSetErr hashref hashrefs InactiveDestroy JSON largeobject len libpq LongReadLen LongTruncOk lseg Mergl Momjian Mullane nullable NULLABLE Oid OID onwards param ParamTypes ParamValues perl Perlish PgBouncer pgbuiltin pgend pglibpq pglogin pgprefix pgquote PGSERVICE PGSERVICEFILE pgsql pgstart PGSYSCONFDIR PID Postgres PostgreSQL PQexecParams PQexecPrepared PrintError PrintWarn pseudotype RaiseError README ReadOnly RowCache RowCacheSize RowsInCache runtime Sabino savepoint savepoints Savepoints schemas ShowErrorStatement SQL SQLSTATE SSL sslmode sslrootcert STDERR STDIN STDOUT stringify subdirectory tablename tablespace tablespaces TaintIn TaintOut TraceLevel tuple typename undef username Username UTF varchar [-Bangs::ProhibitBitwiseOperators] [-Bangs::ProhibitCommentedOutCode] [-Bangs::ProhibitDebuggingModules] [-Bangs::ProhibitFlagComments] [-Bangs::ProhibitNumberedNames] [-Bangs::ProhibitVagueNames] [-BuiltinFunctions::ProhibitBooleanGrep] [-BuiltinFunctions::ProhibitComplexMappings] [-BuiltinFunctions::ProhibitStringyEval] [-BuiltinFunctions::RequireBlockGrep] [-ClassHierarchies::ProhibitExplicitISA] [-CodeLayout::ProhibitHashBarewords] [-CodeLayout::ProhibitParensWithBuiltins] [-CodeLayout::ProhibitQuotedWordLists] [-CodeLayout::ProhibitSpaceIndentation] [-CodeLayout::RequireASCII] [-CodeLayout::RequireBreakBeforeOperator] [-CodeLayout::RequireKRBracing] [-CodeLayout::RequireSpaceAroundBinaryOperators] [-CodeLayout::RequireTidyCode] [-CodeLayout::RequireTrailingCommaAtNewline] [-CodeLayout::RequireUseUTF8] [-CodeLayout::TabIndentSpaceAlign] [-CognitiveComplexity::ProhibitExcessCognitiveComplexity] [-Community::Each] [-Community::EmptyReturn] [-Community::PackageMatchesFilename] [-Community::WhileDiamondDefaultAssignment] [-Compatibility::PodMinimumVersion] [-ControlStructures::ProhibitCascadingIfElse] [-ControlStructures::ProhibitCStyleForLoops] [-ControlStructures::ProhibitDeepNests] [-ControlStructures::ProhibitMultipleSubscripts] [-ControlStructures::ProhibitPostfixControls] [-Documentation::RequireLinkedURLs] [-Documentation::RequirePod] [-Documentation::RequirePodSections] [-Documentation::RequirePODUseEncodingUTF8] [-Editor::RequireEmacsFileVariables] [-ErrorHandling::RequireCarping] [-ErrorHandling::RequireCheckingReturnValueOfEval] [-Freenode::Each] [-Freenode::EmptyReturn] [-Freenode::PackageMatchesFilename] [-Freenode::StrictWarnings] [-Freenode::WhileDiamondDefaultAssignment] [-InputOutput::ProhibitBacktickOperators] [-InputOutput::ProhibitOneArgSelect] [-InputOutput::RequireBriefOpen] [-InputOutput::RequireCheckedClose] [-InputOutput::RequireCheckedSyscalls] [-Lax::ProhibitComplexMappings::LinesNotStatements] [-Lax::ProhibitEmptyQuotes::ExceptAsFallback] [-Lax::ProhibitStringyEval::ExceptForRequire] [-Lax::RequireEndWithTrueConst] [-Lax::RequireExplicitPackage::ExceptForPragmata] [-logicLAB::ProhibitShellDispatch] [-logicLAB::ProhibitUseLib] [-logicLAB::RequireParamsValidate] [-logicLAB::RequireSheBang] [-logicLAB::RequireVersionFormat] [-Miscellanea::ProhibitUnrestrictedNoCritic] [-Miscellanea::ProhibitUselessNoCritic] [-Miscellanea::RequireRcsKeywords] [-Modules::ProhibitAutomaticExportation] [-Modules::ProhibitExcessMainComplexity] [-Modules::ProhibitMultiplePackages] [-Modules::RequireBarewordIncludes] [-Modules::RequireEndWithOne] [-Modules::RequireExplicitInclusion] [-Modules::RequireExplicitPackage] [-OTRS::ProhibitDumper] [-OTRS::ProhibitLocaltime] [-OTRS::ProhibitLowPrecedenceOps] [-OTRS::ProhibitOpen] [-OTRS::ProhibitRequire] [-OTRS::RequireCamelCase] [-OTRS::RequireParensWithMethods] [-ProhibitImplicitImport] [-ProhibitOrReturn] [-References::ProhibitDoubleSigils] [-RegularExpressions::ProhibitCaptureWithoutTest] [-RegularExpressions::ProhibitComplexRegexes] [-RegularExpressions::ProhibitEnumeratedClasses] [-RegularExpressions::ProhibitEscapedMetacharacters] [-RegularExpressions::ProhibitFixedStringMatches] [-RegularExpressions::RequireDefault] [-RegularExpressions::RequireDotMatchAnything] [-RegularExpressions::RequireExtendedFormatting] [-RegularExpressions::RequireExtendedFormattingExceptForSplit] [-RegularExpressions::RequireLineBoundaryMatching] [-Reneeb::ProhibitBlockEval] [-Subroutines::ProhibitAmbiguousFunctionCalls] [-Subroutines::ProhibitCallsToUndeclaredSubs] [-Subroutines::ProhibitCallsToUnexportedSubs] [-Subroutines::ProhibitExcessComplexity] [-Subroutines::ProhibitExplicitReturnUndef] [-Subroutines::ProhibitExportingUndeclaredSubs] [-Subroutines::ProhibitManyArgs] [-Subroutines::ProtectPrivateSubs] [-Subroutines::RequireArgUnpacking] [-TestingAndDebugging::ProhibitNoWarnings] [-TestingAndDebugging::RequireTestLabels] [-Tics::ProhibitLongLines] [-Tics::ProhibitManyArrows] [-TooMuchCode::ProhibitDuplicateLiteral] [-TooMuchCode::ProhibitDuplicateSub] [-TooMuchCode::ProhibitUnusedConstant] [-ValuesAndExpressions::PreventSQLInjection] [-ValuesAndExpressions::ProhibitAccessOfPrivateData] [-ValuesAndExpressions::ProhibitCommaSeparatedStatements] [-ValuesAndExpressions::ProhibitConstantPragma] [-ValuesAndExpressions::ProhibitEmptyQuotes] [-ValuesAndExpressions::ProhibitImplicitNewlines] [-ValuesAndExpressions::ProhibitMagicNumbers] [-ValuesAndExpressions::ProhibitMixedBooleanOperators] [-ValuesAndExpressions::ProhibitNoisyQuotes] [-ValuesAndExpressions::ProhibitNoisyQuotes] [-ValuesAndExpressions::RequireConstantOnLeftSideOfEquality] [-ValuesAndExpressions::RequireInterpolationOfMetachars] [-ValuesAndExpressions::RequireNumberSeparators] [-ValuesAndExpressions::RequireNumericVersion] [-ValuesAndExpressions::RestrictLongStrings] [-Variables::ProhibitConditionalDeclarations] [-Variables::ProhibitLocalVars] [-Variables::ProhibitPackageVars] [-Variables::ProhibitPunctuationVars] [-Variables::RequireHungarianNotation] [-Variables::RequireInitializationForLocalVars] [-Variables::RequireLocalizedPunctuationVars] ## Mostly needed for the test files [-BuiltinFunctions::ProhibitSleepViaSelect] [-ErrorHandling::RequireUseOfExceptions] [-Modules::PerlMinimumVersion] [-Modules::RequirePerlVersion] [-Modules::RequireVersionVar] [-ValuesAndExpressions::ProhibitEscapedCharacters] ## Does not seem to work, but here anyway: [-NamingConventions::Capitalization] [Perlsecret] allow_secrets = Bang Bang, Venus, Key of Truth DBD-Pg-3.20.2/META.json0000644000175000017500000000304015175421053012606 0ustar greggreg{ "generated_by" : "emacs", "dynamic_config" : "1", "recommends" : { "Encode" : "0", "Module::Signature" : "0.50", "Cwd" : "0" }, "name" : "DBD-Pg", "resources" : { "homepage" : "http://search.cpan.org/dist/DBD-Pg/", "MailingList" : "http://www.nntp.perl.org/group/perl.dbd.pg/", "repository" : "https://github.com/bucardo/dbdpg", "bugtracker" : "https://github.com/bucardo/dbdpg/issues", "license" : "http://dev.perl.org/licenses/", "IRC" : "irc://irc.libera.chat/#postgresql" }, "provides" : { "DBD::Pg" : { "file" : "Pg.pm", "version" : "3.20.2" }, "Bundle::DBD::Pg" : { "version" : "3.20.2", "file" : "lib/Bundle/DBD/Pg.pm" } }, "version" : "3.20.2", "requires" : { "perl" : "5.008001", "DBI" : "1.614", "version" : "0" }, "keywords" : [ "Postgres", "PostgreSQL", "DBI", "libpq", "dbdpg" ], "meta-spec" : { "url" : "http://module-build.sourceforge.net/META-spec-v1.4.html", "version" : "1.4" }, "author" : [ "Greg Sabino Mullane " ], "configure_requires" : { "DBI" : "1.614", "ExtUtils::MakeMaker" : "6.58", "version" : "0" }, "license" : "perl", "distribution_type" : "module", "build_requires" : { "File::Temp" : "0", "version" : "0", "Time::HiRes" : "0", "DBI" : "1.614", "Test::More" : "0.88" }, "abstract" : "DBI PostgreSQL interface" } DBD-Pg-3.20.2/MANIFEST.SKIP0000644000175000017500000000064215173034622013070 0ustar greggreg ^Build$ ^Makefile$ ^Makefile.old$ README.testdatabase ^Pg.c$ ^Pg.bs$ ^Pg.xsi$ ^pm_to_blib$ dbdpg_test_postgres_versions.pl MYMETA.json MYMETA.yml ^_build ^DBD-Pg ^blib ^testrun ~$ \.bak$ \.o$ \.tmp$ \.log$ \.blame$ \.asc$ \.git/* ^tmp/* cover_db/ dbdpg_test_database/* testdb/* versiontest/* t/00_release.t t/99_lint.t t/99_perlcritic.t t/99_pod.t t/99_spellcheck.t t/99_yaml.t z_tarballs/ misc/pg9.1.24.scan.c.gz DBD-Pg-3.20.2/win32.mak0000644000175000017500000000466715116315266012644 0ustar greggreg ## 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 : -@erase "$(INTDIR)\pg_config.obj" -@erase "$(OUTDIR)\pg_config.exe" -@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) $< << DBD-Pg-3.20.2/META.yml0000644000175000017500000000324015175421063012441 0ustar greggreg--- #YAML:1.0 name : DBD-Pg version : 3.20.2 abstract : DBI PostgreSQL interface author: - Greg Sabino Mullane license : perl distribution_type : module dynamic_config : 1 requires: DBI : 1.614 perl : 5.008001 version : 0 build_requires: DBI : 1.614 File::Temp : 0 Test::More : 0.88 Time::HiRes : 0 version : 0 configure_requires: DBI : 1.614 ExtUtils::MakeMaker : 6.58 version : 0 recommends: Cwd : 0 Encode : 0 Module::Signature : 0.50 provides: DBD::Pg: file : Pg.pm version : 3.20.2 Bundle::DBD::Pg: file : lib/Bundle/DBD/Pg.pm version : 3.20.2 keywords: - Postgres - PostgreSQL - DBI - libpq - dbdpg resources: homepage : http://search.cpan.org/dist/DBD-Pg/ license : http://dev.perl.org/licenses/ bugtracker : https://github.com/bucardo/dbdpg/issues repository : https://github.com/bucardo/dbdpg MailingList : http://www.nntp.perl.org/group/perl.dbd.pg/ IRC : irc://irc.libera.chat/#postgresql meta-spec: version : 1.4 url : http://module-build.sourceforge.net/META-spec-v1.4.html generated_by : emacs DBD-Pg-3.20.2/README.dev0000644000175000017500000010071315173034534012631 0ustar greggreg This file is for those interested in developing DBD::Pg. It is hoped that it will be a good introduction as well as a continual reference. Suggestions are always welcome. Note: most of this document assumes you are using a Unix-like system. Sections: * Overview * File List * Compiling * Editing * Heavy Testing * Debugging * Test Files * Version Numbers * New Files * New Methods * Making a New Release * Tips and Tricks * Resources * Ongoing maintenance ============== == 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 from the Perl.xsi file from DBI. The files Pg.pm and blib/arch/auto/DBD/Pg/Pg.so form the core of the module once installed. (The above is oversimplified). The canonical git repo is at git://github.com/bucardo/dbdpg.git The repo for DBI is: https://github.com/perl5-dbi/dbi The (mirrored) repo for Postgres is: https://github.com/postgres/postgres =============== == 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 spaces, not tabs, to indent. Try to list who found the bug, and who fixed it (if not the same person). Put the CPAN or Github ticket number in parenthesis, and put the person who made the actual changes in brackets. When in doubt, copy the existing format. Note that t/00_release.t does some simple format checking. This file contains a version number. README.dev - you are reading it. README - the main file that explains the module, where to get it, and guides people in installing it. A large portion of it is simply a list of common gotchas and guides for various platforms. This file has a version number in it (or two, if this is a beta/release candidate) README.win32 - the directions on how to install DBD::Pg on a Win32 box. Very likely to be outdated. README.testdatabase - created by the tests to cache connection information. Can be removed at will. CONTRIBUTING.md - Quick introduction on how to contribute. SECURITY.md - Security policy for the project, including how to report a security vulnerability. TODO - Rough list of possible items to fix or add. SIGNATURE - Checksum verification via PGP, generated by Module::Signature. LICENSES/gpl-2.0.txt - GPL license LICENSES/artistic.txt - Artistic (Perl) license testme.tmp.pl - Quick helper file for testing individual bugs .dir-locals.el - Emacs helper file * Build files: Makefile.PL - The main file that starts everything off. Used by ExtUtils::MakeMaker to create the "Makefile". This file contains a version number. Makefile - Generated automatically by Makefile.PL. Not part of the distribution. META.yml - YAML description file. Updated by hand and contains a version number in three places. META.json - JSON description file. Updated by hand and contains a version number in three places. lib/Bundle/DBD/Pg.pm - Simple file used to enable perl -MCPAN -e 'install Bundle::DBD::Pg' Contains a version number. MYMETA.yml, MYMETA.json - Files automatically created: can be ignored. * Distribution files: MANIFEST - lists which files should be included in the release tarball. Used by the "make dist*" set of commands. MANIFEST.SKIP - files that are known to be safe to exclude from the release tarball. Used by the "make dist", "make distcheck" and "make skipcheck" commands. win32.mak - a helper file for the win32 build. * Program files: dbdimp.c - The main C file, which does most of the heavy lifting for the DBD::Pg module (the rest is done by Pg.pm). Almost all of the complexity and power of the module is here. dbdimp.h - Header file for dbdimp.c. dbivport.h - DBI portability macros. This should be the latest version from the DBI git repository. Pg.pm - The main Perl file, which contains DBD::Pg packages and code for the methods. Often times code here calls code from Pg.xs and dbdimp.c. This file contains a version number in four places (twice in the code, twice in the POD). The main documentation for the module lives here, as POD information. Pg.xs - The Perl "glue" file for DBD::Pg. This file basically tells Perl how to handle various methods. It makes many calls to dbdimp.c Pg.c - Not part of the distribution, but created from Pg.xs as part of the build process. Never edit this directly. Pg.h - Header file for Pg.xs (and thus Pg.c) quote.c - Various methods to help quote and dequote variables. Some of this is now done on the backend, but it is still needed to support older versions of PostgreSQL. quote.h - Header file for quote.c types.c - Lists all known data types for PostgreSQL. Can be run as a perl script to check for new types; rewrites the following: types.h types.c Pg.xs Pg.pm t/01constants.t 99_pod.t types.h - Header file for types.c * Test files: dbdpg_test_postgres_versions.pl - Run the test suite against multiple versions of Postgres, both for compilation and target. Run with "--setup head,9.4,12" etc. to create Postgres directories in ~/pg, then run with no arguments to test all combinations. Specify one or more compilation versions with "-c" and one or more target versions with "-r". For example, "-c 9.4,11 -r head" t/dbdpg_test_setup.pl - Common connection, schema creation, and schema destruction subs. Goes through a lot of trouble to try and get a database to test with. t/00_release.t - Quick check that all version numbers match, some other sanity checks. t/00basic.t - Very basic test to see if DBI and DBD::Pg load properly. Requires Test::Warn for the version warning test. t/00_signature.t - Uses Module::Signature to verify SIGNATURE file. All tests are skipped if the environment variable TEST_SIGNATURE is not set. t/01connect.t - Basic connection tests, outputs pretty, detailed connection information. t/01constants.t - Quick test of pg_types. t/01keywords.t - Test is_keyword inside of quote.c t/02attribs.t - Tests all attributes. t/03dbmethod.t - Tests all database handle methods. t/03smethod.t - Tests all statement handle methods. t/04misc.t - Tests tracing, data_sources, $DBDPG_DEFAULT, and txn status changes. t/06bytea.t - Tests bytea manipulation. t/07copy.t - Tests COPY-related methods. t/08async.t - Tests asynchronous methods. t/09arrays.t - Tests array manipulation. t/10_pg_error_field.t - Tests $dbh->pg_error_field function t/12placeholders.t - Tests placeholders. t/20savepoints.t - Test savepoints. t/30unicode.t - Test Unicode. Or at least UTF8. t/99cleanup.t - Removes anything we have created for the tests (e.g. tables) t/99_lint.t - Various minor code cleanliness checks. Requires TEST_CRITIC to be set. t/99_perlcritic.t - Uses Perl::Critic to check Pg.pm and all of the test files. Requires that TEST_CRITIC is set. It is recommended that you get all the Perl::Critic policies via Bundle::Perl::Critic::IncludingOptionalDependencies. .perlcriticrc - Used by the above: we assume tests are run from the main dir. t/99_pod.t - Verifies the POD of Pg.pm. Requires Test::POD version 0.95, and Test::Pod::Coverage 1.04. t/99_yaml.t - Uses Test::YAML::Meta to verify the META.yml file. t/99_spellcheck.t - Checks the spelling of everything it can. testdb - May be created by the test suite as a place to store a new database cluster. misc/pg9.1.24.scan.c.gz - Special pre-compiled file to help Postgres 9.1 get compiled on servers with a newer flex (all of them, at this point). Used by dbdpg_test_postgres_versions.pl * 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/Handler/Print.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 -Wendif-labels -Wpointer-arith"; $comp_opts .= " -Wbad-function-cast -Wcast-qual -Wcast-align -Wconversion -Wsign-compare -Waggregate-return"; $comp_opts .= " -Wmissing-prototypes -Wmissing-declarations -Wmissing-format-attribute -Wpacked -Winline -Winvalid-pch"; $comp_opts .= " -Wdisabled-optimization"; $comp_opts .= " -Wnested-externs"; $comp_opts .= " -Wstrict-prototypes"; ## Still hits a couple places in types.h $comp_opts .= " -Wswitch-default"; $comp_opts .= " -Wsystem-headers"; $comp_opts .= " -Wmissing-noreturn"; $comp_opts .= " -Wfloat-equal"; ## Does not like SvTRUE() calls ## These options tend to produce lots of hits outside of our code, but may still be useful: $comp_opts .= " -Wpadded"; ## Use when adding/changing our structs $comp_opts .= " -pedantic"; ## Useful, but very verbose $comp_opts .= " -Wundef"; ## Complains of XSubPPtmpAAAA in Pg.c being defined/undefined but then checked raw $comp_opts .= " -Wshadow"; ## lots of bogus hits - not very useful Filter: grep warning wfile | grep -v "/usr" $comp_opts .= " -Wwrite-strings"; $comp_opts .= " -Wredundant-decls"; ## Lots of warnings from Perl itself ## These options are probably not very useful: $comp_opts .= " -Wtraditional"; ## Lots and lots of junk $comp_opts .= " -Wold-style-definition"; ## We use lots of these $comp_opts .= " -Wunreachable-code"; ## Lots due to our multi-version ifdefs Please feel free to add to and clarify the above lists. ============= == Editing == ============= All the perl files should have a cperl pragma at the top of the file, for easy use in emacs. Please use the same whitespace as surrounding code, and keep the indenting to the cperl standard. Use the traditional C mode for *.c files. Pg.xs is a special case: if you know of a good mode for editing this file, please let us know and update this paragraph! Please follow the other syntax standards in place as much as possible. A few guidelines for XS files can be found in the XS perldocs. When in doubt, go with the guidelines from Damian Conway's Perl Best Practices book. =================== == Heavy Testing == =================== Testing should be done heavily and frequently, especially before a new release. The standard way to test is run "make test" which runs all the scripts in the "t" directory. If you find yourself making your own test, even if just for a minor or a temporary problem, please add it to the test suite. The more tests we have, the better. The environment variable DBDPG_TEST_LOCALE can be set to have the test script at t/dbdpg_test_setup.pl run initdb with that locale. Otherwise, it defaults to 'C'. Generally, we want to run 'make test' on as wide a variety of configurations as possible. If you have different platforms of course, you should test all of those. Beyond that, you may find it helpful to set up some aliases to allow quick switching of Postgres and DBI versions. You should generally test each major version of PostgreSQL that DBD::Pg currently supports. Keep in mind that there are two things to test for each version: the server that we are compiling against (e.g. which libraries we are linking to) and the version we are connecting to. You should test all variations. One way is to keep multiple versions of PostgreSQL in standard directories, and use a standard port convention to keep things simple: the port is 5XXX where XXX is the version, so that PG 7.4.2 is listening on port 5742. Then set up two aliases for each version, like so: alias dbd747='export DBI_DSN="dbi:Pg:dbname=greg;port=5747"' alias dbd747m='export POSTGRES_LIB=/home/greg/pg747/lib POSTGRES_INCLUDE=/home/greg/pg747/include POSTGRES_DATA=/home/greg/pg747' This allows for quick testing of each combination: > dbd747m > dbd747 > perl Makefile.PL > make test (check output for any errors) > dbd739 > make test > dbd802 > make test > dbd739m > perl Makefile.PL > make test > dbd727 > make test > dbd802 > make test etc... It's also a good idea to test the current HEAD version of Postgres in your tests: this can detect changes nice and early. See the dbdpg_test_postgres_versions.pl file for one way to automate this. In addition to different versions of Postgres, it's a good idea to test a few versions of DBI: this has caught problems in the past. You'll basically need to install the different versions of DBI into different directories, then adjust PERL5LIB with aliases: alias dbi156='export PERL5LIB=/home/greg/perl/dbi156/lib/perl5/site_perl/5.10.0/i686-linux' alias dbi157='export PERL5LIB=/home/greg/perl/dbi157/lib/perl5/site_perl/5.10.0/i686-linux' Different encoding should also be tested: a good one for flushing out problems is BIG5, as it is not supported as a server encoding, only a client one. The simplest way to do this is to export the PGCLIENTENCODING variable to 'BIG5' before running the tests. * Using splint Another great program to use is splint, which is a "tool for statically checking C programs for security vulnerabilities and common programming mistakes." It can be found at http://www.splint.org/ It is typically run against a single C file, in our case, dbdimp.c and the generated Pg.c file. This is a very finicky tool. There is a "splint" target in the Makefile. There are three challenges to using splint: 1) Getting it to work in the first place. As the Makefile.PL section says, you need at least version 3.1.2. You also need to include all the relevant files, which Makefile.PL should do for you. Note that 'make splint' expects the TMP environment variable to be set to a writeable directory. 2) Limiting the amount of results. splint is extremely verbose, so one must usually limit what sort of things are returned. Again, the Makefile.PL has a partial list. 3) Figuring out the real problems. Again, splint's verbosity takes some getting used to, as does interpreting its output, and deciding what is really a problem and what is not. * Using valgrind We've not gotten valgrind to work against DBD::Pg, but would love to. Please email the list if you manage to do so! * Using Devel::Cover Another handy tool is the module Devel::Cover. While not totally useful as it only tests direct perl modules, it is good at giving Pg.pm the once-over. To use, install it, then run: cover -delete HARNESS_PERL_SWITCHES=-MDevel::Cover make test cover -coverage statement,branch,condition,subroutine then check out the coverage.html file inside the cover_db directory. * Using Devel::DProf This module is good for finding bottlenecks in the C portion of the code. Generally, you create a small test file that does heavy looping over some methods of interest, and then run it with: perl -d:DProf testfile.pl Then view the results with: dprofpp * Using Devel::NYTProf Another nice Perl-level profiler. To use: perl -d:NYTProf testfile.pl Then run: nytprofhtml and check out the generated HTML files. =============== == Debugging == =============== In addition to the Heavy Testing section, there are some simple aids to debugging. * Testing file It is helpful to have a standard file (e.g. ping.test.tmp) which contains some connection information and allows to easily stick in a piece of code for testing. It should run "make" to make sure everything is up to date. Here's the top of one such file: #!perl -w BEGIN { my $out = `make 2>&1`; if ($out =~ /^\w+\.[cx]s?:\d+:/ms or $out =~ /^Error/ms) { for (split /\n/ => $out) { print "MAKE ERROR: $_\n" if /^[\w\.]+:/; } exit; } use lib ".", "blib/lib", "blib/arch"; } END { print "End ping.test\n"; } BEGIN { print "Begin ping.test\n"; } use strict; use warnings; use Data::Dumper; $Data::Dumper::Deepcopy=1; use DBD::Pg; use DBI qw(:sql_types); $|=1; select((select(STDERR),$|=1)[0]); our ($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\n"; print "Server version: $VER\n"; print "Compiled version: $pgver\n"; $dbh->trace($trace); __END__ Once you have completed a test, just put it below the __END__ line in case you ever need to use it again someday. Note that the first argument to this script is the trace level. Bumping the trace level to 10 can be very helpful. If it is not helpful, consider adding some debugging statements to dbdimp.c to make it so! * Coredumps If you get a coredump, you can use the "gdb" utility to see what happened. Here's a 10-second tutorial. If "core" is the name of the core file, just use "gdb perl core", then issue a "bt" command at the gdb prompt. This will run a backtrace and give you an idea of what is causing the problem. * For really low-level debugging from the Postgres side, you can use pg_server_trace() function. * The perl debugger can also be helpful (perl -d ping.test.tmp). * Don't forget about the PostgreSQL server logs either, when investigating matters. ================ == Test Files == ================ The test files are an important part of the module. Much work has gone into making the tests as complete, thorough, and clean as possible. Please try to follow these guidelines when developing: * Whenever you add a new feature, no matter how minor, add a test. Better yet, add many tests to make sure that it not only works correctly, but that it breaks when it is supposed to (e.g. when it is fed the wrong output). Try to conceive of every possible way your feature will be used and mis-used. Consider the effects of older versions of Perl, DBI, and/or Postgres. * If someone files a bug report that is not revealed by a test, please add a new test for it, no matter how simple the fix maybe, or how stupid the bug is. * Don't create a new test file unless necessary - use the existing ones whenever possible. Most things can fit in 03dbmethod.t (database handle methods) or 03smethod.t (statement handle methods). If all else fails, consider using the 04misc.t test. New files should generally be created for a bunch of related tests that do not easily fit into the current listings. * If you do create a new test, keep the name short, start it with a number, and use an existing test as a template. * Tests should be as "standalone" as possible. Most will call dbdpg_test_setup.pl to automatically setup the test table used. It's a good idea to delete any objects your test itself creates. Objects should be created as "temporary" whenever possible. Things should be always have a name starting with "dbd_pg_test". * Don't call DBI->connect inside of your tests, but use connect_database() from the dbdpg_test_setup.pl file instead. If you don't want it to blow away and recreate the current test table and other objects, use connect_database({nosetup => 1}). * Use the standard format for tests, and always provide an appropriate output text. Abbreviations are encouraged, but be consistent throughout the file. * Make sure to test on different versions of PostgreSQL, DBI, and Perl. Use the SKIP tag with an appropriate message if a test does not work on a particular version of something (see 20savepoints.t for an example). * To run a single test, use: prove --blib . -v t/testname.t ===================== == Version Numbers == ===================== Version numbers follow the older Postgres convention: major, minor, and revision. (Note: older versions of DBD::Pg used a two-number system up until version 1.49, after which it switched to 2.0.0). The major number should very, very rarely change, and is saved for the truly major changes (e.g. those that may cause backwards compatibility problems). The minor revision is used to indicate a change in functionality, new features, etc. The revision number is used for small tweaks and bug fixes, and must be completely compatible with the version before it. Beta versions (aka release candidates) are the version with an underscore at the end of it. The tells CPAN not to consider this a "real" release. For example, if the upcoming release is 2.2.4, the first release candidate would be 2.2.3_1. A second would be 2.2.3_2 etc. Version numbers are currently set in seven files: README (one place, two if a beta version) Pg.pm (three places) Changes Makefile.PL META.yml (three places) META.json (three places) lib/Bundle/DBD/Pg.pm =============== == New Files == =============== If you are adding a new file to the distribution (and this should be a rare event), please check that you have done the following items: * Added it to git via 'git add filename' and 'git commit filename' * Added it to the MANIFEST file * Added it to Makefile.PL if needed, to make sure all build dependencies are met * Updated/created necessary tests for it * Added it to the "File List" section above. ================= == New Methods == ================= New methods and attribute names should be short and descriptive. If they are "visible", please make sure they begin with a "pg_" prefix. If you feel they should not have this prefix, make your case on the dbi-dev list. ========================== == Making a New Release == ========================== This is a comprehensive checklist of all the steps required to release a new version, whether beta or regular. It is assumed you are very familiar with the other sections referenced herein (indicated with **) * Test on variety of versions (see ** Heavy Testing), including the optional tests. * Test modules that depend on DBD::Pg, in particular DBIx::Class and DBIx::Class::Schema::Loader Do not forget to set DBICTEST_PG_DSN, DBICTEST_PG_USER, and DBICTEST_PG_PASS * Consider a pre-release announcement to dbix-class-devel@lists.scsys.co.uk * Make sure everything is up to date in git (git status) * Update the versions (see ** Version Numbers) in README, Pg.pm (3 places!), Makefile.PL, lib/Bundle/DBD/Pg.pm, META.yml and META.json (3 places each), and Changes. Run the t/00_release.t file to double check you got everything. * If a final version, put the release date into the Changes file. * If a beta version, please put a large warning at the top of the README file. Here is a sample: =================================================== WARNING!! THIS IS A TEST VERSION (2.4.1_2) AND SHOULD BE USED FOR TESTING PURPOSES ONLY. PLEASE USE A STABLE VERSION (no underscore) BY VISITING: http://search.cpan.org/dist/DBD-Pg/ =================================================== * If not a beta version, remove the above warning from the README if it exists. * Completely update the Changes file The best way to do this (other than doing it as you go along) is to check the git logs, by running a diff against the last-released version. * Update the documentation Make sure that anything new has been documented properly, usually as POD inside of Pg.pm. A good way to do this is to use the tests in 99_pod.t - they will run automatically as part of the test suite if the right modules are installed. * Run "perl Makefile.PL" * Run "make dist". Double check that the tarball created has the correct version name. * Run "make distcheck". This will show you a list of all files that are in the current directory but not inside the MANIFEST file (or the MANIFEST.SKIP file). If there are any new files here that should be part of the distribution, add them to the MANIFEST file, commit your changes, and then re-run. Note that files ending in ".tmp" are currently skipped, so this is a good extension for any miscellaneous files you have that use often (e.g. libpq-fe.h.tmp) * Run "make skipcheck". This will show you a list of files that will NOT be packed into the release tarball. Make sure there is nothing important here. * Update the SIGNATURE file with Module::Signature (e.g. make signature) You may need to add this your login script: export GPG_TTY=$(tty) * Run "make disttest". This unpacks the tarball, then runs "make" and "make test" on it. You may also want to remove the directory it creates later by using "make realclean" * Make a new git tag: git tag -u 01234abc 1.2.3 -m "Version 1.2.3, released April 1, 2015" In the example above, 01234abc is your pgp shortid and 1.2.3 is the new version number. You might need: export GPG_TTY=$(tty) * Make checksums Generate md5 and sha1 checksums of the tarball. Include this in your emails. * Test it out Download the tarball to a completely different system, unpack and test it. * Announce to the "internal" lists dbd-pg@perl.org pgsql-interfaces@postgresql.org Possible subject line: Version 3.18.0 of DBD::Pg released (Perl DBI driver for Postgres) * Upload to CPAN and test. You'll need the pause account password. The interface is fairly straightforward. Once it is loaded, wait for it to appear on the main DBD::Pg page and then test that the file has the same checksums. * Commit the SIGNATURE file. Remember the git commit hash given, and add that to the Changes files. Then commit the Changes file. * Announce to the "public" lists dbi-users@perl.org, dbi-dev@perl.org, dbi-announce@perl.org The format for DBI announcements: To: dbi-announce@perl.org Cc: dbi-users@perl.org Reply-to: dbi-users@perl.org Subject line: Name of module, version Short note of changes, link to CPAN directory. Checksums for the file. See past announcements in the z_announcements directory. * Post to pgsql-announce@postgresql.org if this is a major or important version. * Post to the "PostgreSQL news" On the main page, there is a link named "Submit News" which points to: http://www.postgresql.org/about/submitnews The content should be roughly the same as the announcement. * PostgreSQL weekly news summary The maintainers of the weekly news are usually pretty good about catching the update and adding it in. If not, bug them. http://www.postgresql.org/community/weeklynews/ * Tell Greg to post on planet.postgresql.org * If a non-beta, clean out any CPAN and github bugs, including going back and marking resolved bugs with this new version, once it appears in the choices (takes a day or two for the version to appear as a choice in the pulldown on CPAN). * Check the CPAN testers report a few days after the PAUSE upload: http://matrix.cpantesters.org/?dist=DBD-Pg * Update this file based on your experiences!! ===================== == Tips and Tricks == ===================== Also known as, the section to put things that don't fit anywhere else. Anything that may make life easier for other developers can go here. * Temporary tables We do not use temporary tables in most of our tests because they are not persistent across tests, they mess up the schema testing, and they are not compatible with the foreign key testing. But do try and use them whenever possible. * "turnstep" in the cvs/svn/git logs is Greg Sabino Mullane, greg@turnstep.com. * Use a "tmp" extension for files you keep around in the dbdpg directory, but don't want to show up when you do a "git status". They are also ignored by make dist. * Commit each file individually, unless the log message is *really* identical across all committed files (which is rare). Always give a good description of the exact changes made : assume that the log will be read independently of a diff. * Don't forget to test for memory leaks, particularly if you are working with the more complicated sections of dbdimp.c. For a quick check, enter a loop, then watch the memory size using the top tool. Here's a quick checker: $dbh->{pg_server_prepare} = 1; $dbh->{pg_direct} = 1; $dbh->do("CREATE TEMP TABLE leaktester(a int, b numeric(10,2), c text)"); $sth{'plain'} = $dbh->prepare("SELECT * from leaktester"); $sth{'place'} = $dbh->prepare("INSERT INTO leaktester(a,b,c) VALUES (?,?,?)"); my $loop = 1; while (1) { $sth{plain}->execute; $dbh->do("SELECT 123"); $dbh->quote(qq{Pi''zza!!"abc}); $sth->{pg_server_prepare}=1; $sth{place}->execute(1,2,"abc"); $sth->{pg_server_prepare}=0; $sth{place}->execute(1,2,"abc"); $sth->{pg_server_prepare}=1; $sth = $dbh->prepare("SELECT 123, ?"); $sth->bind_param(1,1,SQL_INTEGER); $sth->execute(1); $sth->finish(); $info = $dbh->selectall_arrayref("SELECT 123,456"); select(undef,undef,undef,0.1); exit if $loop++ > 10000; } =============== == Resources == =============== The primary resource is the mailing list, where the developers live. Subscribe with an email to dbd-pg-subscribe@perl.org Other resources depend on the subject: * DBD::Pg The canonical URL: http://search.cpan.org/dist/DBD-Pg/ * CPAN::Reporter test results: http://matrix.cpantesters.org/?dist=DBD-Pg * DBI The DBI developers list: http://lists.perl.org/showlist.cgi?name=dbi-dev Subscribe: dbi-dev-subscribe@perl.org The DBI users list: http://lists.perl.org/showlist.cgi?name=dbi-users Subscribe: dbi-users-subscribe@perl.org The DBI announcement list: http://lists.perl.org/showlist.cgi?name=dbi-announce Subscribe: dbi-announce-subscribe@perl.org The latest DBI: http://search.cpan.org/dist/DBI/ The source code of other DBDs can be a useful tool as well. * Postgres A good source for general questions on libpq and similar things is the pgsql-hackers list. Having a copy of the Postgres source code is invaluable as well. Using a tool like glimpse or ctags is handy to find those obscure libpq functions quickly. You also may want to keep the libpq documentation handy. All of the Postgres mailing lists: http://www.postgresql.org/community/lists/ A great source for searching the pg documentation and mailing lists is: http://www.pgsql.ru/db/pgsearch/ which allows you to limit the search by version: very helpful as we support multiple versions of PostgreSQL. There are many ways to search the Postgres mailing lists: http://postgresql.markmail.org/ http://archives.postgresql.org/ http://groups.google.com/ (add group:pgsql.*) * Perl Besides a good general understanding of Perl, it helps to learn a little bit about XS: perldoc perlapi perldoc perlclib perldoc perlguts perldoc perlxstut perldoc perlxs This is the module that does all the introductory magic: perldoc ExtUtils::MakeMaker The all important testing suite: perldoc Test perldoc Test::Harness perldoc Test::Simple perldoc Test::More perldoc Test::Pod perldoc Test::Pod::Coverage perldoc Test::YAML::Meta Other important modules: perldoc Devel::Cover perldoc Module::Signature perldoc Perl::Critic perldoc DBI::Profile Also see perldoc DBI::DBD. It's fairly old and incomplete, but still useful. ======================= = Ongoing maintenance = ======================= Keeping a project healthy requires regular maintenance. Here are some things that need to be done regularly: * Update the copyright years (yearly in January) * Copy over dbivport.h from DBI and recompile (check monthly, or when a change is noticed) * Run `perl -x types.c` against Postgres HEAD (often as possible, but once a month is fine) * Check the bug reports from github, mailing lists, etc. (monthly) * Test against latest version of DBI (upon new release, but also as often as possible) DBD-Pg-3.20.2/Pg.xs0000644000175000017500000006605015166170753012131 0ustar greggreg/* Copyright (c) 2000-2026 Greg Sabino Mullane and others: see the Changes file Portions Copyright (c) 1997-2000 Edmund Mergl Portions Copyright (c) 1994-1997 Tim Bunce You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. */ #define NEED_newSVpvn_flags #include "Pg.h" #ifdef _MSC_VER #define strncasecmp(a,b,c) _strnicmp((a),(b),(c)) #endif MODULE = DBD::Pg PACKAGE = DBD::Pg I32 constant(name=Nullch) char *name PROTOTYPE: ALIAS: PG_ACLITEM = 1033 PG_ACLITEMARRAY = 1034 PG_ANY = 2276 PG_ANYARRAY = 2277 PG_ANYCOMPATIBLE = 5077 PG_ANYCOMPATIBLEARRAY = 5078 PG_ANYCOMPATIBLEMULTIRANGE = 4538 PG_ANYCOMPATIBLENONARRAY = 5079 PG_ANYCOMPATIBLERANGE = 5080 PG_ANYELEMENT = 2283 PG_ANYENUM = 3500 PG_ANYMULTIRANGE = 4537 PG_ANYNONARRAY = 2776 PG_ANYRANGE = 3831 PG_BIT = 1560 PG_BITARRAY = 1561 PG_BOOL = 16 PG_BOOLARRAY = 1000 PG_BOX = 603 PG_BOXARRAY = 1020 PG_BPCHAR = 1042 PG_BPCHARARRAY = 1014 PG_BYTEA = 17 PG_BYTEAARRAY = 1001 PG_CHAR = 18 PG_CHARARRAY = 1002 PG_CID = 29 PG_CIDARRAY = 1012 PG_CIDR = 650 PG_CIDRARRAY = 651 PG_CIRCLE = 718 PG_CIRCLEARRAY = 719 PG_CSTRING = 2275 PG_CSTRINGARRAY = 1263 PG_DATE = 1082 PG_DATEARRAY = 1182 PG_DATEMULTIRANGE = 4535 PG_DATEMULTIRANGEARRAY = 6155 PG_DATERANGE = 3912 PG_DATERANGEARRAY = 3913 PG_EVENT_TRIGGER = 3838 PG_FDW_HANDLER = 3115 PG_FLOAT4 = 700 PG_FLOAT4ARRAY = 1021 PG_FLOAT8 = 701 PG_FLOAT8ARRAY = 1022 PG_GTSVECTOR = 3642 PG_GTSVECTORARRAY = 3644 PG_INDEX_AM_HANDLER = 325 PG_INET = 869 PG_INETARRAY = 1041 PG_INT2 = 21 PG_INT2ARRAY = 1005 PG_INT2VECTOR = 22 PG_INT2VECTORARRAY = 1006 PG_INT4 = 23 PG_INT4ARRAY = 1007 PG_INT4MULTIRANGE = 4451 PG_INT4MULTIRANGEARRAY = 6150 PG_INT4RANGE = 3904 PG_INT4RANGEARRAY = 3905 PG_INT8 = 20 PG_INT8ARRAY = 1016 PG_INT8MULTIRANGE = 4536 PG_INT8MULTIRANGEARRAY = 6157 PG_INT8RANGE = 3926 PG_INT8RANGEARRAY = 3927 PG_INTERNAL = 2281 PG_INTERVAL = 1186 PG_INTERVALARRAY = 1187 PG_JSON = 114 PG_JSONARRAY = 199 PG_JSONB = 3802 PG_JSONBARRAY = 3807 PG_JSONPATH = 4072 PG_JSONPATHARRAY = 4073 PG_LANGUAGE_HANDLER = 2280 PG_LINE = 628 PG_LINEARRAY = 629 PG_LSEG = 601 PG_LSEGARRAY = 1018 PG_MACADDR = 829 PG_MACADDR8 = 774 PG_MACADDR8ARRAY = 775 PG_MACADDRARRAY = 1040 PG_MONEY = 790 PG_MONEYARRAY = 791 PG_NAME = 19 PG_NAMEARRAY = 1003 PG_NUMERIC = 1700 PG_NUMERICARRAY = 1231 PG_NUMMULTIRANGE = 4532 PG_NUMMULTIRANGEARRAY = 6151 PG_NUMRANGE = 3906 PG_NUMRANGEARRAY = 3907 PG_OID = 26 PG_OID8 = 8256 PG_OID8ARRAY = 8261 PG_OIDARRAY = 1028 PG_OIDVECTOR = 30 PG_OIDVECTORARRAY = 1013 PG_PATH = 602 PG_PATHARRAY = 1019 PG_PG_ATTRIBUTE = 75 PG_PG_ATTRIBUTEARRAY = 270 PG_PG_BRIN_BLOOM_SUMMARY = 4600 PG_PG_BRIN_MINMAX_MULTI_SUMMARY = 4601 PG_PG_CLASS = 83 PG_PG_CLASSARRAY = 273 PG_PG_DDL_COMMAND = 32 PG_PG_DEPENDENCIES = 3402 PG_PG_LSN = 3220 PG_PG_LSNARRAY = 3221 PG_PG_MCV_LIST = 5017 PG_PG_NDISTINCT = 3361 PG_PG_NODE_TREE = 194 PG_PG_PROC = 81 PG_PG_PROCARRAY = 272 PG_PG_SNAPSHOT = 5038 PG_PG_SNAPSHOTARRAY = 5039 PG_PG_TYPE = 71 PG_PG_TYPEARRAY = 210 PG_POINT = 600 PG_POINTARRAY = 1017 PG_POLYGON = 604 PG_POLYGONARRAY = 1027 PG_RECORD = 2249 PG_RECORDARRAY = 2287 PG_REFCURSOR = 1790 PG_REFCURSORARRAY = 2201 PG_REGCLASS = 2205 PG_REGCLASSARRAY = 2210 PG_REGCOLLATION = 4191 PG_REGCOLLATIONARRAY = 4192 PG_REGCONFIG = 3734 PG_REGCONFIGARRAY = 3735 PG_REGDATABASE = 8326 PG_REGDATABASEARRAY = 8327 PG_REGDICTIONARY = 3769 PG_REGDICTIONARYARRAY = 3770 PG_REGNAMESPACE = 4089 PG_REGNAMESPACEARRAY = 4090 PG_REGOPER = 2203 PG_REGOPERARRAY = 2208 PG_REGOPERATOR = 2204 PG_REGOPERATORARRAY = 2209 PG_REGPROC = 24 PG_REGPROCARRAY = 1008 PG_REGPROCEDURE = 2202 PG_REGPROCEDUREARRAY = 2207 PG_REGROLE = 4096 PG_REGROLEARRAY = 4097 PG_REGTYPE = 2206 PG_REGTYPEARRAY = 2211 PG_TABLE_AM_HANDLER = 269 PG_TEXT = 25 PG_TEXTARRAY = 1009 PG_TID = 27 PG_TIDARRAY = 1010 PG_TIME = 1083 PG_TIMEARRAY = 1183 PG_TIMESTAMP = 1114 PG_TIMESTAMPARRAY = 1115 PG_TIMESTAMPTZ = 1184 PG_TIMESTAMPTZARRAY = 1185 PG_TIMETZ = 1266 PG_TIMETZARRAY = 1270 PG_TRIGGER = 2279 PG_TSMULTIRANGE = 4533 PG_TSMULTIRANGEARRAY = 6152 PG_TSM_HANDLER = 3310 PG_TSQUERY = 3615 PG_TSQUERYARRAY = 3645 PG_TSRANGE = 3908 PG_TSRANGEARRAY = 3909 PG_TSTZMULTIRANGE = 4534 PG_TSTZMULTIRANGEARRAY = 6153 PG_TSTZRANGE = 3910 PG_TSTZRANGEARRAY = 3911 PG_TSVECTOR = 3614 PG_TSVECTORARRAY = 3643 PG_TXID_SNAPSHOT = 2970 PG_TXID_SNAPSHOTARRAY = 2949 PG_UNKNOWN = 705 PG_UUID = 2950 PG_UUIDARRAY = 2951 PG_VARBIT = 1562 PG_VARBITARRAY = 1563 PG_VARCHAR = 1043 PG_VARCHARARRAY = 1015 PG_VOID = 2278 PG_XID = 28 PG_XID8 = 5069 PG_XID8ARRAY = 271 PG_XIDARRAY = 1011 PG_XML = 142 PG_XMLARRAY = 143 PG_ASYNC = 1 PG_OLDQUERY_CANCEL = 2 PG_OLDQUERY_WAIT = 4 CODE: if (0==ix) { if (!name) { name = GvNAME(CvGV(cv)); } croak("Unknown DBD::Pg constant '%s'", name); } else { RETVAL = ix; } OUTPUT: RETVAL INCLUDE: Pg.xsi # ------------------------------------------------------------ # db functions # ------------------------------------------------------------ MODULE=DBD::Pg PACKAGE = DBD::Pg::db SV* quote(dbh, to_quote_sv, type_sv=Nullsv) SV* dbh SV* to_quote_sv SV* type_sv CODE: { bool utf8; D_imp_dbh(dbh); SvGETMAGIC(to_quote_sv); /* Reject references other than overloaded objects (presumed stringifiable) and arrays (will make a PostgreSQL array). */ if (SvROK(to_quote_sv) && !SvAMAGIC(to_quote_sv)) { if (SvTYPE(SvRV(to_quote_sv)) != SVt_PVAV) croak("Cannot quote a reference"); to_quote_sv = pg_stringify_array(to_quote_sv, ",", imp_dbh->pg_server_version, imp_dbh->client_encoding_utf8); } /* Null is always returned as "NULL", so we can ignore any type given */ if (!SvOK(to_quote_sv)) { RETVAL = newSVpvn("NULL", 4); } else { sql_type_info_t *type_info; char *quoted; const char *to_quote; STRLEN retlen=0; STRLEN len=0; /* If no valid type is given, we default to unknown */ if (!type_sv || !SvOK(type_sv)) { type_info = pg_type_data(PG_UNKNOWN); } else { if SvMAGICAL(type_sv) (void)mg_get(type_sv); if (SvNIOK(type_sv)) { type_info = sql_type_data(SvIV(type_sv)); } else { SV **svp; /* Currently the type argument must be a hashref, so throw an exception if not */ if (!SvROK(type_sv) || SvTYPE(SvRV(type_sv)) != SVt_PVHV) croak("Second argument to quote must be a hashref"); if ((svp = hv_fetchs((HV*)SvRV(type_sv),"pg_type", 0)) != NULL) { type_info = pg_type_data(SvIV(*svp)); } else if ((svp = hv_fetchs((HV*)SvRV(type_sv),"type", 0)) != NULL) { type_info = sql_type_data(SvIV(*svp)); } else { type_info = NULL; } } if (!type_info) { if (NULL == type_info) warn("No type given, defaulting to UNKNOWN"); else warn("Unknown type %" IVdf ", defaulting to UNKNOWN", SvIV(type_sv)); type_info = pg_type_data(PG_UNKNOWN); } } /* At this point, type_info points to a valid struct, one way or another */ utf8 = imp_dbh->client_encoding_utf8 && PG_BYTEA != type_info->type_id && SQL_BLOB != type_info->type_id && SQL_BINARY != type_info->type_id && SQL_VARBINARY != type_info->type_id && SQL_LONGVARBINARY != type_info->type_id; if (SvMAGICAL(to_quote_sv)) (void)mg_get(to_quote_sv); /* avoid up- or down-grading the argument */ to_quote_sv = pg_rightgraded_sv(aTHX_ to_quote_sv, utf8); to_quote = SvPV(to_quote_sv, len); /* Need good debugging here */ quoted = type_info->quote(aTHX_ to_quote, len, &retlen, imp_dbh->pg_server_version >= 80100 ? 1 : 0); RETVAL = newSVpvn_utf8(quoted, retlen, utf8); Safefree (quoted); } } OUTPUT: RETVAL # Primarily for unit test... bool _is_keyword(const char *str) CODE: RETVAL = is_keyword(str); OUTPUT: RETVAL # ------------------------------------------------------------ # database level interface PG specific # ------------------------------------------------------------ MODULE = DBD::Pg PACKAGE = DBD::Pg::db void state(dbh) SV *dbh CODE: D_imp_dbh(dbh); ST(0) = strEQ(imp_dbh->sqlstate,"00000") ? &PL_sv_no : sv_2mortal(newSVpv(imp_dbh->sqlstate, 5)); void do(dbh, statement_sv, attr=Nullsv, ...) SV * dbh SV * statement_sv SV * attr PROTOTYPE: $$;$@ CODE: { long retval; int asyncflag = 0; char *statement; D_imp_dbh(dbh); /* Always reset the last stored sth */ imp_dbh->do_tmp_sth = NULL; statement_sv = pg_rightgraded_sv(aTHX_ statement_sv, imp_dbh->pg_utf8_flag); statement = SvPV_nolen(statement_sv); if (statement[0] == '\0') { /* Corner case */ XST_mUNDEF(0); return; } if (attr && SvROK(attr) && SvTYPE(SvRV(attr)) == SVt_PVHV) { SV **svp; if ((svp = hv_fetchs((HV*)SvRV(attr),"pg_async", 0)) != NULL) { asyncflag = (int)SvIV(*svp); } } if (items < 4) { /* No bind arguments */ /* Quick run via PQexec */ retval = pg_quickexec(dbh, statement, asyncflag); } else { /* We've got bind arguments, so we do the whole prepare/execute route */ imp_sth_t *imp_sth; SV * const sth = dbixst_bounce_method("prepare", 3); if (!SvROK(sth)) XSRETURN_UNDEF; imp_sth = (imp_sth_t*)(DBIh_COM(sth)); if (!dbdxst_bind_params(sth, imp_sth, items-2, ax+2)) XSRETURN_UNDEF; imp_sth->async_flag = asyncflag; imp_dbh->do_tmp_sth = imp_sth; retval = dbd_st_execute(sth, imp_sth); } if (retval == 0) XST_mPV(0, "0E0"); else if (retval < -1) XST_mUNDEF(0); else XST_mIV(0, retval); } void _ping(dbh) SV * dbh CODE: ST(0) = sv_2mortal(newSViv(dbd_db_ping(dbh))); void getfd(dbh) SV * dbh CODE: int ret; D_imp_dbh(dbh); ret = pg_db_getfd(imp_dbh); ST(0) = sv_2mortal( newSViv( ret ) ); void pg_endcopy(dbh) SV * dbh CODE: ST(0) = (pg_db_endcopy(dbh)!=0) ? &PL_sv_no : &PL_sv_yes; void pg_error_field(dbh, fieldname) SV * dbh char * fieldname; CODE: /* pg_db_error_field() modifies its argument, so make a copy */ char *tmp = savepv(fieldname); SAVEFREEPV(tmp); ST(0) = pg_db_error_field(dbh, tmp); void pg_notifies(dbh) SV * dbh CODE: D_imp_dbh(dbh); ST(0) = pg_db_pg_notifies(dbh, imp_dbh); void pg_savepoint(dbh,name) SV * dbh char * name CODE: D_imp_dbh(dbh); if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh)) warn("savepoint ineffective with AutoCommit enabled"); ST(0) = (pg_db_savepoint(dbh, imp_dbh, name)!=0) ? &PL_sv_yes : &PL_sv_no; void pg_rollback_to(dbh,name) SV * dbh char * name CODE: D_imp_dbh(dbh); if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh)) warn("rollback_to ineffective with AutoCommit enabled"); ST(0) = (pg_db_rollback_to(dbh, imp_dbh, name)!=0) ? &PL_sv_yes : &PL_sv_no; void pg_release(dbh,name) SV * dbh char * name CODE: D_imp_dbh(dbh); if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh)) warn("release ineffective with AutoCommit enabled"); ST(0) = (pg_db_release(dbh, imp_dbh, name)!=0) ? &PL_sv_yes : &PL_sv_no; void pg_lo_creat(dbh, mode) SV * dbh int mode CODE: const unsigned int ret = pg_db_lo_creat(dbh, mode); ST(0) = (ret > 0) ? sv_2mortal(newSVuv(ret)) : &PL_sv_undef; void pg_lo_open(dbh, lobjId, mode) SV * dbh unsigned int lobjId int mode CODE: const int ret = pg_db_lo_open(dbh, lobjId, mode); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_write(dbh, fd, buf, len) SV * dbh int fd char * buf size_t len CODE: const int ret = pg_db_lo_write(dbh, fd, buf, len); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_read(dbh, fd, buf, len) SV * dbh int fd char * buf size_t len PREINIT: SV * const bufsv = SvROK(ST(2)) ? SvRV(ST(2)) : ST(2); int ret; CODE: sv_setpvn(bufsv,"",0); /* Make sure we can grow it safely */ buf = SvGROW(bufsv, len + 1); ret = pg_db_lo_read(dbh, fd, buf, len); if (ret > 0) { SvCUR_set(bufsv, ret); *SvEND(bufsv) = '\0'; sv_setpvn(ST(2), buf, (unsigned)ret); SvSETMAGIC(ST(2)); } ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_lseek(dbh, fd, offset, whence) SV * dbh int fd IV offset int whence ALIAS: pg_lo_lseek64 = 1 CODE: const IV ret = pg_db_lo_lseek(dbh, fd, offset, whence); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_tell(dbh, fd) SV * dbh int fd ALIAS: pg_lo_tell64 = 1 CODE: const IV ret = pg_db_lo_tell(dbh, fd); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_truncate(dbh, fd, len) SV * dbh int fd UV len ALIAS: pg_lo_truncate64 = 1 CODE: const IV ret = pg_db_lo_truncate(dbh, fd, len); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_close(dbh, fd) SV * dbh int fd CODE: ST(0) = (pg_db_lo_close(dbh, fd) >= 0) ? &PL_sv_yes : &PL_sv_no; void pg_lo_unlink(dbh, lobjId) SV * dbh unsigned int lobjId CODE: ST(0) = (pg_db_lo_unlink(dbh, lobjId) >= 1) ? &PL_sv_yes : &PL_sv_no; void pg_lo_import(dbh, filename) SV * dbh char * filename CODE: const unsigned int ret = pg_db_lo_import(dbh, filename); ST(0) = (ret > 0) ? sv_2mortal(newSVuv(ret)) : &PL_sv_undef; void pg_lo_import_with_oid(dbh, filename, lobjId) SV * dbh char * filename unsigned int lobjId CODE: const unsigned int ret = (lobjId==0) ? pg_db_lo_import(dbh, filename) : pg_db_lo_import_with_oid(dbh, filename, lobjId); ST(0) = (ret > 0) ? sv_2mortal(newSVuv(ret)) : &PL_sv_undef; void pg_lo_export(dbh, lobjId, filename) SV * dbh unsigned int lobjId char * filename CODE: ST(0) = (pg_db_lo_export(dbh, lobjId, filename) >= 1) ? &PL_sv_yes : &PL_sv_no; void lo_creat(dbh, mode) SV * dbh int mode CODE: const unsigned int ret = pg_db_lo_creat(dbh, mode); ST(0) = (ret > 0) ? sv_2mortal(newSVuv(ret)) : &PL_sv_undef; void lo_open(dbh, lobjId, mode) SV * dbh unsigned int lobjId int mode CODE: const int ret = pg_db_lo_open(dbh, lobjId, mode); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void lo_write(dbh, fd, buf, len) SV * dbh int fd char * buf size_t len CODE: const int ret = pg_db_lo_write(dbh, fd, buf, len); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void lo_read(dbh, fd, buf, len) SV * dbh int fd char * buf size_t len PREINIT: SV * const bufsv = SvROK(ST(2)) ? SvRV(ST(2)) : ST(2); int ret; CODE: sv_setpvn(bufsv,"",0); /* Make sure we can grow it safely */ buf = SvGROW(bufsv, len + 1); ret = pg_db_lo_read(dbh, fd, buf, len); if (ret > 0) { SvCUR_set(bufsv, ret); *SvEND(bufsv) = '\0'; sv_setpvn(ST(2), buf, (unsigned)ret); SvSETMAGIC(ST(2)); } ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void lo_lseek(dbh, fd, offset, whence) SV * dbh int fd int offset int whence CODE: const int ret = pg_db_lo_lseek(dbh, fd, offset, whence); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void lo_tell(dbh, fd) SV * dbh int fd CODE: const int ret = pg_db_lo_tell(dbh, fd); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void lo_close(dbh, fd) SV * dbh int fd CODE: ST(0) = (pg_db_lo_close(dbh, fd) >= 0) ? &PL_sv_yes : &PL_sv_no; void lo_unlink(dbh, lobjId) SV * dbh unsigned int lobjId CODE: ST(0) = (pg_db_lo_unlink(dbh, lobjId) >= 1) ? &PL_sv_yes : &PL_sv_no; void lo_import(dbh, filename) SV * dbh char * filename CODE: const unsigned int ret = pg_db_lo_import(dbh, filename); ST(0) = (ret > 0) ? sv_2mortal(newSVuv(ret)) : &PL_sv_undef; void lo_export(dbh, lobjId, filename) SV * dbh unsigned int lobjId char * filename CODE: ST(0) = (pg_db_lo_export(dbh, lobjId, filename) >= 1) ? &PL_sv_yes : &PL_sv_no; void pg_putline(dbh, buf) SV * dbh SV * buf CODE: ST(0) = (pg_db_putline(dbh, buf)!=0) ? &PL_sv_no : &PL_sv_yes; void putline(dbh, buf) SV * dbh SV * buf CODE: ST(0) = (pg_db_putline(dbh, buf)!=0) ? &PL_sv_no : &PL_sv_yes; void pg_getline(dbh, buf, len) PREINIT: SV *bufsv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); INPUT: SV * dbh unsigned int len char * buf CODE: int ret; bufsv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); sv_setpvn(bufsv,"",0); /* Make sure we can grow it safely */ buf = SvGROW(bufsv, 3); if (len > 3) buf = SvGROW(bufsv, len); ret = pg_db_getline(dbh, bufsv, (int)len); sv_setpv((SV*)ST(1), buf); SvSETMAGIC(ST(1)); ST(0) = (-1 != ret) ? &PL_sv_yes : &PL_sv_no; I32 pg_getcopydata(dbh, dataline) INPUT: SV * dbh CODE: RETVAL = pg_db_getcopydata(dbh, SvROK(ST(1)) ? SvRV(ST(1)) : ST(1), 0); OUTPUT: RETVAL I32 pg_getcopydata_async(dbh, dataline) INPUT: SV * dbh CODE: RETVAL = pg_db_getcopydata(dbh, SvROK(ST(1)) ? SvRV(ST(1)) : ST(1), 1); OUTPUT: RETVAL I32 pg_putcopydata(dbh, dataline) INPUT: SV * dbh SV * dataline CODE: RETVAL = pg_db_putcopydata(dbh, dataline); OUTPUT: RETVAL I32 pg_putcopyend(dbh) INPUT: SV * dbh CODE: RETVAL = pg_db_putcopyend(dbh); OUTPUT: RETVAL void getline(dbh, buf, len) PREINIT: SV *bufsv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); INPUT: SV * dbh unsigned int len char * buf CODE: int ret; sv_setpvn(bufsv,"",0); /* Make sure we can grow it safely */ buf = SvGROW(bufsv, 3); if (len > 3) buf = SvGROW(bufsv, len); ret = pg_db_getline(dbh, bufsv, (int)len); sv_setpv((SV*)ST(1), buf); SvSETMAGIC(ST(1)); ST(0) = (-1 != ret) ? &PL_sv_yes : &PL_sv_no; void endcopy(dbh) SV * dbh CODE: ST(0) = (-1 != pg_db_endcopy(dbh)) ? &PL_sv_yes : &PL_sv_no; void pg_server_trace(dbh,fh) SV * dbh FILE * fh CODE: pg_db_pg_server_trace(dbh,fh); void pg_server_untrace(dbh) SV * dbh CODE: pg_db_pg_server_untrace(dbh); void _pg_type_info (type_sv=Nullsv) SV* type_sv CODE: { int type_num = 0; if (type_sv && SvOK(type_sv)) { sql_type_info_t *type_info; if SvMAGICAL(type_sv) (void)mg_get(type_sv); type_info = pg_type_data(SvIV(type_sv)); type_num = type_info ? type_info->type.sql : SQL_VARCHAR; } ST(0) = sv_2mortal( newSViv( type_num ) ); } int pg_continue_connect(dbh) SV* dbh CODE: RETVAL = pg_db_continue_connect(dbh); OUTPUT: RETVAL void pg_result(dbh) SV * dbh CODE: int ret; D_imp_dbh(dbh); ret = pg_db_result(dbh, imp_dbh); if (ret == 0) XST_mPV(0, "0E0"); else if (ret < -1) XST_mUNDEF(0); else XST_mIV(0, ret); void pg_ready(dbh) SV *dbh CODE: D_imp_dbh(dbh); ST(0) = sv_2mortal(newSViv(pg_db_ready(dbh, imp_dbh))); void pg_send_cancel(dbh) SV *dbh CODE: D_imp_dbh(dbh); ST(0) = pg_db_send_cancel(dbh, imp_dbh) ? &PL_sv_yes : &PL_sv_no; void pg_cancel(dbh) SV *dbh CODE: D_imp_dbh(dbh); ST(0) = pg_db_cancel(dbh, imp_dbh) ? &PL_sv_yes : &PL_sv_no; # -- end of DBD::Pg::db # ------------------------------------------------------------ # statement level interface PG specific # ------------------------------------------------------------ MODULE = DBD::Pg PACKAGE = DBD::Pg::st void state(sth) SV *sth; CODE: D_imp_sth(sth); D_imp_dbh_from_sth; ST(0) = strEQ(imp_dbh->sqlstate,"00000") ? &PL_sv_no : sv_2mortal(newSVpv(imp_dbh->sqlstate, 5)); void pg_ready(sth) SV *sth CODE: D_imp_sth(sth); D_imp_dbh_from_sth; ST(0) = sv_2mortal(newSViv(pg_db_ready(sth, imp_dbh))); void pg_cancel(sth) SV *sth CODE: D_imp_sth(sth); ST(0) = pg_db_cancel_sth(sth, imp_sth) ? &PL_sv_yes : &PL_sv_no; void cancel(sth) SV *sth CODE: D_imp_sth(sth); ST(0) = dbd_st_cancel(sth, imp_sth) ? &PL_sv_yes : &PL_sv_no; void pg_result(sth) SV * sth CODE: long ret; D_imp_sth(sth); D_imp_dbh_from_sth; ret = pg_db_result(sth, imp_dbh); if (ret == 0) XST_mPV(0, "0E0"); else if (ret < -1) XST_mUNDEF(0); else XST_mIV(0, ret); SV* pg_canonical_ids(sth) SV *sth CODE: D_imp_sth(sth); RETVAL = dbd_st_canonical_ids(sth, imp_sth); OUTPUT: RETVAL SV* pg_canonical_names(sth) SV *sth CODE: D_imp_sth(sth); RETVAL = dbd_st_canonical_names(sth, imp_sth); OUTPUT: RETVAL # end of Pg.xs DBD-Pg-3.20.2/LICENSES/0000755000175000017500000000000015175422003012371 5ustar greggregDBD-Pg-3.20.2/LICENSES/gpl-2.0.txt0000644000175000017500000004310315116315266014221 0ustar greggreg GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. DBD-Pg-3.20.2/LICENSES/artistic.txt0000644000175000017500000001517215116315266014771 0ustar greggreg The Artistic License August 15, 1997 Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a. place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b. use the modified Package only within your corporation or organization. c. rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d. make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a. distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b. accompany the distribution with the machine-readable source of the Package with your modifications. c. give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d. make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End DBD-Pg-3.20.2/CONTRIBUTING.md0000644000175000017500000000247115157052770013433 0ustar greggreg# How to Contribute Help with DBD::Pg is always welcome. You do not have to know any code to help out - we also need help testing, answering questions, improving documentation, etc. ## Issues Bugs and problems can be reported at: https://github.com/bucardo/dbdpg/issues ## Questions Questions about usage can be answered in a number of places: ### IRC You may find helpful people at #postgresql on irc.libera.chat Lower volume but more technical discussions happen at #dbi on irc.perl.org ### Slack The Slack channel #general at postgresteam.slack.com is full of helpful people ### Email There is a low-volume mailing list for discussion about this module Send an email to . Before doing so, you probably want to subscribe by sending an email to dbd-pg-subscribe@perl.org ## Testing You can help by testing DBD::Pg as widely as possible. Running the tests on a wide variety of platforms, Postgres versions, DBI versions, and other factors is a great help in uncovering problems and improving DBD::Pg ## Code development Development happens in a git repo. The canonical location is currently at https://github.com/bucardo/dbdpg Create your own copy of the repo by running: git clone https://github.com/bucardo/dbdpg.git See the README.dev file for more information about developing DBD::Pg DBD-Pg-3.20.2/dbdimp.c0000644000175000017500000064362315175421043012610 0ustar greggreg/* Copyright (c) 2002-2026 Greg Sabino Mullane and others: see the Changes file 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" #if defined (_WIN32) && !defined (atoll) #define atoll(X) _atoi64(X) #endif #ifndef SvIsBOOL #define SvIsBOOL(sv) DBDPG_FALSE #endif #if PGLIBVERSION < 80300 Oid lo_truncate (PGconn *conn, int fd, size_t len); Oid lo_truncate (PGconn *conn, int fd, size_t len) { croak ("Cannot use lo_truncate unless compiled against Postgres 8.3 or later"); } #endif #if PGLIBVERSION < 80400 Oid lo_import_with_oid (PGconn *conn, char *filename, unsigned int lobjId); Oid lo_import_with_oid (PGconn *conn, char *filename, unsigned int lobjId) { croak ("Cannot use lo_import_with_oid unless compiled against Postgres 8.4 or later"); } #endif #ifndef PG_DIAG_SCHEMA_NAME #define PG_DIAG_SCHEMA_NAME 's' #define PG_DIAG_TABLE_NAME 't' #define PG_DIAG_COLUMN_NAME 'c' #define PG_DIAG_DATATYPE_NAME 'd' #define PG_DIAG_CONSTRAINT_NAME 'n' #endif #ifndef PG_DIAG_SEVERITY_NONLOCALIZED #define PG_DIAG_SEVERITY_NONLOCALIZED 'V' #endif #ifndef PGErrorVerbosity typedef enum { PGERROR_TERSE, /* single-line error messages */ PGERROR_DEFAULT, /* recommended style */ PGERROR_VERBOSE /* all the facts, ma'am */ } PGErrorVerbosity; #endif typedef enum { PQTYPE_UNKNOWN, PQTYPE_EXEC, PQTYPE_PARAMS, PQTYPE_PREPARED, } PQExecType; #define IS_DBI_HANDLE(h) \ (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV && \ SvRMAGICAL(SvRV(h)) && (SvMAGIC(SvRV(h)))->mg_type == 'P') enum { STH_ASYNC_AUTOERROR = -2, /* PG_OLDQUERY_WAIT auto-retrieved an error result */ STH_ASYNC_CANCELLED = -1, STH_NO_ASYNC, STH_ASYNC, STH_ASYNC_PREPARE, STH_ASYNC_AUTORETRIEVED /* PG_OLDQUERY_WAIT auto-retrieved results */ }; enum { DBH_ASYNC_CANCELLED = -1, DBH_NO_ASYNC, DBH_ASYNC, DBH_ASYNC_CONNECT, DBH_ASYNC_CONNECT_POLL }; static void pg_error(pTHX_ SV *h, int error_num, const char *error_msg); static void pg_warn (void * arg, const char * message); static ExecStatusType _result(pTHX_ imp_dbh_t *imp_dbh, const char *sql); static void _fatal_sqlstate(pTHX_ imp_dbh_t *imp_dbh); static ExecStatusType _sqlstate(pTHX_ imp_dbh_t *imp_dbh, PGresult *result); static int pg_db_rollback_commit (pTHX_ SV *dbh, imp_dbh_t *imp_dbh, int action); static SV *pg_st_placeholder_key (imp_sth_t *imp_sth, ph_t *currph, int i); static void pg_st_split_statement (pTHX_ imp_sth_t *imp_sth, char *statement); static int pg_st_prepare_statement (pTHX_ SV *sth, imp_sth_t *imp_sth); static int pg_st_deallocate_statement(pTHX_ SV *sth, imp_sth_t *imp_sth); static PGTransactionStatusType pg_db_txn_status (pTHX_ imp_dbh_t *imp_dbh); static int pg_db_start_txn (pTHX_ SV *dbh, imp_dbh_t *imp_dbh); static int handle_old_async(pTHX_ SV * handle, imp_dbh_t * imp_dbh, const int asyncflag); static void pg_db_detect_client_encoding_utf8(pTHX_ imp_dbh_t *imp_dbh); static int do_send_cancel(SV *h, imp_dbh_t *imp_dbh, char const *caller) { dTHX; PGcancel *cancel; char errbuf[256]; /* Get the cancel structure */ TRACE_PQGETCANCEL; cancel = PQgetCancel(imp_dbh->conn); /* This almost always works. If not, free our structure and complain loudly */ TRACE_PQCANCEL; if (! PQcancel(cancel,errbuf,sizeof(errbuf))) { TRACE_PQFREECANCEL; PQfreeCancel(cancel); if (TRACEWARN_slow) { TRC(DBILOGFP, "%sPQcancel failed: %s\n", THEADER_slow, errbuf); } _fatal_sqlstate(aTHX_ imp_dbh); pg_error(aTHX_ h, PGRES_FATAL_ERROR, "PQcancel failed"); if (TEND_slow) TRC(DBILOGFP, "%sEnd %s (error: cancel failed)\n", THEADER_slow, caller); return DBDPG_FALSE; } TRACE_PQFREECANCEL; PQfreeCancel(cancel); return DBDPG_TRUE; } /* ================================================================== */ void dbd_init (dbistate_t *dbistate) { dTHX; DBISTATE_INIT; } /* ================================================================== */ static int want_async_connect(pTHX_ SV *attrs) { SV **psv, *sv; return attrs && (psv = hv_fetchs((HV *)SvRV(attrs), "pg_async_connect", 0)) && (sv = *psv) && SvTRUE(sv); } static int after_connect_init(pTHX_ SV *dbh, imp_dbh_t * imp_dbh) { /* Figure out what protocol this server is using (most likely 3) */ TRACE_PQPROTOCOLVERSION; imp_dbh->pg_protocol = PQprotocolVersion(imp_dbh->conn); /* Figure out this particular backend's version */ TRACE_PQSERVERVERSION; imp_dbh->pg_server_version = PQserverVersion(imp_dbh->conn); if (imp_dbh->pg_server_version < 80000) { /* Special workaround for PgBouncer, which has the unfortunate habit of modifying 'server_version', something it should never do. If we think this is the case for the version failure, we simply allow things to continue with a faked version. See github issue #47 */ TRACE_PQPARAMETERSTATUS; const char *sv = PQparameterStatus(imp_dbh->conn, "server_version"); if (NULL != sv && NULL != strstr(sv, "bouncer")) { imp_dbh->pg_server_version = 90600; } else { TRACE_PQERRORMESSAGE; strncpy(imp_dbh->sqlstate, "08001", 6); /* sqlclient_unable_to_establish_sqlconnection */ pg_error(aTHX_ dbh, CONNECTION_BAD, "Server version 8.0 required"); TRACE_PQFINISH; PQfinish(imp_dbh->conn); imp_dbh->conn = NULL; sv_free((SV *)imp_dbh->savepoints); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_db_login (error)\n", THEADER_slow); return 1; } } pg_db_detect_client_encoding_utf8(aTHX_ imp_dbh); /* If the client_encoding is UTF8, flip the utf8 flag until convinced otherwise */ imp_dbh->pg_utf8_flag = imp_dbh->client_encoding_utf8; /* Tell DBI that we should call destroy when the handle dies */ DBIc_IMPSET_on(imp_dbh); /* Tell DBI that we should call disconnect when the handle dies */ DBIc_ACTIVE_on(imp_dbh); return 0; } int dbd_db_login6 (SV * dbh, imp_dbh_t * imp_dbh, char * dbname, char * uid, char * pwd, SV *attr) { dTHR; dTHX; char * conn_str; char * dest; bool inquote = DBDPG_FALSE; STRLEN connect_string_size; ConnStatusType connstatus; int async_connect; int retval = 1; async_connect = want_async_connect(aTHX_ attr); if (TSTART_slow) { TRC(DBILOGFP, "%sBegin dbd_db_login6\n", THEADER_slow); if (async_connect) TRC(DBILOGFP, "%sAsync connect requested\n", THEADER_slow); } /* DBD::Pg syntax: 'dbname=dbname;host=host;port=port', 'User', 'Pass' */ /* 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 (*uid) connect_string_size += strlen("user='' ") + 2*strlen(uid); if (*pwd) 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 single-quoted */ dest = conn_str; while (*dbname != '\0') { if (';' == *dbname && !inquote) *dest++ = ' '; else { if ('\\' == *dbname && *(dbname+1) != '\0') *dest++ = *dbname++; 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 (*uid) { 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 (*pwd) { 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, "'"); } /* Remove any stored savepoint information */ if (imp_dbh->savepoints) { av_undef(imp_dbh->savepoints); sv_free((SV *)imp_dbh->savepoints); } imp_dbh->savepoints = newAV(); /* freed in dbd_db_destroy */ /* Close any old connection and free memory, just in case */ if (imp_dbh->conn) { TRACE_PQFINISH; PQfinish(imp_dbh->conn); imp_dbh->conn = NULL; } /* Attempt the connection to the database */ if (TLOGIN_slow) TRC(DBILOGFP, "%sLogin connection string: (%s)\n", THEADER_slow, conn_str); if (async_connect) { TRACE_PQCONNECTSTART; imp_dbh->conn = PQconnectStart(conn_str); if (TLOGIN_slow) TRC(DBILOGFP, "%sConnection started\n", THEADER_slow); } else { TRACE_PQCONNECTDB; imp_dbh->conn = PQconnectdb(conn_str); if (TLOGIN_slow) TRC(DBILOGFP, "%sConnection complete\n", THEADER_slow); } Safefree(conn_str); /* Set the initial sqlstate */ Renew(imp_dbh->sqlstate, 6, char); /* freed in dbd_db_destroy */ strncpy(imp_dbh->sqlstate, "25P01", 6); /* "NO ACTIVE SQL TRANSACTION" */ /* Check to see that the backend connection was successfully made */ TRACE_PQSTATUS; connstatus = PQstatus(imp_dbh->conn); if (CONNECTION_OK == connstatus) async_connect = 0; else if (CONNECTION_BAD == connstatus) { strncpy(imp_dbh->sqlstate, "08006", 6); /* "CONNECTION FAILURE" */ TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, connstatus, PQerrorMessage(imp_dbh->conn)); TRACE_PQFINISH; PQfinish(imp_dbh->conn); imp_dbh->conn = NULL; sv_free((SV *)imp_dbh->savepoints); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_db_login (error)\n", THEADER_slow); return 0; } /* Call the pg_warn function anytime this connection raises a notice */ TRACE_PQSETNOTICEPROCESSOR; (void)PQsetNoticeProcessor(imp_dbh->conn, pg_warn, (void *)SvRV(dbh)); imp_dbh->pg_enable_utf8 = -1; imp_dbh->prepare_now = DBDPG_FALSE; imp_dbh->done_begin = DBDPG_FALSE; imp_dbh->dollaronly = DBDPG_FALSE; imp_dbh->nocolons = DBDPG_FALSE; imp_dbh->ph_escaped = DBDPG_TRUE; imp_dbh->expand_array = DBDPG_TRUE; imp_dbh->txn_read_only = DBDPG_FALSE; imp_dbh->pid_number = getpid(); imp_dbh->server_prepare = DBDPG_TRUE; imp_dbh->prepare_number = 1; imp_dbh->switch_prepared = 2; imp_dbh->copystate = 0; imp_dbh->copybinary = DBDPG_FALSE; imp_dbh->pg_errorlevel = 1; /* Default */ imp_dbh->async_status = DBH_NO_ASYNC; imp_dbh->async_sth = NULL; imp_dbh->last_result = NULL; /* NULL or the last PGresult returned by a database or statement handle */ imp_dbh->result_clearable = DBDPG_TRUE; imp_dbh->pg_int8_as_string = DBDPG_FALSE; imp_dbh->skip_deallocate = DBDPG_FALSE; /* if not connecting asynchronously, do after connect init */ imp_dbh->pg_protocol = -1; imp_dbh->pg_server_version = -1; if (async_connect) imp_dbh->async_status = DBH_ASYNC_CONNECT; else retval = ! after_connect_init(aTHX_ dbh, imp_dbh); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_db_login\n", THEADER_slow); return retval; } /* end of dbd_db_login */ int pg_db_continue_connect(SV *dbh) { dTHX; D_imp_dbh(dbh); int status; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_continue_connect\n", THEADER_slow); switch (imp_dbh->async_status) { default: pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, "No async connect in progress\n"); status = -1; break; case DBH_ASYNC_CONNECT: imp_dbh->async_status = DBH_ASYNC_CONNECT_POLL; status = PGRES_POLLING_WRITING; break; case DBH_ASYNC_CONNECT_POLL: TRACE_PQCONNECTPOLL; status = PQconnectPoll(imp_dbh->conn); if (TRACE5_slow) TRC(DBILOGFP, "%sPQconnectPoll returned %d\n", THEADER_slow, status); switch (status) { case PGRES_POLLING_READING: case PGRES_POLLING_WRITING: break; case PGRES_POLLING_OK: if (TLOGIN_slow) TRC(DBILOGFP, "%sconnection established\n", THEADER_slow); imp_dbh->async_status = DBH_NO_ASYNC; status = after_connect_init(aTHX_ dbh, imp_dbh) ? -2 : 0; break; case PGRES_POLLING_FAILED: strncpy(imp_dbh->sqlstate, "08006", 6); /* "CONNECTION FAILURE" */ TRACE_PQSTATUS; TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, PQstatus(imp_dbh->conn), PQerrorMessage(imp_dbh->conn)); TRACE_PQFINISH; PQfinish(imp_dbh->conn); imp_dbh->conn = NULL; imp_dbh->async_status = DBH_NO_ASYNC; status = -2; } } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_continue_connect\n", THEADER_slow); return status; } /* ================================================================== */ /* Database specific error handling. */ static void pg_error (pTHX_ SV * h, int error_num, const char * error_msg) { D_imp_xxh(h); size_t error_len; imp_dbh_t * imp_dbh = (imp_dbh_t *)(DBIc_TYPE(imp_xxh) == DBIt_ST ? DBIc_PARENT_COM(imp_xxh) : imp_xxh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_error (message: %s number: %d)\n", THEADER_slow, error_msg, error_num); error_len = strlen(error_msg); /* Strip final newline so line number appears for warn/die */ if (error_len > 0 && error_msg[error_len-1] == 10) error_len--; sv_setiv(DBIc_ERR(imp_xxh), (IV)error_num); sv_setpv(DBIc_STATE(imp_xxh), (char*)imp_dbh->sqlstate); /* We need a special exception for cases in which libpq doesn't know what the error was, and Postgres returns nothing. Probably client_min_messages is boosted too high. See CPAN ticket #109591 */ if (7 == error_num && 0 == error_len) { sv_setpvn(DBIc_ERRSTR(imp_xxh), "No error returned from Postgres. Perhaps client_min_messages is set too high?", 77); } else { sv_setpvn(DBIc_ERRSTR(imp_xxh), error_msg, error_len); } /* Set as utf-8 */ if (imp_dbh->pg_utf8_flag) SvUTF8_on(DBIc_ERRSTR(imp_xxh)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_error\n", THEADER_slow); } /* end of pg_error */ /* ================================================================== */ /* Turn database notices into perl warnings for proper handling. */ static void pg_warn (void * arg, const char * message) { dTHX; SV *tmp; tmp = sv_2mortal(newRV_inc((SV *)arg)); /* This fun little bit is to prevent a core dump when the following occurs: client_min_messages is set to DEBUG3 or greater, and we exit without a disconnect. DBI issues a 'rollback' in this case, which causes some debugging messages to be emitted from the server (such as "StartTransactionCommand"). However, we can't do the D_imp_dbh call anymore, because the underlying dbh has lost some of its magic. Unfortunately, DBI then coredumps in dbh_getcom2. Hence, we make sure that the object passed in is still 'valid', in that a certain level has a ROK flag. If it's not, we just return without issuing any warning, as we can't check things like DBIc_WARN. There may be a better way of handling all this, and we may want to default to always warn() - input welcome. */ if (!SvROK(SvMAGIC(SvRV(tmp))->mg_obj)) { return; } else { D_imp_dbh(tmp); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_warn (message: %s DBIc_WARN: %d PrintWarn: %d)\n", THEADER_slow, message, DBIc_WARN(imp_dbh) ? 1 : 0, DBIc_is(imp_dbh, DBIcf_PrintWarn) ? 1 : 0); if (DBIc_WARN(imp_dbh) && DBIc_is(imp_dbh, DBIcf_PrintWarn)) warn("%s", message); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_warn\n", THEADER_slow); } } /* end of pg_warn */ /* ================================================================== */ /* Quick command executor used throughout this file */ static ExecStatusType _result(pTHX_ imp_dbh_t * imp_dbh, const char * sql) { ExecStatusType status; if (TSTART_slow) TRC(DBILOGFP, "%sBegin _result (sql: %s)\n", THEADER_slow, sql); if (TSQL) TRC(DBILOGFP, "%s;\n\n", sql); /* Free the last_result as needed, as we are about to replace it */ if (imp_dbh->last_result && imp_dbh->result_clearable) { TRACE_PQCLEAR; PQclear(imp_dbh->last_result); imp_dbh->last_result = NULL; } TRACE_PQEXEC; imp_dbh->last_result = PQexec(imp_dbh->conn, sql); imp_dbh->result_clearable = DBDPG_TRUE; status = _sqlstate(aTHX_ imp_dbh, imp_dbh->last_result); if (TEND_slow) TRC(DBILOGFP, "%sEnd _result\n", THEADER_slow); return status; } /* end of _result */ /* ================================================================== */ /* Set the SQLSTATE for a 'fatal' error */ static void _fatal_sqlstate(pTHX_ imp_dbh_t * imp_dbh) { char *sqlstate; TRACE_PQSTATUS; sqlstate = PQstatus(imp_dbh->conn) == CONNECTION_BAD ? "08000" : /* CONNECTION EXCEPTION */ "22000"; /* DATA EXCEPTION */ strncpy(imp_dbh->sqlstate, sqlstate, 6); } /* ================================================================== */ /* Set the SQLSTATE based on a result, returns the status */ static ExecStatusType _sqlstate(pTHX_ imp_dbh_t * imp_dbh, PGresult * result) { char *sqlstate; ExecStatusType status = PGRES_FATAL_ERROR; /* until proven otherwise */ if (TSTART_slow) TRC(DBILOGFP, "%sBegin _sqlstate\n", THEADER_slow); if (result) { TRACE_PQRESULTSTATUS; status = PQresultStatus(result); } sqlstate = NULL; /* Because PQresultErrorField may not work completely when an error occurs, and we are connecting over TCP/IP, only set it here if non-null, and fall through to a better default value below. */ if (result) { TRACE_PQRESULTERRORFIELD; sqlstate = PQresultErrorField(result, PG_DIAG_SQLSTATE); } if (!sqlstate) { /* Do our best to map the status result to a sqlstate code */ switch ((int)status) { case PGRES_EMPTY_QUERY: case PGRES_COMMAND_OK: case PGRES_TUPLES_OK: case PGRES_COPY_OUT: case PGRES_COPY_IN: case PGRES_COPY_BOTH: sqlstate = "00000"; /* SUCCESSFUL COMPLETION */ break; case PGRES_BAD_RESPONSE: case PGRES_NONFATAL_ERROR: sqlstate = "01000"; /* WARNING */ break; case PGRES_FATAL_ERROR: /* libpq returns NULL result in case of connection failures */ TRACE_PQSTATUS; if (!result || PQstatus(imp_dbh->conn) == CONNECTION_BAD) { sqlstate = "08000"; /* CONNECTION EXCEPTION */ break; } /*@fallthrough@*/ default: sqlstate = "22000"; /* DATA EXCEPTION */ break; } } strncpy(imp_dbh->sqlstate, sqlstate, 5); imp_dbh->sqlstate[5] = 0; if (TRACE7_slow) TRC(DBILOGFP, "%s_sqlstate txn_status is %d\n", THEADER_slow, pg_db_txn_status(aTHX_ imp_dbh)); if (TEND_slow) TRC(DBILOGFP, "%sEnd _sqlstate (status: %d)\n", THEADER_slow, status); return status; } /* end of _sqlstate */ /* ================================================================== */ int dbd_db_ping (SV * dbh) { dTHX; D_imp_dbh(dbh); PGTransactionStatusType tstatus; ExecStatusType status; PGresult * result; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_db_ping\n", THEADER_slow); if (NULL == imp_dbh->conn) { if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_db_ping (error: no connection)\n", THEADER_slow); return -1; } tstatus = pg_db_txn_status(aTHX_ imp_dbh); if (TRACE5_slow) TRC(DBILOGFP, "%sdbd_db_ping txn_status is %d\n", THEADER_slow, tstatus); if (tstatus >= PQTRANS_UNKNOWN) { /* Unknown, so we err on the side of "bad" */ if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_pg_ping (result: -2 unknown/bad)\n", THEADER_slow); return -2; } /* No matter what state we are in, send an empty query to the backend */ TRACE_PQEXEC; result = PQexec(imp_dbh->conn, "/* DBD::Pg ping test v3.20.2 */"); TRACE_PQRESULTSTATUS; status = PQresultStatus(result); TRACE_PQCLEAR; PQclear(result); if (PGRES_FATAL_ERROR == status) { /* Something very bad, usually indicating the backend is gone */ return -3; } /* We expect to see an empty query most times */ if (PGRES_EMPTY_QUERY == status) { if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_pg_ping (PGRES_EMPTY_QUERY)\n", THEADER_slow); return 1+tstatus; /* 0=idle 1=active 2=intrans 3=inerror 4=unknown */ } /* As a safety measure, check PQstatus as well */ TRACE_PQSTATUS; if (CONNECTION_BAD == PQstatus(imp_dbh->conn)) { if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_pg_ping (PQstatus returned CONNECTION_BAD)\n", THEADER_slow); return -4; } if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_pg_ping\n", THEADER_slow); return 1+tstatus; } /* end of dbd_db_ping */ /* ================================================================== */ static PGTransactionStatusType pg_db_txn_status (pTHX_ imp_dbh_t * imp_dbh) { if (TSTART_slow) TRC(DBILOGFP, "%sBegin PGTransactionStatusType\n", THEADER_slow); TRACE_PQTRANSACTIONSTATUS; return PQtransactionStatus(imp_dbh->conn); } /* end of pg_db_txn_status */ /* rollback and commit share so much code they get one function: */ /* ================================================================== */ static int pg_db_rollback_commit (pTHX_ SV * dbh, imp_dbh_t * imp_dbh, int action) { PGTransactionStatusType tstatus; ExecStatusType status; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_rollback_commit (action: %s AutoCommit: %d BegunWork: %d)\n", THEADER_slow, action ? "commit" : "rollback", 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))) { if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_rollback_commit (result: 0)\n", THEADER_slow); 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 */ tstatus = pg_db_txn_status(aTHX_ imp_dbh); if (TRACE4_slow) TRC(DBILOGFP, "%sdbd_db_%s txn_status is %d\n", THEADER_slow, action ? "commit" : "rollback", tstatus); 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 (TRACEWARN_slow) TRC(DBILOGFP, "%sWarning: invalid done_begin turned off\n", THEADER_slow); imp_dbh->done_begin = DBDPG_FALSE; } } else if (PQTRANS_ACTIVE == tstatus) { /* Still active - probably in a COPY */ if (TRACEWARN_slow) TRC(DBILOGFP,"%sCommand in progress, so no done_begin checking!\n", THEADER_slow); } 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 (TRACEWARN_slow) TRC(DBILOGFP, "%sWarning: invalid done_begin turned on\n", THEADER_slow); imp_dbh->done_begin = DBDPG_TRUE; } } else { /* Something is wrong: transaction status unknown */ if (TRACEWARN_slow) TRC(DBILOGFP, "%sWarning: cannot determine transaction status\n", THEADER_slow); } if (!imp_dbh->done_begin) { /* for example, inside a COPY */ if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_rollback_commit (result: 1)\n", THEADER_slow); return 1; } status = _result(aTHX_ imp_dbh, action ? "commit" : "rollback"); /* Set this early, for scripts that continue despite the error below */ imp_dbh->done_begin = DBDPG_FALSE; if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_rollback_commit (error: status not OK)\n", THEADER_slow); return 0; } /* 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); } /* We just did a rollback or a commit, so savepoints are not relevant, and we cannot be in a PGRES_COPY state */ av_undef(imp_dbh->savepoints); imp_dbh->copystate=0; if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_rollback_commit (result: 1)\n", THEADER_slow); return 1; } /* end of pg_db_rollback_commit */ /* ================================================================== */ int dbd_db_commit (SV * dbh, imp_dbh_t * imp_dbh) { dTHX; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_db_commit\n", THEADER_slow); return pg_db_rollback_commit(aTHX_ dbh, imp_dbh, 1); } /* ================================================================== */ int dbd_db_rollback (SV * dbh, imp_dbh_t * imp_dbh) { dTHX; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_db_rollback\n", THEADER_slow); return pg_db_rollback_commit(aTHX_ dbh, imp_dbh, 0); } /* ================================================================== */ int dbd_db_disconnect (SV * dbh, imp_dbh_t * imp_dbh) { dTHX; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_db_disconnect\n", THEADER_slow); /* We assume that disconnect will always work since most errors imply already disconnected. */ DBIc_ACTIVE_off(imp_dbh); if (NULL != imp_dbh->conn) { /* Attempt a rollback */ if (0 != dbd_db_rollback(dbh, imp_dbh) && TRACE5_slow) TRC(DBILOGFP, "%sdbd_db_disconnect: AutoCommit=off -> rollback\n", THEADER_slow); TRACE_PQFINISH; 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! */ if (TLOGIN_slow) TRC(DBILOGFP, "%sDisconnection complete\n", THEADER_slow); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_db_disconnect\n", THEADER_slow); return 1; } /* end of dbd_db_disconnect */ /* ================================================================== */ void dbd_db_destroy (SV * dbh, imp_dbh_t * imp_dbh) { dTHX; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_db_destroy\n", THEADER_slow); imp_dbh->do_tmp_sth = NULL; if (DBIc_ACTIVE(imp_dbh)) (void)dbd_db_disconnect(dbh, imp_dbh); if (NULL != imp_dbh->async_sth) { /* Just in case */ if (imp_dbh->async_sth->result) { TRACE_PQCLEAR; PQclear(imp_dbh->async_sth->result); imp_dbh->async_sth->result = NULL; } imp_dbh->async_sth = NULL; } /* Free the last_result as needed */ if (imp_dbh->last_result && imp_dbh->result_clearable) { TRACE_PQCLEAR; PQclear(imp_dbh->last_result); imp_dbh->last_result = NULL; } av_undef(imp_dbh->savepoints); sv_free((SV *)imp_dbh->savepoints); Safefree(imp_dbh->sqlstate); DBIc_IMPSET_off(imp_dbh); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_db_destroy\n", THEADER_slow); } /* end of dbd_db_destroy */ /* ================================================================== */ SV * dbd_db_FETCH_attrib (SV * dbh, imp_dbh_t * imp_dbh, SV * keysv) { dTHX; STRLEN kl; char * key = SvPV(keysv,kl); SV * retsv = Nullsv; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_db_FETCH (key: %s)\n", THEADER_slow, key); switch (kl) { case 5: /* pg_db */ if (strEQ("pg_db", key)) { TRACE_PQDB; retsv = newSVpv(PQdb(imp_dbh->conn),0); } break; case 6: /* pg_pid */ if (strEQ("pg_pid", key)) { TRACE_PQBACKENDPID; retsv = newSViv((IV)PQbackendPID(imp_dbh->conn)); } break; case 7: /* pg_user pg_pass pg_port pg_host */ if (strEQ("pg_user", key)) { TRACE_PQUSER; retsv = newSVpv(PQuser(imp_dbh->conn),0); } else if (strEQ("pg_pass", key)) { TRACE_PQPASS; retsv = newSVpv(PQpass(imp_dbh->conn),0); } else if (strEQ("pg_port", key)) { TRACE_PQPORT; retsv = newSVpv(PQport(imp_dbh->conn),0); } else if (strEQ("pg_host", key)) { TRACE_PQHOST; retsv = PQhost(imp_dbh->conn) ? newSVpv(PQhost(imp_dbh->conn),0) : Nullsv; } break; case 9: /* pg_socket */ if (strEQ("pg_socket", key)) { TRACE_PQSOCKET; retsv = newSViv((IV)PQsocket(imp_dbh->conn)); } break; case 10: /* AutoCommit pg_bool_tf pg_options */ if (strEQ("AutoCommit", key)) retsv = boolSV(DBIc_has(imp_dbh, DBIcf_AutoCommit)); else if (strEQ("pg_bool_tf", key)) retsv = newSViv((IV)imp_dbh->pg_bool_tf); else if (strEQ("pg_options", key)) { TRACE_PQOPTIONS; retsv = newSVpv(PQoptions(imp_dbh->conn),0); } break; case 11: /* pg_INV_READ pg_protocol ParamValues */ if (strEQ("pg_INV_READ", key)) retsv = newSViv((IV)INV_READ); else if (strEQ("pg_protocol", key)) retsv = newSViv((IV)imp_dbh->pg_protocol); else if (strEQ("ParamValues", key) && imp_dbh->do_tmp_sth != NULL) return dbd_st_FETCH_attrib (dbh, imp_dbh->do_tmp_sth, keysv); break; case 12: /* pg_INV_WRITE pg_utf8_flag */ if (strEQ("pg_INV_WRITE", key)) retsv = newSViv((IV) INV_WRITE ); else if (strEQ("pg_utf8_flag", key)) retsv = newSViv((IV)imp_dbh->pg_utf8_flag); break; case 13: /* pg_errorlevel */ if (strEQ("pg_errorlevel", key)) retsv = newSViv((IV)imp_dbh->pg_errorlevel); break; case 14: /* pg_lib_version pg_prepare_now pg_enable_utf8 */ if (strEQ("pg_lib_version", key)) retsv = newSViv((IV) PGLIBVERSION ); else if (strEQ("pg_prepare_now", key)) retsv = newSViv((IV)imp_dbh->prepare_now); else if (strEQ("pg_enable_utf8", key)) retsv = newSViv((IV)imp_dbh->pg_enable_utf8); break; case 15: /* pg_default_port pg_async_status pg_expand_array */ if (strEQ("pg_default_port", key)) retsv = newSViv((IV) PGDEFPORT ); else if (strEQ("pg_async_status", key)) retsv = newSViv((IV)imp_dbh->async_status); else if (strEQ("pg_expand_array", key)) retsv = newSViv((IV)imp_dbh->expand_array); break; case 17: /* pg_server_prepare pg_server_version pg_int8_as_string */ if (strEQ("pg_server_prepare", key)) retsv = newSViv((IV)imp_dbh->server_prepare); else if (strEQ("pg_server_version", key)) retsv = newSViv((IV)imp_dbh->pg_server_version); else if (strEQ("pg_int8_as_string", key)) { retsv = newSViv((IV)imp_dbh->pg_int8_as_string); } break; case 18: /* pg_switch_prepared pg_skip_deallocate */ if (strEQ("pg_switch_prepared", key)) retsv = newSViv((IV)imp_dbh->switch_prepared); else if (strEQ("pg_skip_deallocate", key)) retsv = newSViv((IV)imp_dbh->skip_deallocate); break; case 23: /* pg_placeholder_nocolons */ if (strEQ("pg_placeholder_nocolons", key)) retsv = newSViv((IV)imp_dbh->nocolons); break; case 25: /* pg_placeholder_dollaronly */ if (strEQ("pg_placeholder_dollaronly", key)) retsv = newSViv((IV)imp_dbh->dollaronly); break; case 30: /* pg_standard_conforming_strings */ if (strEQ("pg_standard_conforming_strings", key)) { TRACE_PQPARAMETERSTATUS; if (NULL != PQparameterStatus(imp_dbh->conn, "standard_conforming_strings")) { TRACE_PQPARAMETERSTATUS; retsv = newSVpv(PQparameterStatus(imp_dbh->conn,"standard_conforming_strings"),0); } } break; default: /* Do nothing, unknown name */ break; } if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_db_FETCH_attrib\n", THEADER_slow); if (!retsv) return Nullsv; if (retsv == &PL_sv_yes || retsv == &PL_sv_no) { return retsv; /* no need to mortalize yes or no */ } return sv_2mortal(retsv); } /* end of dbd_db_FETCH_attrib */ /* ================================================================== */ int dbd_db_STORE_attrib (SV * dbh, imp_dbh_t * imp_dbh, SV * keysv, SV * valuesv) { dTHX; STRLEN kl; char * key = SvPV(keysv,kl); unsigned int newval = SvTRUE(valuesv); int retval = 0; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_db_STORE (key: %s newval: %d kl:%d)\n", THEADER_slow, key, newval, (int)kl); switch (kl) { case 8: /* ReadOnly */ if (strEQ("ReadOnly", key)) { if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { warn("Setting ReadOnly in AutoCommit mode has no effect"); } imp_dbh->txn_read_only = newval ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } break; case 10: /* AutoCommit pg_bool_tf */ if (strEQ("AutoCommit", key)) { if (newval != DBIc_has(imp_dbh, DBIcf_AutoCommit)) { if (newval!=0) { /* It was off but is now on, so do a final commit */ if (0!=dbd_db_commit(dbh, imp_dbh) && TRACE4_slow) TRC(DBILOGFP, "%sSetting AutoCommit to 'on' forced a commit\n", THEADER_slow); } DBIc_set(imp_dbh, DBIcf_AutoCommit, newval); } retval = 1; } else if (strEQ("pg_bool_tf", key)) { imp_dbh->pg_bool_tf = newval!=0 ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } break; case 13: /* pg_errorlevel */ if (strEQ("pg_errorlevel", key)) { if (SvOK(valuesv)) { newval = (unsigned)SvIV(valuesv); } /* Default to "1" if an invalid value is passed in */ imp_dbh->pg_errorlevel = 0==newval ? 0 : 2==newval ? 2 : 1; TRACE_PQSETERRORVERBOSITY; (void)PQsetErrorVerbosity(imp_dbh->conn, (PGVerbosity)imp_dbh->pg_errorlevel); if (TRACE5_slow) TRC(DBILOGFP, "%sReset error verbosity to %d\n", THEADER_slow, imp_dbh->pg_errorlevel); retval = 1; } break; case 14: /* pg_prepare_now pg_enable_utf8 */ if (strEQ("pg_prepare_now", key)) { imp_dbh->prepare_now = newval ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } /* We don't want to check the client_encoding every single time we talk to the database, so we only do it here, which allows people to signal DBD::Pg that something may have changed, so could you please rescan client_encoding? */ else if (strEQ("pg_enable_utf8", key)) { /* Technically, we only allow -1, 0, and 1 */ if (SvOK(valuesv)) { newval = (unsigned)SvIV(valuesv); } imp_dbh->pg_enable_utf8 = newval; /* Never use the utf8 flag, no matter what */ if (0 == imp_dbh->pg_enable_utf8) { imp_dbh->pg_utf8_flag = DBDPG_FALSE; } /* Always use the flag, no matter what */ else if (1 == imp_dbh->pg_enable_utf8) { imp_dbh->pg_utf8_flag = DBDPG_TRUE; } /* Do The Right Thing */ else if (-1 == imp_dbh->pg_enable_utf8) { pg_db_detect_client_encoding_utf8(aTHX_ imp_dbh); imp_dbh->pg_enable_utf8 = -1; imp_dbh->pg_utf8_flag = imp_dbh->client_encoding_utf8; } else { warn("The pg_enable_utf8 setting can only be set to 0, 1, or -1"); } retval = 1; } break; case 15: /* pg_expand_array */ if (strEQ("pg_expand_array", key)) { imp_dbh->expand_array = newval ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } break; case 17: /* pg_server_prepare pg_int8_as_string */ if (strEQ("pg_server_prepare", key)) { imp_dbh->server_prepare = newval ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } else if (strEQ("pg_int8_as_string", key)) { imp_dbh->pg_int8_as_string = newval!=0 ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } break; case 18: /* pg_switch_prepared pg_skip_deallocate */ if (strEQ("pg_switch_prepared", key)) { if (SvOK(valuesv)) { imp_dbh->switch_prepared = (unsigned)SvIV(valuesv); retval = 1; } } else if (strEQ("pg_skip_deallocate", key)) { if (SvOK(valuesv)) { imp_dbh->skip_deallocate = (unsigned)SvIV(valuesv); retval = 1; } } break; case 22: /* pg_placeholder_escaped */ if (strEQ("pg_placeholder_escaped", key)) { imp_dbh->ph_escaped = newval ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } break; case 23: /* pg_placeholder_nocolons */ if (strEQ("pg_placeholder_nocolons", key)) { imp_dbh->nocolons = newval ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } break; case 25: /* pg_placeholder_dollaronly */ if (strEQ("pg_placeholder_dollaronly", key)) { imp_dbh->dollaronly = newval ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } break; } if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_db_STORE_attrib\n", THEADER_slow); return retval; } /* end of dbd_db_STORE_attrib */ static SV * pg_st_placeholder_key (imp_sth_t * imp_sth, ph_t * currph, int i) { dTHX; if (PLACEHOLDER_COLON == imp_sth->placeholder_type) return newSVpv(currph->fooname, 0); return newSViv(i+1); } /* ================================================================== */ SV * dbd_st_FETCH_attrib (SV * sth, imp_sth_t * imp_sth, SV * keysv) { dTHX; STRLEN kl; char * key = SvPV(keysv,kl); SV * retsv = Nullsv; int fields; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_st_FETCH (key: %s)\n", THEADER_slow, key); /* Some can be done before we have a result: */ switch (kl) { case 8: /* pg_bound */ if (strEQ("pg_bound", key)) { HV *pvhv = newHV(); ph_t *currph; int i; for (i=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,i++) { SV *key, *val; key = pg_st_placeholder_key(imp_sth, currph, i); val = newSViv(NULL == currph->bind_type ? 0 : 1); if (! hv_store_ent(pvhv, key, val, 0)) { SvREFCNT_dec(val); } SvREFCNT_dec(key); } retsv = newRV_noinc((SV*)pvhv); } else if (strEQ("pg_async", key)) { retsv = newSViv((IV)imp_sth->async_flag); } break; case 9: /* pg_direct */ if (strEQ("pg_direct", key)) retsv = newSViv((IV)imp_sth->direct); break; case 10: /* ParamTypes */ if (strEQ("ParamTypes", key)) { HV *pvhv = newHV(); ph_t *currph; int i; for (i=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,i++) { SV *key, *val; key = pg_st_placeholder_key(imp_sth, currph, i); if (NULL == currph->bind_type) { val = newSV(0); if (! hv_store_ent(pvhv, key, val, 0)) { SvREFCNT_dec(val); } } else { HV *pvhv2 = newHV(); if (currph->bind_type->type.sql) { (void)hv_store(pvhv2, "TYPE", 4, newSViv(currph->bind_type->type.sql), 0); } else { (void)hv_store(pvhv2, "pg_type", 7, newSViv(currph->bind_type->type_id), 0); } val = newRV_noinc((SV*)pvhv2); if (! hv_store_ent(pvhv, key, val, 0)) { SvREFCNT_dec(val); } } SvREFCNT_dec(key); } retsv = newRV_noinc((SV*)pvhv); } break; case 11: /* ParamValues pg_segments pg_numbound */ if (strEQ("ParamValues", key)) { HV *pvhv = newHV(); ph_t *currph; int i; for (i=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,i++) { SV *key, *val; key = pg_st_placeholder_key(imp_sth, currph, i); if (NULL == currph->value) { val = newSV(0); if (!hv_store_ent(pvhv, key, val, 0)) { SvREFCNT_dec(val); } } else { val = newSVpv(currph->value,currph->valuelen); if (!hv_store_ent(pvhv, key, val, 0)) { SvREFCNT_dec(val); } } SvREFCNT_dec(key); } retsv = newRV_noinc((SV*)pvhv); } else if (strEQ("pg_segments", key)) { AV *arr = newAV(); seg_t *currseg; int i; 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); } else if (strEQ("pg_numbound", key)) { ph_t *currph; int i = 0; for (currph=imp_sth->ph; NULL != currph; currph=currph->nextph) { i += NULL == currph->bind_type ? 0 : 1; } retsv = newSViv(i); } break; case 14: /* pg_prepare_now pg_current_row */ if (strEQ("pg_prepare_now", key)) retsv = newSViv((IV)imp_sth->prepare_now); else if (strEQ("pg_current_row", key)) retsv = newSViv(imp_sth->cur_tuple); break; case 15: /* pg_prepare_name pg_async_status */ if (strEQ("pg_prepare_name", key)) retsv = newSVpv((char *)imp_sth->prepare_name, 0); else if (strEQ("pg_async_status", key)) retsv = newSViv((IV)imp_sth->async_status); break; case 17: /* pg_server_prepare */ if (strEQ("pg_server_prepare", key)) retsv = newSViv((IV)imp_sth->server_prepare); break; case 18: /* pg_switch_prepared */ if (strEQ("pg_switch_prepared", key)) retsv = newSViv((IV)imp_sth->switch_prepared); break; case 23: /* pg_placeholder_nocolons */ if (strEQ("pg_placeholder_nocolons", key)) retsv = newSViv((IV)imp_sth->nocolons); break; case 25: /* pg_placeholder_dollaronly */ if (strEQ("pg_placeholder_dollaronly", key)) retsv = newSViv((IV)imp_sth->dollaronly); break; default: /* Do nothing, unknown name */ break; } if (retsv != Nullsv) { if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_FETCH_attrib\n", THEADER_slow); return sv_2mortal(retsv); } if (NULL == imp_sth->result) { if (TRACEWARN_slow) TRC(DBILOGFP, "%sCannot fetch value of %s pre-execute\n", THEADER_slow, key); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_FETCH_attrib\n", THEADER_slow); return Nullsv; } fields = DBIc_NUM_FIELDS(imp_sth); switch (kl) { case 4: /* NAME TYPE */ if (strEQ("NAME", key)) { AV *av = newAV(); char *fieldname; SV * sv_fieldname; retsv = newRV_inc(sv_2mortal((SV*)av)); while(--fields >= 0) { D_imp_dbh_from_sth; TRACE_PQFNAME; fieldname = PQfname(imp_sth->result, fields); sv_fieldname = newSVpv(fieldname,0); if (imp_dbh->pg_utf8_flag) SvUTF8_on(sv_fieldname); (void)av_store(av, fields, sv_fieldname); } } else if (strEQ("TYPE", key)) { /* Need to convert the Pg type to ANSI/SQL type. */ sql_type_info_t * type_info; AV *av = newAV(); retsv = newRV_inc(sv_2mortal((SV*)av)); while(--fields >= 0) { TRACE_PQFTYPE; type_info = pg_type_data((int)PQftype(imp_sth->result, fields)); (void)av_store(av, fields, newSViv( type_info ? type_info->type.sql : 0 ) ); } } break; case 5: /* SCALE */ if (strEQ("SCALE", key)) { AV *av = newAV(); Oid o; retsv = newRV_inc(sv_2mortal((SV*)av)); while(--fields >= 0) { TRACE_PQFTYPE; o = PQftype(imp_sth->result, fields); if (PG_NUMERIC == o) { TRACE_PQFMOD; o = PQfmod(imp_sth->result, fields)-4; (void)av_store(av, fields, newSViv(o % (o>>16))); } else { (void)av_store(av, fields, &PL_sv_undef); } } } break; case 7: /* pg_size pg_type */ if (strEQ("pg_size", key)) { AV *av = newAV(); retsv = newRV_inc(sv_2mortal((SV*)av)); while(--fields >= 0) { TRACE_PQFSIZE; (void)av_store(av, fields, newSViv(PQfsize(imp_sth->result, fields))); } } else if (strEQ("pg_type", key)) { sql_type_info_t * type_info; AV *av = newAV(); retsv = newRV_inc(sv_2mortal((SV*)av)); while(--fields >= 0) { TRACE_PQFTYPE; type_info = pg_type_data((int)PQftype(imp_sth->result,fields)); (void)av_store(av, fields, newSVpv(type_info ? type_info->type_name : "unknown", 0)); } } break; case 8: /* NULLABLE */ if (strEQ("NULLABLE", key)) { AV *av = newAV(); PGresult *result; int status; D_imp_dbh_from_sth; int nullable; /* 0 = not nullable, 1 = nullable 2 = unknown */ int y; Oid o; retsv = newRV_inc(sv_2mortal((SV*)av)); while(--fields >= 0) { nullable=2; TRACE_PQFTABLE; o = PQftable(imp_sth->result, fields); TRACE_PQFTABLECOL; y = PQftablecol(imp_sth->result, fields); if (InvalidOid != o && y > 0) { /* We know what table and column this came from */ char statement[128]; sprintf(statement, "SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid=%u AND attnum=%d", o, y); TRACE_PQEXEC; result = PQexec(imp_dbh->conn, statement); TRACE_PQRESULTSTATUS; status = PQresultStatus(result); if (PGRES_TUPLES_OK == status) { TRACE_PQNTUPLES; if (PQntuples(result)!=0) { TRACE_PQGETVALUE; switch (PQgetvalue(result,0,0)[0]) { case 't': nullable = 0; break; case 'f': default: nullable = 1; break; } } } TRACE_PQCLEAR; PQclear(result); } (void)av_store(av, fields, newSViv(nullable)); } } break; case 9: /* PRECISION */ if (strEQ("PRECISION", key)) { AV *av = newAV(); int sz = 0; Oid o; retsv = newRV_inc(sv_2mortal((SV*)av)); while(--fields >= 0) { TRACE_PQFTYPE; o = PQftype(imp_sth->result, fields); switch (o) { case PG_BPCHAR: case PG_VARCHAR: TRACE_PQFMOD; sz = PQfmod(imp_sth->result, fields); break; case PG_NUMERIC: TRACE_PQFMOD; sz = PQfmod(imp_sth->result, fields)-4; if (sz > 0) sz = sz >> 16; break; default: TRACE_PQFSIZE; sz = PQfsize(imp_sth->result, fields); break; } (void)av_store(av, fields, sz > 0 ? newSViv(sz) : &PL_sv_undef); } } break; case 10: /* CursorName */ if (strEQ("CursorName", key)) retsv = &PL_sv_undef; break; case 11: /* RowsInCache */ if (strEQ("RowsInCache", key)) retsv = &PL_sv_undef; break; case 13: /* pg_oid_status pg_cmd_status */ if (strEQ("pg_oid_status", key)) { TRACE_PQOIDVALUE; retsv = newSVuv((unsigned int)PQoidValue(imp_sth->result)); } else if (strEQ("pg_cmd_status", key)) { TRACE_PQCMDSTATUS; retsv = newSVpv((char *)PQcmdStatus(imp_sth->result), 0); } break; default: /* Do nothing, unknown name */ break; } if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_FETCH_attrib\n", THEADER_slow); if (retsv == Nullsv) return Nullsv; return sv_2mortal(retsv); } /* end of dbd_st_FETCH_attrib */ /* ================================================================== */ int dbd_st_STORE_attrib (SV * sth, imp_sth_t * imp_sth, SV * keysv, SV * valuesv) { dTHX; STRLEN kl; char * key = SvPV(keysv,kl); STRLEN vl; char * value = SvPV(valuesv,vl); int retval = 0; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_st_STORE (key: %s value: %s)\n", THEADER_slow, key, value); switch (kl) { case 8: /* pg_async */ if (strEQ("pg_async", key)) { imp_sth->async_flag = (int)SvIV(valuesv); retval = 1; } break; case 14: /* pg_prepare_now */ if (strEQ("pg_prepare_now", key)) { imp_sth->prepare_now = strEQ(value,"0") ? DBDPG_FALSE : DBDPG_TRUE; retval = 1; } break; case 15: /* pg_prepare_name */ if (strEQ("pg_prepare_name", key)) { Safefree(imp_sth->prepare_name); New(0, imp_sth->prepare_name, vl+1, char); /* freed in dbd_st_destroy */ Copy(value, imp_sth->prepare_name, vl, char); imp_sth->prepare_name[vl] = '\0'; retval = 1; } break; case 17: /* pg_server_prepare */ if (strEQ("pg_server_prepare", key)) { imp_sth->server_prepare = SvTRUE(valuesv) ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } break; case 18: /* pg_switch_prepared */ if (strEQ("pg_switch_prepared", key)) { imp_sth->switch_prepared = (int)SvIV(valuesv); retval = 1; } break; case 23: /* pg_placeholder_nocolons */ if (strEQ("pg_placeholder_nocolons", key)) { imp_sth->nocolons = SvTRUE(valuesv) ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } break; case 25: /* pg_placeholder_dollaronly */ if (strEQ("pg_placeholder_dollaronly", key)) { imp_sth->dollaronly = SvTRUE(valuesv) ? DBDPG_TRUE : DBDPG_FALSE; retval = 1; } break; default: /* Do nothing, unknown name */ break; } if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_STORE_attrib\n", THEADER_slow); return retval; } /* end of dbd_st_STORE_attrib */ /* ================================================================== */ int dbd_discon_all (SV * drh, imp_drh_t * imp_drh) { dTHX; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_discon_all\n", THEADER_slow); /* The disconnect_all concept is flawed and needs more work */ if (!PL_dirty && !SvTRUE(get_sv("DBI::PERL_ENDING",0))) { sv_setiv(DBIc_ERR(imp_drh), (IV)1); sv_setpv(DBIc_ERRSTR(imp_drh), "disconnect_all not implemented"); } if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_discon_all\n", THEADER_slow); return 0; } /* end of dbd_discon_all */ /* ================================================================== */ /* Deprecated in favor of $dbh->{pg_socket} */ int pg_db_getfd (imp_dbh_t * imp_dbh) { dTHX; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_getfd\n", THEADER_slow); TRACE_PQSOCKET; return PQsocket(imp_dbh->conn); } /* end of pg_db_getfd */ /* ================================================================== */ SV * pg_db_pg_notifies (SV * dbh, imp_dbh_t * imp_dbh) { dTHX; int status; PGnotify * notify; AV * ret; SV * retsv; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_pg_notifies\n", THEADER_slow); TRACE_PQCONSUMEINPUT; status = PQconsumeInput(imp_dbh->conn); if (0 == status) { _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_pg_notifies (error)\n", THEADER_slow); return &PL_sv_undef; } TRACE_PQNOTIFIES; notify = PQnotifies(imp_dbh->conn); if (!notify) { if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_pg_notifies (undef)\n", THEADER_slow); return &PL_sv_undef; } ret=newAV(); SV *relnamesv = newSVpv(notify->relname, 0); if (imp_dbh->pg_utf8_flag) { SvUTF8_on(relnamesv); } av_push(ret, relnamesv); av_push(ret, newSViv(notify->be_pid) ); SV *payloadsv = newSVpv(notify->extra, 0); if (imp_dbh->pg_utf8_flag) { SvUTF8_on(payloadsv); } av_push(ret, payloadsv); TRACE_PQFREEMEM; PQfreemem(notify); retsv = newRV_inc(sv_2mortal((SV*)ret)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_pg_notifies\n", THEADER_slow); return sv_2mortal(retsv); } /* end of pg_db_pg_notifies */ /* ================================================================== */ int dbd_st_prepare_sv (SV * sth, imp_sth_t * imp_sth, SV * statement_sv, SV * attribs) { dTHX; D_imp_dbh_from_sth; STRLEN mypos=0; /* Used to find and set firstword */ SV **svp; /* To help parse the arguments */ char *statement; statement_sv = pg_rightgraded_sv(aTHX_ statement_sv, imp_dbh->pg_utf8_flag); statement = SvPV_nolen(statement_sv); if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_st_prepare (statement: %s)\n", THEADER_slow, statement); if ('\0' == *statement) croak ("Cannot prepare empty statement"); /* Set default values for this statement handle */ imp_sth->placeholder_type = PLACEHOLDER_NONE; imp_sth->numsegs = 0; imp_sth->numphs = 0; imp_sth->numbound = 0; imp_sth->cur_tuple = 0; imp_sth->rows = -1; /* per DBI spec */ imp_sth->totalsize = 0; imp_sth->async_flag = 0; imp_sth->async_status = STH_NO_ASYNC; imp_sth->prepare_name = NULL; imp_sth->firstword = NULL; imp_sth->result = NULL; imp_sth->type_info = NULL; imp_sth->seg = NULL; imp_sth->ph = NULL; imp_sth->PQvals = NULL; imp_sth->PQlens = NULL; imp_sth->PQfmts = NULL; imp_sth->PQoids = NULL; imp_sth->prepared_by_us = DBDPG_FALSE; /* Set to 1 when actually done preparing */ imp_sth->direct = DBDPG_FALSE; imp_sth->is_dml = DBDPG_FALSE; /* Not preparable DML until proved otherwise */ 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->has_current = DBDPG_FALSE; /* Are any of the params DEFAULT? */ imp_sth->use_inout = DBDPG_FALSE; /* Are any of the placeholders using inout? */ imp_sth->all_bound = DBDPG_FALSE; /* Have all placeholders been bound? */ imp_sth->number_iterations = 0; /* We inherit some preferences from the database handle */ imp_sth->server_prepare = imp_dbh->server_prepare; imp_sth->switch_prepared = imp_dbh->switch_prepared; imp_sth->prepare_now = imp_dbh->prepare_now; imp_sth->dollaronly = imp_dbh->dollaronly; imp_sth->nocolons = imp_dbh->nocolons; /* Parse and set any attributes passed in */ if (attribs) { if ((svp = hv_fetchs((HV*)SvRV(attribs),"pg_server_prepare", 0)) != NULL) { imp_sth->server_prepare = SvTRUE(*svp) ? DBDPG_TRUE : DBDPG_FALSE; } if ((svp = hv_fetchs((HV*)SvRV(attribs),"pg_direct", 0)) != NULL) imp_sth->direct = 0==SvIV(*svp) ? DBDPG_FALSE : DBDPG_TRUE; else if ((svp = hv_fetchs((HV*)SvRV(attribs),"pg_prepare_now", 0)) != NULL) { imp_sth->prepare_now = 0==SvIV(*svp) ? DBDPG_FALSE : DBDPG_TRUE; } if ((svp = hv_fetchs((HV*)SvRV(attribs),"pg_placeholder_dollaronly", 0)) != NULL) { imp_sth->dollaronly = SvTRUE(*svp) ? DBDPG_TRUE : DBDPG_FALSE; } if ((svp = hv_fetchs((HV*)SvRV(attribs),"pg_placeholder_nocolons", 0)) != NULL) { imp_sth->nocolons = SvTRUE(*svp) ? DBDPG_TRUE : DBDPG_FALSE; } if ((svp = hv_fetchs((HV*)SvRV(attribs),"pg_async", 0)) != NULL) { imp_sth->async_flag = (int)SvIV(*svp); } } /* Figure out the first word in the statement */ while (isSPACE(statement[mypos])) mypos++; if (isALPHA(statement[mypos])) { STRLEN wordstart = mypos, wordlen; while (isALPHA(statement[mypos])) mypos++; wordlen = mypos-wordstart; New(0, imp_sth->firstword, wordlen+1, char); /* freed in dbd_st_destroy */ Copy(statement+wordstart, imp_sth->firstword, wordlen, char); imp_sth->firstword[wordlen] = '\0'; /* 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") || 0 == strcasecmp(imp_sth->firstword, "MERGE") || 0 == strcasecmp(imp_sth->firstword, "VALUES") || 0 == strcasecmp(imp_sth->firstword, "TABLE") || 0 == strcasecmp(imp_sth->firstword, "WITH") ) { imp_sth->is_dml = DBDPG_TRUE; } } /* Break the statement into segments by placeholder */ pg_st_split_statement(aTHX_ imp_sth, statement); /* We prepare it right away if: 1. The statement is DML 2. The attribute "direct" is false 3. The attribute "pg_server_prepare" is true 4. The attribute "pg_prepare_now" is true 5. We are compiled on a 8 or greater server */ if (TRACE4_slow) TRC(DBILOGFP, "%sImmediate prepare decision: dml=%d direct=%d server_prepare=%d prepare_now=%d PGLIBVERSION=%d\n", THEADER_slow, imp_sth->is_dml, imp_sth->direct, imp_sth->server_prepare, imp_sth->prepare_now, PGLIBVERSION); if (imp_sth->is_dml && !imp_sth->direct && imp_sth->server_prepare && imp_sth->prepare_now ) { if (TRACE5_slow) TRC(DBILOGFP, "%sRunning an immediate prepare\n", THEADER_slow); if (pg_st_prepare_statement(aTHX_ sth, imp_sth)!=0) { TRACE_PQERRORMESSAGE; croak ("%s", PQerrorMessage(imp_dbh->conn)); } if (STH_ASYNC_PREPARE == imp_sth->async_status) imp_dbh->async_status = 1; } /* Tell DBI to call destroy when this handle ends */ DBIc_IMPSET_on(imp_sth); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_prepare\n", THEADER_slow); return 1; } /* end of dbd_st_prepare */ static const char *placeholder_string[PLACEHOLDER_TYPE_COUNT] = { "", "?", "$1", ":foo" }; /* ================================================================== */ static void pg_st_split_statement (pTHX_ imp_sth_t * imp_sth, char * statement) { /* Builds the "segment" and "placeholder" structures for a statement handle */ D_imp_dbh_from_sth; STRLEN currpos; /* Where we currently are in the statement string */ STRLEN sectionstart, sectionstop; /* Borders of current section */ STRLEN sectionsize; /* Size of an allocated segment */ PGPlaceholderType placeholder_type; /* Which type we are in: one of none,?,$,: */ unsigned char ch; /* The current character being checked */ unsigned char oldch; /* The previous character */ signed char non_standard_strings = -1; /* Status 0=standard 1=non_standard -1=unknown */ 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 */ bool statement_rewritten = DBDPG_FALSE; char * original_statement = NULL; /* Copy as needed so we can restore the original */ if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_st_split_statement\n", THEADER_slow); if (TRACE6_slow) TRC(DBILOGFP, "%spg_st_split_statement: (%s)\n", THEADER_slow, statement); /* 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 (TRACE4_slow) { TRC(DBILOGFP, "%snot splitting due to %s\n", THEADER_slow, imp_sth->direct ? "pg_direct" : "empty string"); } imp_sth->numsegs = 1; imp_sth->numphs = 0; imp_sth->totalsize = strlen(statement); New(0, imp_sth->seg, 1, seg_t); /* freed in dbd_st_destroy */ imp_sth->seg->placeholder = 0; imp_sth->seg->nextseg = NULL; imp_sth->seg->ph = NULL; 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 (TRACE6_slow) TRC(DBILOGFP, "%sdirect split = (%s) length=(%d)\n", THEADER_slow, imp_sth->seg->segment, (int)imp_sth->totalsize); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_st_split_statement (direct)\n", THEADER_slow); return; } /* Start everyone at the start of the string */ currpos = sectionstart = 0; ch = oldch = 1; while (1) { /* Are we done processing this string? */ if (ch < 1) { break; } /* Store the old character in case we need to look backwards */ oldch = ch; /* 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) /* > @ABC... but not [ */ || (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) { char quote = ch; STRLEN backslashes = 0; bool estring = (oldch == 'E') ? DBDPG_TRUE : DBDPG_FALSE; /* E'' style string with backslash escapes */ if ('\'' == ch && -1 == non_standard_strings) { TRACE_PQPARAMETERSTATUS; const char * scs = PQparameterStatus(imp_dbh->conn,"standard_conforming_strings"); non_standard_strings = (NULL==scs ? 1 : 0==strncmp(scs,"on",2) ? 0 : 1); } /* 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 */ /* 1.2.1 : backslashes have no meaning in double quoted sections */ /* 1.2.2 : if non_standard_strings is not set, ignore backslashes in single quotes */ /* 1.2.3 : backslashes always escape in E'' strings */ if (ch == quote && (quote == '"' || 0==(backslashes&1))) { quote = 0; } else if ('\\' == ch) { if (quote == '"' || non_standard_strings || estring) 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) ) { char quote = *statement; /* Go until end of comment (may be newline) or end of the string */ while (quote && ++currpos && (ch = *statement++)) { /* 2.1: dashdash only terminates at newline */ if ('-' == 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 */ if ('$' == ch && (*statement == '$' || *statement == '_' || (*statement >= 'A' && *statement <= 'Z') || (*statement >= 'a' && *statement <= 'z') || ((unsigned char)*statement >= (unsigned char)'\200'))) { /* "SQL identifiers must begin with a letter (a-z, but also letters with diacritical marks and non-Latin letters) or an underscore (_). Subsequent characters in an identifier or key word can be letters, underscores, digits (0-9), or dollar signs ($) */ char * dollarstring = NULL; /* Dynamic string between $$ in dollar quoting */ STRLEN dollarsize; /* Size of dollarstring */ STRLEN dollaroffset = 0; /* How far from the first dollar sign are we? */ STRLEN xlen = 0; /* The current character we are tracing */ bool found = DBDPG_FALSE; /* Have we found the end of the dollarquote? */ bool inside_dollar = DBDPG_FALSE; /* Are we evaluating the dollar sign for the end? */ /* Scan forward until we hit the matching dollarsign */ while ((ch = *statement++)) { dollaroffset++; if ('$' == ch) { found = DBDPG_TRUE; break; } /* If we hit an invalid character, bail out */ if (ch <= 47 || (ch >= 58 && ch <= 64) || (ch >= 91 && ch <= 94) || ch == 96 ) { break; } } /* end first scan */ /* Not found? Move to the next letter after the dollarsign and move on */ if (!found) { statement -= dollaroffset; 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 (dollaroffset >= 1) { New(0, dollarstring, dollaroffset, char); /* note: a true array, not a null-terminated string */ strncpy(dollarstring, statement-dollaroffset, dollaroffset); } /* Move on and see if the quote is ever closed */ dollarsize = dollaroffset; found = DBDPG_FALSE; while ((ch = *statement++)) { dollaroffset++; 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++; dollaroffset--; 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) { dollaroffset--; } if (dollarstring) Safefree(dollarstring); /* Advance our cursor to the current position */ currpos += dollaroffset+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; } /* If this placeholder is escaped, we rewrite the string to remove the backslash, and move on as if there is no placeholder. The use of $dbh->{pg_placeholder_escaped} = 0 is left as an emergency measure. It will probably be removed at some point. */ if ('\\' == oldch && imp_dbh->ph_escaped) { if (! statement_rewritten) { New(0, original_statement, strlen(statement-currpos)+1, char); Copy(statement-currpos, original_statement, strlen(statement-currpos)+1, char); statement_rewritten = DBDPG_TRUE; } /* copy the placeholder-like character but ignore the backslash */ char *p = statement-2; while(*p++) { *(p-1) = *p; } /* We need to adjust these items because we just rewrote 'statement'! */ statement--; currpos--; ch = *statement; 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 = PLACEHOLDER_NONE; /* Dollar sign placeholder style */ if ('$' == ch && isDIGIT(*statement)) { if ('0' == *statement) croak("Invalid placeholder value"); while(isDIGIT(*statement)) { ++statement; ++currpos; } placeholder_type = PLACEHOLDER_DOLLAR; } else if (! imp_sth->dollaronly) { /* Question mark style */ if ('?' == ch) { placeholder_type = PLACEHOLDER_QUESTIONMARK; } /* Colon style */ else if (':' == ch && ! imp_sth->nocolons) { /* Skip two colons in a row (e.g. myval::float) */ if (':' == *statement) { /* Might as well skip _all_ consecutive colons */ while(':' == *statement) { ++statement; ++currpos; } continue; } /* Skip number-colon-number */ if (isDIGIT(oldch) && isDIGIT(*statement)) { /* Eat until we don't see a number */ while (isDIGIT(*statement)) { ++statement; ++currpos; } continue; } /* Only allow colon placeholders if they start with alphanum */ if (isALNUM(*statement)) { while(isALNUM(*statement)) { ++statement; ++currpos; } placeholder_type = PLACEHOLDER_COLON; } } } /* Check for conflicting placeholder types */ if (placeholder_type != PLACEHOLDER_NONE) { if (imp_sth->placeholder_type && placeholder_type != imp_sth->placeholder_type) croak("Cannot mix placeholder styles \"%s\" and \"%s\"", placeholder_string[imp_sth->placeholder_type], placeholder_string[placeholder_type]); } /* Move on to the next letter unless we found a placeholder, or we are at the end of the string */ if (PLACEHOLDER_NONE == 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 (PLACEHOLDER_QUESTIONMARK == placeholder_type) { newseg->placeholder = ++imp_sth->numphs; } else if (PLACEHOLDER_DOLLAR == placeholder_type) { newseg->placeholder = atoi(statement-(currpos-sectionstop-1)); } else if (PLACEHOLDER_COLON == placeholder_type) { STRLEN phsectionsize = currpos-sectionstop; /* Have we seen this placeholder yet? */ for (xint=1,thisph=imp_sth->ph; NULL != thisph; thisph=thisph->nextph,xint++) { /* Because we need to make sure :foobar does not match as a previous hit when seeing :foobar2, we always use the greater of the two lengths: the length of the old name or the current name we are scanning */ if (0==strncmp(thisph->fooname, statement-phsectionsize, strlen(thisph->fooname) > phsectionsize ? strlen(thisph->fooname) : phsectionsize)) { 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; newph->iscurrent = DBDPG_FALSE; newph->isinout = DBDPG_FALSE; New(0, newph->fooname, phsectionsize+1, char); /* freed in dbd_st_destroy */ Copy(statement-phsectionsize, newph->fooname, phsectionsize, char); newph->fooname[phsectionsize] = '\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 (TRACE6_slow) TRC(DBILOGFP, "%sCreated segment (%s)\n", THEADER_slow, 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++; if (placeholder_type != PLACEHOLDER_NONE) imp_sth->placeholder_type = placeholder_type; /* Check if this segment also ends the string. If it does, we simply leave right away. Make sure we don't peek at statement if we know it is past the end of the string. */ if ('\0' != ch && '\0' == *statement) break; } /* end large while(1) loop: statement parsing */ /* For dollar sign placeholders, ensure that the rules are followed */ if (PLACEHOLDER_DOLLAR == 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 */ int 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++) { bool found = DBDPG_FALSE; for (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 (TRACE6_slow) TRC(DBILOGFP, "%sSet number of placeholders to %d\n", THEADER_slow, topdollar); imp_sth->numphs = topdollar; } /* Create sequential placeholders */ if (PLACEHOLDER_COLON != imp_sth->placeholder_type) { 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->fooname = NULL; newph->referenced = DBDPG_FALSE; newph->defaultval = DBDPG_TRUE; newph->isdefault = DBDPG_FALSE; newph->iscurrent = DBDPG_FALSE; newph->isinout = DBDPG_FALSE; /* Let the correct segment(s) point to it */ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { if (currseg->placeholder==xint) { currseg->ph = newph; } } if (NULL==currph) { imp_sth->ph = newph; } else { currph->nextph = newph; } currph = newph; } } if (TRACE7_slow) { TRC(DBILOGFP, "%sPlaceholder type: %d numsegs: %d numphs: %d\n", THEADER_slow, imp_sth->placeholder_type, imp_sth->numsegs, imp_sth->numphs); TRC(DBILOGFP, "%sPlaceholder numbers and segments:\n", THEADER_slow); for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { TRC(DBILOGFP, "%sPH: (%d) SEG: (%s)\n", THEADER_slow, currseg->placeholder, currseg->segment); } if (imp_sth->numphs) { TRC(DBILOGFP, "%sPlaceholder number, fooname, id:\n", THEADER_slow); STRLEN xlen = 1; for (currph=imp_sth->ph; NULL != currph; currph=currph->nextph,xlen++) { TRC(DBILOGFP, "%s#%d FOONAME: (%s)\n", THEADER_slow, (int)xlen, currph->fooname); } } } DBIc_NUM_PARAMS(imp_sth) = imp_sth->numphs; if (statement_rewritten) { Copy(original_statement, statement-currpos, strlen(original_statement)+1, char); } Safefree(original_statement); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_st_split_statement\n", THEADER_slow); return; } /* end pg_st_split_statement */ /* ================================================================== */ static int pg_st_prepare_statement (pTHX_ SV * sth, imp_sth_t * imp_sth) { D_imp_dbh_from_sth; char * statement; unsigned int placeholder_digits; int x, params; STRLEN execsize; int status; seg_t * currseg; ph_t * currph; long power_of_ten; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_st_prepare_statement\n", THEADER_slow); Renew(imp_sth->prepare_name, 25, char); /* freed in dbd_st_destroy */ /* Name is "dbdpg_xPID_#", where x is p for positive or n for negative */ sprintf(imp_sth->prepare_name,"dbdpg_%c%d_%x", (imp_dbh->pid_number < 0 ? 'n' : 'p'), abs(imp_dbh->pid_number), imp_dbh->prepare_number); if (TRACE5_slow) TRC(DBILOGFP, "%sNew statement name (%s)\n", THEADER_slow, imp_sth->prepare_name); execsize = imp_sth->totalsize; if (imp_sth->numphs!=0) { for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { if (0==currseg->placeholder) continue; /* The parameter itself: dollar sign plus digit(s) */ power_of_ten = 10; for (placeholder_digits=1; placeholder_digits<7; placeholder_digits++, power_of_ten *= 10) { if (currseg->placeholder < power_of_ten) break; } if (placeholder_digits >= 7) croak("Too many placeholders!"); execsize += placeholder_digits+1; } } New(0, statement, execsize+1, char); /* freed below */ statement[0] = '\0'; /* Construct the statement, with proper placeholders */ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { if (currseg->segment != NULL) strcat(statement, currseg->segment); if (currseg->placeholder) { sprintf(strchr(statement, '\0'), "$%d", currseg->placeholder); } } statement[execsize] = '\0'; if (TRACE6_slow) TRC(DBILOGFP, "%sPrepared statement (%s)\n", THEADER_slow, statement); params = 0; if (imp_sth->numbound!=0) { params = imp_sth->numphs; if (NULL == imp_sth->PQoids) { Newz(0, imp_sth->PQoids, (unsigned int)imp_sth->numphs, Oid); } for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph) { imp_sth->PQoids[x++] = (currph->defaultval) ? 0 : (Oid)currph->bind_type->type_id; } } if (TSQL) TRC(DBILOGFP, "PREPARE %s AS %s;\n\n", imp_sth->prepare_name, statement); /* Free the last_result as needed, even if happens to be owned by us */ if (imp_dbh->last_result && imp_dbh->result_clearable) { TRACE_PQCLEAR; PQclear(imp_dbh->last_result); imp_dbh->last_result = NULL; } if (imp_sth->result) { TRACE_PQCLEAR; PQclear(imp_sth->result); imp_sth->result = NULL; } if (imp_sth->async_flag & PG_ASYNC) { TRACE_PQSENDPREPARE; status = PQsendPrepare(imp_dbh->conn, imp_sth->prepare_name, statement, params, imp_sth->PQoids); if (status) { imp_sth->async_status = STH_ASYNC_PREPARE; imp_dbh->async_sth = imp_sth; } else { status = PGRES_FATAL_ERROR; _fatal_sqlstate(aTHX_ imp_dbh); } } else { TRACE_PQPREPARE; imp_dbh->last_result = imp_sth->result = PQprepare(imp_dbh->conn, imp_sth->prepare_name, statement, params, imp_sth->PQoids); imp_dbh->result_clearable = DBDPG_FALSE; status = _sqlstate(aTHX_ imp_dbh, imp_sth->result); if (PGRES_COMMAND_OK == status) { imp_sth->prepared_by_us = DBDPG_TRUE; /* Done here so deallocate is not called spuriously */ imp_dbh->prepare_number++; } } Safefree(statement); if (PGRES_COMMAND_OK != status) { Safefree(imp_sth->prepare_name); imp_sth->prepare_name = NULL; TRACE_PQERRORMESSAGE; pg_error(aTHX_ sth, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_st_prepare_statement (error)\n", THEADER_slow); return -2; } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_st_prepare_statement\n", THEADER_slow); return 0; } /* end of pg_st_prepare_statement */ /* ================================================================== */ int dbd_bind_ph (SV * sth, imp_sth_t * imp_sth, SV * ph_name, SV * newvalue, IV sql_type, SV * attribs, int is_inout, IV maxlen) { dTHX; D_imp_dbh_from_sth; 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; bool is_array = DBDPG_FALSE; maxlen = 0; /* not used, this makes the compiler happy */ if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_bind_ph (ph_name: %s)\n", THEADER_slow, neatsvpv(ph_name,0)); 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 (PLACEHOLDER_COLON == 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 (PLACEHOLDER_COLON == 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)) { if (sv_isa(newvalue, "DBD::Pg::DefaultValue") || sv_isa(newvalue, "DBI::DefaultValue")) { /* 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 if (sv_isa(newvalue, "DBD::Pg::Current")) { /* This is a special type */ Safefree(currph->value); currph->value = NULL; currph->valuelen = 0; currph->iscurrent = DBDPG_TRUE; imp_sth->has_current = DBDPG_TRUE; } else if (SvTYPE(SvRV(newvalue)) == SVt_PVAV) { SV * quotedval; quotedval = pg_stringify_array(newvalue,",",imp_dbh->pg_server_version,imp_dbh->pg_utf8_flag); currph->valuelen = sv_len(quotedval); Renew(currph->value, currph->valuelen+1, char); /* freed in dbd_st_destroy */ Copy(SvUTF8(quotedval) ? SvPVutf8_nolen(quotedval) : SvPV_nolen(quotedval), currph->value, currph->valuelen+1, char); currph->bind_type = pg_type_data(PG_CSTRINGARRAY); sv_2mortal(quotedval); is_array = DBDPG_TRUE; } else if (!SvAMAGIC(newvalue)) { /* We want to allow magic scalars on through - but we cannot check above, because sometimes DBD::Pg::DefaultValue arrives as one! */ croak("Cannot bind a reference\n"); } } if (TRACE5_slow) { TRC(DBILOGFP, "%sBind (%s) (type=%ld)\n", THEADER_slow, name, (long)sql_type); if (attribs) { TRC(DBILOGFP, "%sBind attribs (%s)", THEADER_slow, neatsvpv(attribs,0)); } } if (is_inout) { currph->isinout = DBDPG_TRUE; imp_sth->use_inout = DBDPG_TRUE; currph->inout = newvalue; /* Reference to a scalar */ } /* We ignore attribs for these special cases */ if (currph->isdefault || currph->iscurrent || (is_array && !SvAMAGIC(newvalue))) { if (NULL == currph->bind_type) { imp_sth->numbound++; currph->bind_type = pg_type_data(PG_UNKNOWN); } if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_bind_ph (special)\n", THEADER_slow); return 1; } /* Check for a pg_type argument (sql_type already handled) */ if (attribs) { if((svp = hv_fetchs((HV*)SvRV(attribs),"pg_type", 0)) != NULL) pg_type = (int)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, pg_type %s not supported by DBD::Pg", name, currph->bind_type->type_name); } } else { croak("Cannot bind %s unknown pg_type %d", 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 param %s: unknown sql_type %ld", name, (long)sql_type); } if (!(currph->bind_type = pg_type_data(currph->bind_type->type.pg))) { croak("Cannot find a pg_type for %ld", (long)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(PG_UNKNOWN); 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 (PG_BYTEA==currph->bind_type->type_id) imp_sth->has_binary = DBDPG_TRUE; } /* convert to a string ASAP */ if (!SvPOK(newvalue) && SvOK(newvalue)) { (void)sv_2pv(newvalue, &PL_na); } /* upgrade to at least string */ (void)SvUPGRADE(newvalue, SVt_PV); if (SvOK(newvalue)) { if (SvIsBOOL(newvalue)) { /* bind native booleans as 1/0 or t/f if pg_bool_tf is set */ value_string = SvTRUE(newvalue) ? imp_dbh->pg_bool_tf ? "t" : "1" : imp_dbh->pg_bool_tf ? "f" : "0"; currph->valuelen = 1; } else { /* get the right encoding, without modifying the caller's copy */ newvalue = pg_rightgraded_sv(aTHX_ newvalue, imp_dbh->pg_utf8_flag && PG_BYTEA!=currph->bind_type->type_id); value_string = SvPV(newvalue, currph->valuelen); } Renew(currph->value, currph->valuelen+1, char); /* freed in dbd_st_destroy */ Copy(value_string, currph->value, currph->valuelen+1, char); currph->value[currph->valuelen] = '\0'; } else { Safefree(currph->value); currph->value = NULL; currph->valuelen = 0; } if (reprepare) { if (TRACE5_slow) TRC(DBILOGFP, "%sBinding has forced a re-prepare\n", THEADER_slow); /* Deallocate sets the prepare_name to NULL */ if (pg_st_deallocate_statement(aTHX_ sth, imp_sth)!=0) { /* Deallocation failed. Let's mark it and move on */ Safefree(imp_sth->prepare_name); imp_sth->prepare_name = NULL; if (TRACEWARN_slow) TRC(DBILOGFP, "%sFailed to deallocate!\n", THEADER_slow); } } if (TRACE7_slow) TRC (DBILOGFP, "%sPlaceholder (%s) bound as type (%s) (type_id=%d), length %d, value of (%s)\n", THEADER_slow, name, currph->bind_type->type_name, currph->bind_type->type_id, (int)currph->valuelen, PG_BYTEA==currph->bind_type->type_id ? "(binary, not shown)" : value_string); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_bind_ph\n", THEADER_slow); return 1; } /* end of dbd_bind_ph */ /* ================================================================== */ SV * pg_stringify_array(SV *input, const char * array_delim, int server_version, bool utf8) { dTHX; AV * toparr; AV * currarr; AV * lastarr; int done; int array_depth = 0; int array_items; int inner_arrays = 0; int xy, yz; SV * svitem; char * string; STRLEN stringlength; SV * value; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_stringify_array\n", THEADER_slow); toparr = (AV *) SvRV(input); value = newSVpv("{", 1); if (utf8) SvUTF8_on(value); /* Empty arrays are easy */ if (av_len(toparr) < 0) { av_clear(toparr); sv_catpv(value, "}"); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_stringify_array (empty)\n", THEADER_slow); return value; } done = 0; currarr = lastarr = toparr; /* We want to walk through to find out the depth */ while (!done) { /* If we come across a null, we are done */ if (! av_exists(currarr, 0)) { done = 1; break; } /* Grab the first item of the current array */ svitem = *av_fetch(currarr, 0, 0); /* If a ref, die if not an array, else keep descending */ if (SvROK(svitem)) { if (SvTYPE(SvRV(svitem)) != SVt_PVAV) croak("Arrays must contain only scalars and other arrays"); array_depth++; /* Squirrel away this level before we leave it */ lastarr = currarr; /* Set the current array to this item */ currarr = (AV *)SvRV(svitem); /* If this is an empty array, stop here */ if (av_len(currarr) < 0) done = 1; } else done = 1; } inner_arrays = array_depth ? 1+(int)av_len(lastarr) : 0; /* How many items are in each inner array? */ array_items = array_depth ? (1+(int)av_len((AV*)SvRV(*av_fetch(lastarr,0,0)))) : 1+(int)av_len(lastarr); for (xy=1; xy < array_depth; xy++) { sv_catpv(value, "{"); } for (xy=0; xy < inner_arrays || !array_depth; xy++) { if (array_depth) { svitem = *av_fetch(lastarr, xy, 0); if (!SvROK(svitem)) croak ("Not a valid array!"); currarr = (AV*)SvRV(svitem); if (SvTYPE(currarr) != SVt_PVAV) croak("Arrays must contain only scalars and other arrays!"); if (1+av_len(currarr) != array_items) croak("Invalid array - all arrays must be of equal size"); sv_catpv(value, "{"); } for (yz=0; yz < array_items; yz++) { if (! av_exists(currarr, yz)) { sv_catpv(value, "NULL"); } else { svitem = *av_fetch(currarr, yz, 0); if (SvROK(svitem)) croak("Arrays must contain only scalars and other arrays"); if (!SvOK(svitem)) { /* Insert NULL if we can */ /* Only version 8.2 and up can handle NULLs in arrays */ if (server_version < 80200) croak("Cannot use NULLs in arrays until version 8.2"); sv_catpv(value, "NULL"); /* Beware of array_nulls config param! */ } else { sv_catpv(value, "\""); /* avoid up- or down-grading the caller's value */ svitem = pg_rightgraded_sv(aTHX_ svitem, utf8); string = SvPV(svitem, stringlength); while (stringlength--) { /* Escape backslashes and double-quotes. */ if ('\"' == *string || '\\' == *string) sv_catpvn(value, "\\", 1); sv_catpvn(value, string, 1); string++; } sv_catpv(value, "\""); } } if (yz < array_items-1) sv_catpv(value, array_delim); } if (!array_items) { sv_catpv(value, "\"\""); } sv_catpv(value, "}"); if (xy < inner_arrays-1) sv_catpv(value, array_delim); if (!array_depth) break; } for (xy=0; xyarray_delimiter); /* Note: we don't do careful balance checking here, as this is coming straight from the Postgres backend, and we rely on it to give us a sane and balanced structure */ /* The array may start with a non 1-based beginning. If so, we'll just eat the range */ if ('[' == *input) { while (*input != '\0') { if ('=' == *input++) break; } } /* Eat the opening brace and perform a sanity check */ if ('{' != *(input++)) croak("Tried to destringify a non-array!: %s", input); /* Count how deep this array goes */ while ('{' == *input) { opening_braces++; input++; } input -= opening_braces; New(0, string, strlen((char *)input), char); /* Freed at end of this function */ string[0] = '\0'; av = currentav = topav = newAV(); while (*input != '\0') { if (in_quote) { if ('"' == *input) { in_quote = 0; /* String will be stored by following delimiter or brace */ input++; continue; } if ('\\' == *input) { /* Eat backslashes */ input++; } string[section_size++] = *input++; continue; } else if ('{' == *input) { AV * const newav = newAV(); av_push(currentav, newRV_noinc((SV*)newav)); currentav = newav; } else if (coltype->array_delimiter == *input) { } else if ('}' == *input) { } else if ('"' == *input) { in_quote = seen_quotes = (bool)1; } else { string[section_size++] = *input; } if ('}' == *input || (coltype->array_delimiter == *input && '}' != *(input-1))) { string[section_size] = '\0'; if (0 == section_size && !seen_quotes) { /* Just an empty array */ } else if (4 == section_size && 0 == strncmp(string, "NULL", 4) && '"' != *(input-1)) { av_push(currentav, newSV(0)); } else { if (1 == coltype->svtype) av_push(currentav, newSViv(SvIV(sv_2mortal(newSVpvn(string,section_size))))); else if (2 == coltype->svtype) av_push(currentav, newSVnv(SvNV(sv_2mortal(newSVpvn(string,section_size))))); else if (3 == coltype->svtype) { if (imp_dbh->pg_bool_tf) { av_push(currentav, newSVpv('t' == *string ? "t" : "f", 0)); } else av_push(currentav, newSViv('t' == *string ? 1 : 0)); } else { // Bytea gets special dequoting if (0 == strncmp(coltype->type_name, "_bytea", 6)) { coltype->dequote(aTHX_ string, §ion_size); } SV *sv = newSVpvn(string, section_size); // Mark as utf8 if needed (but never bytea) if (0 != strncmp(coltype->type_name, "_bytea", 6) && imp_dbh->pg_utf8_flag) SvUTF8_on(sv); av_push(currentav, sv); } } section_size = 0; } /* Handle all touching closing braces */ if ('}' == *input) { if (closing_braces) { while ('}' == *input) { input++; } } else { while ('}' == *input) { closing_braces++; input++; } /* Set the new topav if required */ if ('\0' != *input && opening_braces > closing_braces) { closing_braces = opening_braces - closing_braces; while (closing_braces--) { topav = (AV*)SvRV(AvARRAY(topav)[0]); } } } currentav = topav; } else { input++; } } Safefree(string); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_destringify_array\n", THEADER_slow); return newRV_noinc((SV*)av); } /* end of pg_destringify_array */ SV * pg_upgraded_sv(pTHX_ SV *input) { U8 *p, *end; STRLEN len; /* SvPV() can change the value SvUTF8() (for overloaded values and tied values). */ p = (U8*)SvPV(input, len); if(SvUTF8(input)) return input; for(end = p + len; p != end; p++) { if(*p & 0x80) { SV *output = sv_mortalcopy(input); sv_utf8_upgrade(output); return output; } } return input; } SV * pg_downgraded_sv(pTHX_ SV *input) { U8 *p, *end; STRLEN len; /* SvPV() can change the value SvUTF8() (for overloaded values and tied values). */ p = (U8*)SvPV(input, len); if(!SvUTF8(input)) return input; for(end = p + len; p != end; p++) { if(*p & 0x80) { SV *output = sv_mortalcopy(input); sv_utf8_downgrade(output, DBDPG_FALSE); return output; } } return input; } SV * pg_rightgraded_sv(pTHX_ SV *input, bool utf8) { return utf8 ? pg_upgraded_sv(aTHX_ input) : pg_downgraded_sv(aTHX_ input); } static void pg_db_detect_client_encoding_utf8(pTHX_ imp_dbh_t *imp_dbh) { char *clean_encoding; long unsigned int i, j; TRACE_PQPARAMETERSTATUS; const char * const client_encoding = PQparameterStatus(imp_dbh->conn, "client_encoding"); if (NULL != client_encoding) { STRLEN len = strlen(client_encoding); New(0, clean_encoding, len + 1, char); for (i = 0, j = 0; i < len; i++) { const char c = toLOWER(client_encoding[i]); if (isALPHA(c) || isDIGIT(c)) clean_encoding[j++] = c; } clean_encoding[j] = '\0'; imp_dbh->client_encoding_utf8 = (strnEQ(clean_encoding, "utf8", 4) || strnEQ(clean_encoding, "unicode", 8)) ? DBDPG_TRUE : DBDPG_FALSE; Safefree(clean_encoding); } else { imp_dbh->client_encoding_utf8 = DBDPG_FALSE; } } /* ================================================================== */ long pg_quickexec (SV * dbh, const char * sql, const int asyncflag) { dTHX; D_imp_dbh(dbh); ExecStatusType status = PGRES_FATAL_ERROR; /* Assume the worst */ PGTransactionStatusType txn_status; long rows = 0; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_quickexec (query: %s async: %d async_status: %d)\n", THEADER_slow, sql, asyncflag, imp_dbh->async_status); if (NULL == imp_dbh->conn) { pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, "Database handle has been disconnected"); return -2; } /* Abort if we are in the middle of a copy */ if (imp_dbh->copystate != 0) { if (PGRES_COPY_IN == imp_dbh->copystate) { croak("Must call pg_putcopyend before issuing more commands"); } else { croak("Must call pg_getcopydata until no more rows before issuing more commands"); } } /* If we are still waiting on an async, handle it */ switch (imp_dbh->async_status) { case DBH_NO_ASYNC: break; case DBH_ASYNC_CONNECT: case DBH_ASYNC_CONNECT_POLL: if (TRACE5_slow) TRC(DBILOGFP, "%snot yet connected\n", THEADER_slow); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_quickexec (async rows: %ld)\n", THEADER_slow, rows); return -1; default: if (TRACE5_slow) TRC(DBILOGFP, "%shandling old async\n", THEADER_slow); rows = handle_old_async(aTHX_ dbh, imp_dbh, asyncflag); if (rows) { if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_quickexec (async rows: %ld)\n", THEADER_slow, rows); return rows; } } /* If not autocommit, start a new transaction */ if (!imp_dbh->done_begin && !DBIc_has(imp_dbh, DBIcf_AutoCommit)) { status = _result(aTHX_ imp_dbh, "begin"); if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_quickexec (error: begin failed)\n", THEADER_slow); return -2; } imp_dbh->done_begin = DBDPG_TRUE; /* If read-only mode, make it so */ if (imp_dbh->txn_read_only) { status = _result(aTHX_ imp_dbh, "set transaction read only"); if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_quickexec (error: set transaction read only failed)\n", THEADER_slow); return -2; } } } /* We want txn mode if AutoCommit */ /* Asynchronous commands get kicked off and return undef */ if (asyncflag & PG_ASYNC) { if (TRACE4_slow) TRC(DBILOGFP, "%sGoing asynchronous with do()\n", THEADER_slow); TRACE_PQSENDQUERY; if (! PQsendQuery(imp_dbh->conn, sql)) { if (TRACE4_slow) TRC(DBILOGFP, "%sPQsendQuery failed\n", THEADER_slow); _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_quickexec (error: async do failed)\n", THEADER_slow); return -2; } imp_dbh->async_status = DBH_ASYNC; imp_dbh->async_sth = NULL; /* Needed? */ if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_quickexec (async)\n", THEADER_slow); return 0; } if (TSQL) TRC(DBILOGFP, "%s;\n\n", sql); /* Free the last_result as needed, as we are about to replace it */ if (imp_dbh->last_result && imp_dbh->result_clearable) { TRACE_PQCLEAR; PQclear(imp_dbh->last_result); imp_dbh->last_result = NULL; } TRACE_PQEXEC; imp_dbh->last_result = PQexec(imp_dbh->conn, sql); imp_dbh->result_clearable = DBDPG_TRUE; status = _sqlstate(aTHX_ imp_dbh, imp_dbh->last_result); imp_dbh->copystate = 0; /* Assume not in copy mode until told otherwise */ if (TRACE4_slow) TRC(DBILOGFP, "%sGot a status of %d\n", THEADER_slow, status); switch ((int)status) { case PGRES_TUPLES_OK: TRACE_PQNTUPLES; rows = PQntuples(imp_dbh->last_result); break; case PGRES_COMMAND_OK: /* non-select statement */ TRACE_PQCMDTUPLES; rows = atol(PQcmdTuples(imp_dbh->last_result)); break; case PGRES_COPY_OUT: case PGRES_COPY_IN: case PGRES_COPY_BOTH: /* Copy Out/In data transfer in progress */ imp_dbh->copystate = status; imp_dbh->copybinary = PQbinaryTuples(imp_dbh->last_result); rows = -1; break; case PGRES_EMPTY_QUERY: case PGRES_BAD_RESPONSE: case PGRES_NONFATAL_ERROR: rows = -2; TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); break; case PGRES_FATAL_ERROR: default: rows = -2; TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); break; } if (NULL == imp_dbh->last_result) { if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_quickexec (no result)\n", THEADER_slow); return -2; } TRACE_PQTRANSACTIONSTATUS; txn_status = PQtransactionStatus(imp_dbh->conn); if (PQTRANS_IDLE == txn_status) { imp_dbh->done_begin = DBDPG_FALSE; imp_dbh->copystate=0; /* 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 (TEND_slow) TRC(DBILOGFP, "%sEnd pg_quickexec (rows: %ld, txn_status: %d)\n", THEADER_slow, rows, txn_status); return rows; } /* end of pg_quickexec */ /* ================================================================== */ /* Return value <= -2:error, >=0:ok row count, (-1=unknown count) */ static int pq_send_prepared_query (pTHX_ imp_dbh_t * imp_dbh, imp_sth_t * imp_sth) { TRACE_PQSENDQUERYPREPARED; return PQsendQueryPrepared (imp_dbh->conn, imp_sth->prepare_name, imp_sth->numphs, imp_sth->PQvals, imp_sth->PQlens, imp_sth->PQfmts, 0); } long dbd_st_execute (SV * sth, imp_sth_t * imp_sth) { dTHX; D_imp_dbh_from_sth; ph_t * currph; int status; STRLEN execsize, x; unsigned int placeholder_digits; seg_t * currseg; char * statement = NULL; int num_fields; long ret; PQExecType pqtype; long power_of_ten; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_st_execute\n", THEADER_slow); if (NULL == imp_dbh->conn) { pg_error(aTHX_ sth, PGRES_FATAL_ERROR, "Cannot call execute on a disconnected database handle"); return -2; } /* 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->all_bound && imp_sth->numphs!=0) { for (currph=imp_sth->ph; NULL != currph; currph=currph->nextph) { if (NULL == currph->bind_type) { pg_error(aTHX_ sth, PGRES_FATAL_ERROR, "execute called with an unbound placeholder"); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (error: unbound placeholder)\n", THEADER_slow); return -2; } if (currph->isinout) { currph->valuelen = sv_len(currph->inout); Renew(currph->value, currph->valuelen+1, char); Copy(SvPV_nolen(currph->inout), currph->value, currph->valuelen+1, char); currph->value[currph->valuelen] = '\0'; } } imp_sth->all_bound = DBDPG_TRUE; } /* Check for old async transactions */ switch (imp_dbh->async_status) { case DBH_NO_ASYNC: break; case DBH_ASYNC_CONNECT: case DBH_ASYNC_CONNECT_POLL: if (TRACE5_slow) TRC(DBILOGFP, "%snot yet connected\n", THEADER_slow); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute\n", THEADER_slow); return -2; default: if (imp_dbh->async_status && STH_ASYNC_PREPARE != imp_sth->async_status) { if (TRACE7_slow) TRC(DBILOGFP, "%sAttempting to handle existing async transaction\n", THEADER_slow); ret = handle_old_async(aTHX_ sth, imp_dbh, imp_sth->async_flag); if (ret) { if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (async ret: %ld)\n", THEADER_slow, ret); return ret; } } } /* If not autocommit, start a new transaction */ if (!imp_dbh->done_begin && !DBIc_has(imp_dbh, DBIcf_AutoCommit)) { status = _result(aTHX_ imp_dbh, "begin"); if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ sth, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (error: begin failed)\n", THEADER_slow); return -2; } imp_dbh->done_begin = DBDPG_TRUE; /* If read-only mode, make it so */ if (imp_dbh->txn_read_only) { status = _result(aTHX_ imp_dbh, "set transaction read only"); if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ sth, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (error: set transaction read only failed)\n", THEADER_slow); return -2; } } } /* Clear old result (if any), except if starting the query asynchronously. Old async results will be deleted implicitly the next time pg_db_result is called. */ if (imp_sth->result && !(imp_sth->async_flag & PG_ASYNC)) { TRACE_PQCLEAR; PQclear(imp_sth->result); imp_sth->result = NULL; } /* Now, we need to build the statement to send to the backend We are using one of PQexec, PQexecPrepared, or PQexecParams Let's figure out which we are going to use and set pqtype */ if (TRACE4_slow) TRC(DBILOGFP, "%sPQexec* decision: dml=%d direct=%d server_prepare=%d numbound=%d numphs=%d default=%d current=%d\n", THEADER_slow, imp_sth->is_dml, imp_sth->direct, imp_sth->server_prepare, imp_sth->numbound, imp_sth->numphs, imp_sth->has_default, imp_sth->has_current); /* Increment our count */ imp_sth->number_iterations++; /* We use PQexec if: 1. The statement is *not* DML (e.g. is DDL, which cannot be prepared) 2. We have a DEFAULT parameter 3. We have a CURRENT parameter 4. pg_direct is true 5. There are no placeholders 6. pg_server_prepare is false */ if (!imp_sth->is_dml || imp_sth->has_default || imp_sth->has_current || imp_sth->direct || !imp_sth->numphs || !imp_sth->server_prepare ) pqtype = PQTYPE_EXEC; else if (STH_ASYNC_PREPARE == imp_sth->async_status ) { pqtype = PQTYPE_PREPARED; } else if (0==imp_sth->switch_prepared || imp_sth->number_iterations < imp_sth->switch_prepared) { pqtype = PQTYPE_PARAMS; } else { pqtype = PQTYPE_PREPARED; } /* We use the new server_side prepare style if: 1. The statement is DML (DDL is not preparable) 2. The attribute "pg_direct" is false 3. The attribute "pg_server_prepare" is true 4. There are no DEFAULT or CURRENT values */ execsize = imp_sth->totalsize; /* Total of all segments */ /* If using plain old PQexec, we need to quote each value ourselves */ if (PQTYPE_EXEC == pqtype) { 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", 8); currph->quotedlen = 7; } else if (currph->iscurrent) { Renew(currph->quoted, 18, char); /* freed in dbd_st_destroy */ strncpy(currph->quoted, "CURRENT_TIMESTAMP", 18); currph->quotedlen = 17; } else if (NULL == currph->value) { Renew(currph->quoted, 5, char); /* freed in dbd_st_destroy */ strncpy(currph->quoted, "NULL", 5); currph->quotedlen = 4; } else { if (currph->quoted) Safefree(currph->quoted); currph->quoted = currph->bind_type->quote( aTHX_ currph->value, currph->valuelen, &currph->quotedlen, imp_dbh->pg_server_version >= 80100 ? 1 : 0 ); /* freed in dbd_st_destroy */ } } } else { /* We are using a server that can handle PQexecParams/PQexecPrepared */ /* Put all values into an array to pass to one of the above */ if (NULL == imp_sth->PQvals) { Newz(0, imp_sth->PQvals, (unsigned int)imp_sth->numphs, const char *); /* freed in dbd_st_destroy */ } for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph) { imp_sth->PQvals[x++] = currph->value; } /* Binary or regular? */ if (imp_sth->has_binary) { if (NULL == imp_sth->PQlens) { Newz(0, imp_sth->PQlens, (unsigned int)imp_sth->numphs, int); /* freed in dbd_st_destroy */ Newz(0, imp_sth->PQfmts, (unsigned int)imp_sth->numphs, int); /* freed below */ } for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,x++) { if (PG_BYTEA==currph->bind_type->type_id) { imp_sth->PQlens[x] = (int)currph->valuelen; imp_sth->PQfmts[x] = 1; } else { imp_sth->PQlens[x] = 0; imp_sth->PQfmts[x] = 0; } } } } /* Run one of PQexec (or PQsendQuery), PQexecParams (or PQsendQueryParams), PQexecPrepared (or PQsendQueryPrepared) */ if (PQTYPE_EXEC == pqtype) { /* PQexec or PQsendQuery */ if (TRACE4_slow) TRC(DBILOGFP, "%s%s\n", THEADER_slow, imp_sth->async_flag & PG_ASYNC ? "PQsendQuery" : "PQexec"); /* 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 at end of this 'if' block */ statement[0] = '\0'; for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { if (currseg->segment != NULL) strcat(statement, currseg->segment); if (currseg->placeholder!=0) strcat(statement, currseg->ph->quoted); } statement[execsize] = '\0'; if (TRACE5_slow) TRC(DBILOGFP, "%sRunning %s with (%s)\n", THEADER_slow, imp_sth->async_flag & PG_ASYNC ? "PQsendQuery" : "PQexec", statement); if (TSQL) TRC(DBILOGFP, "%s;\n\n", statement); if (imp_sth->async_flag & PG_ASYNC) { TRACE_PQSENDQUERY; if (!PQsendQuery(imp_dbh->conn, statement)) { Safefree(statement); _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ sth, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (error: PQsendQuery failed)\n", THEADER_slow); return -2; } } else { /* Free the last_result as needed, even if happens to be owned by us */ if (imp_dbh->last_result && imp_dbh->result_clearable) { TRACE_PQCLEAR; PQclear(imp_dbh->last_result); imp_dbh->last_result = NULL; } if (imp_sth->result) { TRACE_PQCLEAR; PQclear(imp_sth->result); imp_sth->result = NULL; } TRACE_PQEXEC; imp_dbh->last_result = imp_sth->result = PQexec(imp_dbh->conn, statement); imp_dbh->result_clearable = DBDPG_FALSE; } Safefree(statement); } else if (PQTYPE_PARAMS == pqtype) { /* PQexecParams or PQsendQueryParams */ if (TRACE4_slow) TRC(DBILOGFP, "%s%s\n", THEADER_slow, imp_sth->async_flag & PG_ASYNC ? "PQsendQueryParams" : "PQexecParams"); /* 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) */ power_of_ten = 10; for (placeholder_digits=1; placeholder_digits<7; placeholder_digits++, power_of_ten *= 10) { if (currseg->placeholder < power_of_ten) break; } if (placeholder_digits >= 7) croak("Too many placeholders!"); execsize += placeholder_digits+1; } /* Create the statement */ New(0, statement, execsize+1, char); /* freed below at end of this 'if' block */ statement[0] = '\0'; for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { if (currseg->segment != NULL) strcat(statement, currseg->segment); if (currseg->placeholder!=0) sprintf(strchr(statement, '\0'), "$%d", currseg->placeholder); } statement[execsize] = '\0'; /* Populate PQoids */ if (NULL == imp_sth->PQoids) { Newz(0, imp_sth->PQoids, (unsigned int)imp_sth->numphs, Oid); } for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph) { imp_sth->PQoids[x++] = (currph->defaultval) ? 0 : (Oid)currph->bind_type->type_id; } if (TRACE7_slow) { for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,x++) { TRC(DBILOGFP, "%sPQexecParams item #%d\n", THEADER_slow, (int)x); TRC(DBILOGFP, "%s-> Type: (%d)\n", THEADER_slow, imp_sth->PQoids[x]); TRC(DBILOGFP, "%s-> Value: (%s)\n", THEADER_slow, imp_sth->PQvals[x]); TRC(DBILOGFP, "%s-> Length: (%d)\n", THEADER_slow, imp_sth->PQlens ? imp_sth->PQlens[x] : 0); TRC(DBILOGFP, "%s-> Format: (%d)\n", THEADER_slow, imp_sth->PQfmts ? imp_sth->PQfmts[x] : 0); } } if (TSQL) { TRC(DBILOGFP, "EXECUTE %s (\n", statement); for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,x++) { TRC(DBILOGFP, "$%d: %s\n", (int)x+1, imp_sth->PQvals[x]); } TRC(DBILOGFP, ");\n\n"); } if (TRACE5_slow) TRC(DBILOGFP, "%sRunning %s with (%s)\n", THEADER_slow, imp_sth->async_flag & PG_ASYNC ? "PQsendQueryParams" : "PQexecParams", statement); if (imp_sth->async_flag & PG_ASYNC) { TRACE_PQSENDQUERYPARAMS; if (!PQsendQueryParams (imp_dbh->conn, statement, imp_sth->numphs, imp_sth->PQoids, imp_sth->PQvals, imp_sth->PQlens, imp_sth->PQfmts, 0)) { Safefree(statement); _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ sth, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (error: PQsendQueryParams failed)\n", THEADER_slow); return -2; } } else { /* Free the last_result as needed, even if happens to be owned by us */ if (imp_dbh->last_result && imp_dbh->result_clearable) { TRACE_PQCLEAR; PQclear(imp_dbh->last_result); imp_dbh->last_result = NULL; } if (imp_sth->result) { TRACE_PQCLEAR; PQclear(imp_sth->result); imp_sth->result = NULL; } TRACE_PQEXECPARAMS; imp_dbh->last_result = imp_sth->result = PQexecParams( imp_dbh->conn, statement, imp_sth->numphs, imp_sth->PQoids, imp_sth->PQvals, imp_sth->PQlens, imp_sth->PQfmts, 0 ); imp_dbh->result_clearable = DBDPG_FALSE; } Safefree(statement); } else if (PQTYPE_PREPARED == pqtype) { /* PQexecPrepared or PQsendQueryPrepared */ if (TRACE4_slow) TRC(DBILOGFP, "%s%s\n", THEADER_slow, imp_sth->async_flag & PG_ASYNC ? "PQsendQueryPrepared" : "PQexecPrepared"); /* 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 (TRACE5_slow) TRC(DBILOGFP, "%sRe-preparing statement\n", THEADER_slow); } if (pg_st_prepare_statement(aTHX_ sth, imp_sth)!=0) { if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (error)\n", THEADER_slow); return -2; } } else if (STH_ASYNC_PREPARE == imp_sth->async_status) { if (TRACE5_slow) TRC(DBILOGFP, "%swaiting for async preprare to complete (%s)\n", THEADER_slow, imp_sth->prepare_name); } else { if (TRACE5_slow) TRC(DBILOGFP, "%sUsing previously prepared statement (%s)\n", THEADER_slow, imp_sth->prepare_name); } if (STH_ASYNC_PREPARE != imp_sth->async_status) { if (TRACE7_slow) { for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,x++) { TRC(DBILOGFP, "%sPQexecPrepared item #%d\n", THEADER_slow, (int)x); TRC(DBILOGFP, "%s-> Value: (%s)\n", THEADER_slow, (imp_sth->PQfmts && imp_sth->PQfmts[x]==1) ? "(binary, not shown)" : imp_sth->PQvals[x]); TRC(DBILOGFP, "%s-> Length: (%d)\n", THEADER_slow, imp_sth->PQlens ? imp_sth->PQlens[x] : 0); TRC(DBILOGFP, "%s-> Format: (%d)\n", THEADER_slow, imp_sth->PQfmts ? imp_sth->PQfmts[x] : 0); } } if (TRACE5_slow) TRC(DBILOGFP, "%sRunning %s with (%s)\n", THEADER_slow, imp_sth->async_flag & PG_ASYNC ? "PQsendQueryPrepared" : "PQexecPrepared", imp_sth->prepare_name); if (TSQL) { TRC(DBILOGFP, "EXECUTE %s (\n", imp_sth->prepare_name); for (x=0,currph=imp_sth->ph; NULL != currph; currph=currph->nextph,x++) { TRC(DBILOGFP, "$%d: %s\n", (int)x+1, imp_sth->PQvals[x]); } TRC(DBILOGFP, ");\n\n"); } if (imp_sth->async_flag & PG_ASYNC) { TRACE_PQSENDQUERYPREPARED; if (!PQsendQueryPrepared (imp_dbh->conn, imp_sth->prepare_name, imp_sth->numphs, imp_sth->PQvals, imp_sth->PQlens, imp_sth->PQfmts, 0)) { _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ sth, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (error: PQsendQueryPrepared failed)\n", THEADER_slow); return -2; } } else { /* Free the last_result as needed, even if happens to be owned by us */ if (imp_dbh->last_result && imp_dbh->result_clearable) { TRACE_PQCLEAR; PQclear(imp_dbh->last_result); imp_dbh->last_result = NULL; } if (imp_sth->result) { TRACE_PQCLEAR; PQclear(imp_sth->result); imp_sth->result = NULL; } TRACE_PQEXECPREPARED; imp_dbh->last_result = imp_sth->result = PQexecPrepared( imp_dbh->conn, imp_sth->prepare_name, imp_sth->numphs, imp_sth->PQvals, imp_sth->PQlens, imp_sth->PQfmts, 0 ); imp_dbh->result_clearable = DBDPG_FALSE; } } } /* end new-style prepare */ /* Some form of PQexec* or PQsend* has been run at this point */ /* If running asynchronously, we don't stick around for the result */ if (imp_sth->async_flag & PG_ASYNC) { if (TRACEWARN_slow) TRC(DBILOGFP, "%sEarly return for async query\n", THEADER_slow); if (!imp_sth->async_status) imp_sth->async_status = STH_ASYNC; imp_dbh->async_sth = imp_sth; imp_dbh->async_status = DBH_ASYNC; if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (async)\n", THEADER_slow); return 0; } status = _sqlstate(aTHX_ imp_dbh, imp_sth->result); imp_dbh->copystate = 0; /* Assume not in copy mode until told otherwise */ if (PGRES_TUPLES_OK == status) { TRACE_PQNFIELDS; num_fields = PQnfields(imp_sth->result); imp_sth->cur_tuple = 0; DBIc_NUM_FIELDS(imp_sth) = num_fields; DBIc_ACTIVE_on(imp_sth); TRACE_PQNTUPLES; ret = PQntuples(imp_sth->result); if (TRACE5_slow) TRC(DBILOGFP, "%sStatus was PGRES_TUPLES_OK, fields=%d, tuples=%ld\n", THEADER_slow, num_fields, ret); } else if (PGRES_COMMAND_OK == status) { /* non-select statement */ bool gotrows = DBDPG_FALSE; if (TRACE5_slow) TRC(DBILOGFP, "%sStatus was PGRES_COMMAND_OK\n", THEADER_slow); if (imp_sth->result) { TRACE_PQCMDTUPLES; ret = atol(PQcmdTuples(imp_sth->result)); gotrows = ret; } if (!gotrows) { /* No rows affected, but check for change of state */ TRACE_PQTRANSACTIONSTATUS; if (PQTRANS_IDLE == PQtransactionStatus(imp_dbh->conn)) { imp_dbh->done_begin = DBDPG_FALSE; /* 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 (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (OK, no rows)\n", THEADER_slow); return 0; } } else if (PGRES_COPY_OUT == status || PGRES_COPY_IN == status || PGRES_COPY_BOTH == status) { if (TRACE5_slow) TRC(DBILOGFP, "%sStatus was PGRES_COPY_%s\n", THEADER_slow, PGRES_COPY_OUT == status ? "OUT" : PGRES_COPY_IN == status ? "IN" : "BOTH"); /* Copy Out/In data transfer in progress */ imp_dbh->copystate = status; imp_dbh->copybinary = PQbinaryTuples(imp_sth->result); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (COPY)\n", THEADER_slow); return -1; } else { if (TRACE5_slow) TRC(DBILOGFP, "%sInvalid status returned (%d)\n", THEADER_slow, status); TRACE_PQERRORMESSAGE; pg_error(aTHX_ sth, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (error: bad status)\n", THEADER_slow); return -2; } /* store the number of affected rows */ imp_sth->rows = ret; if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_execute (rows: %ld)\n", THEADER_slow, ret); return ret; } /* end of dbd_st_execute */ /* ================================================================== */ AV * dbd_st_fetch (SV * sth, imp_sth_t * imp_sth) { dTHX; D_imp_dbh_from_sth; int num_fields; int i; int chopblanks; AV * av; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_st_fetch\n", THEADER_slow); /* Check that execute() was executed successfully */ if ( !DBIc_ACTIVE(imp_sth) ) { pg_error(aTHX_ sth, PGRES_NONFATAL_ERROR, "no statement executing\n"); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_fetch (error: no statement)\n", THEADER_slow); return Nullav; } TRACE_PQNTUPLES; if (imp_sth->cur_tuple == imp_sth->rows) { if (TRACE5_slow) TRC(DBILOGFP, "%sFetched the last tuple (%d)\n", THEADER_slow, imp_sth->cur_tuple); imp_sth->cur_tuple = 0; DBIc_ACTIVE_off(imp_sth); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_fetch (last tuple)\n", THEADER_slow); return Nullav; /* we reached the last tuple */ } av = DBIc_DBISTATE(imp_sth)->get_fbav(imp_sth); num_fields = AvFILL(av)+1; chopblanks = (int)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 int)num_fields, sql_type_info_t*); /* freed in dbd_st_destroy */ for (i = 0; i < num_fields; ++i) { TRACE_PQFTYPE; imp_sth->type_info[i] = pg_type_data((int)PQftype(imp_sth->result, i)); if (imp_sth->type_info[i] == NULL) { if (TRACEWARN_slow) { TRACE_PQFTYPE; TRC(DBILOGFP, "%sUnknown type returned by Postgres: %d. Setting to UNKNOWN\n", THEADER_slow, PQftype(imp_sth->result, i)); } imp_sth->type_info[i] = pg_type_data(PG_UNKNOWN); } } } for (i = 0; i < num_fields; ++i) { sql_type_info_t * type_info; SV *sv; if (TRACE5_slow) TRC(DBILOGFP, "%sFetching field #%d\n", THEADER_slow, i); sv = AvARRAY(av)[i]; TRACE_PQGETISNULL; if (PQgetisnull(imp_sth->result, imp_sth->cur_tuple, i)!=0) { SvROK(sv) ? (void)sv_unref(sv) : (void)SvOK_off(sv); } else { unsigned char * value; TRACE_PQGETVALUE; value = (unsigned char*)PQgetvalue(imp_sth->result, imp_sth->cur_tuple, i); type_info = imp_sth->type_info[i]; if (type_info && 0 == strncmp(type_info->arrayout, "array", 5) && imp_dbh->expand_array) { sv_setsv(sv, sv_2mortal(pg_destringify_array(aTHX_ imp_dbh, value, type_info))); } else { if (type_info) { STRLEN value_len; type_info->dequote(aTHX_ value, &value_len); /* dequote in place */ /* For certain types, we can cast to non-string Perlish values */ switch (type_info->type_id) { case PG_BOOL: if (imp_dbh->pg_bool_tf) { *value = ('1' == *value) ? 't' : 'f'; sv_setpvn(sv, (char *)value, value_len); } else sv_setiv(sv, '1' == *value ? 1 : 0); break; #if IVSIZE >= 8 && LONGSIZE >= 8 case PG_INT8: if (imp_dbh->pg_int8_as_string) { sv_setpvn(sv, (char *)value, value_len); break; } #endif case PG_INT2: case PG_INT4: sv_setiv(sv, atol((char *)value)); break; case PG_FLOAT4: case PG_FLOAT8: sv_setnv(sv, strtod((char *)value, NULL)); break; default: sv_setpvn(sv, (char *)value, value_len); } } else { sv_setpv(sv, (char *)value); } if (type_info && (PG_BPCHAR == type_info->type_id) && chopblanks) { char *p = SvEND(sv); STRLEN len = SvCUR(sv); while(len && ' ' == *--p) --len; if (len != SvCUR(sv)) { SvCUR_set(sv, len); *SvEND(sv) = '\0'; } } } if (imp_dbh->pg_utf8_flag) { /* The only exception to our rule about setting utf8 (when the client_encoding is set to UTF8) is bytea. */ if (type_info && PG_BYTEA == type_info->type_id) { SvUTF8_off(sv); } /* Don't try to upgrade references (e.g. arrays). pg_destringify_array() upgrades the items as appropriate. */ else if (!SvROK(sv)) { SvUTF8_on(sv); SvSETMAGIC(sv); } } } } imp_sth->cur_tuple += 1; /* Experimental inout support */ if (imp_sth->use_inout) { ph_t *currph; for (i=0,currph=imp_sth->ph; NULL != currph && i < num_fields; currph=currph->nextph,i++) { if (currph->isinout) sv_copypv(currph->inout, AvARRAY(av)[i]); } } if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_fetch\n", THEADER_slow); return av; } /* end of dbd_st_fetch */ /* ================================================================== */ /* Pop off savepoints to the specified savepoint name */ static void pg_db_free_savepoints_to (pTHX_ imp_dbh_t * imp_dbh, const char *savepoint) { I32 i; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_free_savepoints_to\n", THEADER_slow); for (i = av_len(imp_dbh->savepoints); i >= 0; i--) { SV * const elem = av_pop(imp_dbh->savepoints); if (strEQ(SvPV_nolen(elem), savepoint)) { sv_2mortal(elem); break; } sv_2mortal(elem); } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_free_savepoints_to\n", THEADER_slow); } /* ================================================================== */ long dbd_st_rows (SV * sth, imp_sth_t * imp_sth) { dTHX; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_st_rows\n", THEADER_slow); return imp_sth->rows; } /* end of dbd_st_rows */ /* ================================================================== */ int dbd_st_finish (SV * sth, imp_sth_t * imp_sth) { dTHX; D_imp_dbh_from_sth; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbdpg_finish (async: %d)\n", THEADER_slow, imp_dbh->async_status); /* Only handle async cleanup if THIS statement owns the async query */ if (imp_dbh->async_status && imp_dbh->async_sth == imp_sth) { handle_old_async(aTHX_ sth, imp_dbh, PG_OLDQUERY_WAIT); } imp_sth->async_status = STH_NO_ASYNC; if (imp_dbh->async_sth == imp_sth) { imp_dbh->async_sth = NULL; imp_dbh->async_status = DBH_NO_ASYNC; } DBIc_ACTIVE_off(imp_sth); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_finish\n", THEADER_slow); return 1; } /* end of dbd_st_finish */ /* ================================================================== */ static int pg_st_deallocate_statement (pTHX_ SV * sth, imp_sth_t * imp_sth) { D_imp_dbh_from_sth; char tempsqlstate[6]; int status; PGTransactionStatusType tstatus; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_st_deallocate_statement\n", THEADER_slow); if (imp_dbh->skip_deallocate) { if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_st_deallocate_statement (skipped)\n", THEADER_slow); return 0; } if (NULL == imp_dbh->conn || NULL == imp_sth->prepare_name) { if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_st_deallocate_statement (0)\n", THEADER_slow); return 0; } tempsqlstate[0] = '\0'; /* What is our status? */ tstatus = pg_db_txn_status(aTHX_ imp_dbh); if (TRACE5_slow) TRC(DBILOGFP, "%stxn_status is %d\n", THEADER_slow, tstatus); /* If we are in a failed transaction, rollback before deallocating */ if (PQTRANS_INERROR == tstatus) { if (TRACE4_slow) TRC(DBILOGFP, "%sIssuing rollback before deallocate\n", THEADER_slow); { /* 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) { char *cmd; SV * const sp = *av_fetch(imp_dbh->savepoints, alen, 0); New(0, cmd, SvLEN(sp) + 13, char); /* Freed below */ if (TRACE4_slow) TRC(DBILOGFP, "%sRolling back to savepoint %s\n", THEADER_slow, SvPV_nolen(sp)); sprintf(cmd, "rollback to %s", SvPV_nolen(sp)); strncpy(tempsqlstate, imp_dbh->sqlstate, sizeof(tempsqlstate)-1); tempsqlstate[sizeof(tempsqlstate)-1]='\0'; status = _result(aTHX_ imp_dbh, cmd); Safefree(cmd); } else { status = _result(aTHX_ 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 (TRACEWARN_slow) TRC(DBILOGFP, "%sRollback failed, so no deallocate\n", THEADER_slow); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_st_deallocate_statement (cannot deallocate)\n", THEADER_slow); return 1; } } #if PGLIBVERSION >= 170000 if (TRACE5_slow) TRC(DBILOGFP, "%sUsing PQclosePrepared: %s\n", THEADER_slow, imp_sth->prepare_name); imp_dbh->last_result = imp_sth->result = PQclosePrepared(imp_dbh->conn, imp_sth->prepare_name); imp_dbh->result_clearable = DBDPG_FALSE; status = _sqlstate(aTHX_ imp_dbh, imp_sth->result); #else { char * stmt; New(0, stmt, strlen("DEALLOCATE ") + strlen(imp_sth->prepare_name) + 1, char); /* freed below */ sprintf(stmt, "DEALLOCATE %s", imp_sth->prepare_name); if (TRACE5_slow) TRC(DBILOGFP, "%sDeallocating (%s)\n", THEADER_slow, imp_sth->prepare_name); status = _result(aTHX_ imp_dbh, stmt); Safefree(stmt); } #endif if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ sth, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_st_deallocate_statement (error: status not OK)\n", THEADER_slow); return 2; } Safefree(imp_sth->prepare_name); imp_sth->prepare_name = NULL; if (tempsqlstate[0]) { strncpy(imp_dbh->sqlstate, tempsqlstate, 6); } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_st_deallocate_statement\n", THEADER_slow); return 0; } /* end of pg_st_deallocate_statement */ /* ================================================================== */ void dbd_st_destroy (SV * sth, imp_sth_t * imp_sth) { dTHX; D_imp_dbh_from_sth; seg_t * currseg; seg_t * nextseg; ph_t * currph; ph_t * nextph; imp_dbh->do_tmp_sth = NULL; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_st_destroy\n", THEADER_slow); if (NULL == imp_sth->seg) /* Already been destroyed! */ croak("dbd_st_destroy called twice!"); /* If the AutoInactiveDestroy flag has been set, we go no further */ if ((DBIc_AIADESTROY(imp_dbh)) && ((U32)PerlProc_getpid() != (unsigned int)imp_dbh->pid_number)) { if (TRACE4_slow) { TRC(DBILOGFP, "%sskipping sth destroy due to AutoInactiveDestroy\n", THEADER_slow); } DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */ if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_destroy (AutoInactiveDestroy set)\n", THEADER_slow); return; } /* If the InactiveDestroy flag has been set, we go no further */ if (DBIc_IADESTROY(imp_dbh)) { if (TRACE4_slow) { TRC(DBILOGFP, "%sskipping sth destroy due to InactiveDestroy\n", THEADER_slow); } DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */ if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_destroy (InactiveDestroy set)\n", THEADER_slow); return; } /* Only handle async cleanup if THIS statement owns the async query */ if (imp_dbh->async_status && imp_dbh->async_sth == imp_sth) { handle_old_async(aTHX_ sth, imp_dbh, PG_OLDQUERY_WAIT); } /* 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 (pg_st_deallocate_statement(aTHX_ sth, imp_sth)!=0) { if (TRACEWARN_slow) TRC(DBILOGFP, "%sCould not deallocate\n", THEADER_slow); } } Safefree(imp_sth->prepare_name); Safefree(imp_sth->type_info); Safefree(imp_sth->firstword); Safefree(imp_sth->PQvals); Safefree(imp_sth->PQlens); Safefree(imp_sth->PQfmts); Safefree(imp_sth->PQoids); /* If our result is the same as the last_result, we will not free it, but will cede control over it so that the parent dbh can clear it later. We do this in case $dbh->pg_error_field() is called */ if (imp_sth->result == imp_dbh->last_result) { imp_dbh->result_clearable = DBDPG_TRUE; } else { if (imp_sth->result) { /* Nobody else is using this PGresult, so we can clear it */ TRACE_PQCLEAR; PQclear(imp_sth->result); } } /* Regardless of the above, we want to not use this anymore */ 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; if (NULL != imp_dbh->async_sth && imp_dbh->async_sth == imp_sth) imp_dbh->async_sth = NULL; DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */ if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_destroy\n", THEADER_slow); } /* end of dbd_st_destroy */ /* ================================================================== */ int pg_db_putline (SV * dbh, SV * svbuf) { dTHX; D_imp_dbh(dbh); const char * buffer; STRLEN len; int copystatus; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_putline\n", THEADER_slow); /* We must be in COPY IN state */ if (PGRES_COPY_IN != imp_dbh->copystate && PGRES_COPY_BOTH != imp_dbh->copystate) croak("pg_putline can only be called directly after issuing a COPY FROM command\n"); if (!svbuf || !SvOK(svbuf)) croak("pg_putline can only be called with a defined value\n"); buffer = SvPV(svbuf,len); TRACE_PQPUTCOPYDATA; copystatus = PQputCopyData(imp_dbh->conn, buffer, (int)strlen(buffer)); if (-1 == copystatus) { _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_putline (error: copystatus not -1)\n", THEADER_slow); return 0; } else if (1 != copystatus) { croak("PQputCopyData gave a value of %d\n", copystatus); } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_putline\n", THEADER_slow); return 0; } /* end of pg_db_putline */ /* ================================================================== */ int pg_db_getline (SV * dbh, SV * svbuf, int length) { dTHX; D_imp_dbh(dbh); int copystatus; char * tempbuf; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_getline\n", THEADER_slow); tempbuf = NULL; /* We must be in COPY OUT state */ if (PGRES_COPY_OUT != imp_dbh->copystate && PGRES_COPY_BOTH != imp_dbh->copystate) croak("pg_getline can only be called directly after issuing a COPY TO command\n"); length = 0; /* Make compilers happy */ TRACE_PQGETCOPYDATA; copystatus = PQgetCopyData(imp_dbh->conn, &tempbuf, 0); if (-1 == copystatus) { sv_setpvn(svbuf, "", 0); imp_dbh->copystate=0; TRACE_PQENDCOPY; PQendcopy(imp_dbh->conn); /* Can't hurt */ if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_getline (-1)\n", THEADER_slow); return -1; } else if (copystatus < 1) { _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); } else { sv_setpvn(svbuf, tempbuf, copystatus); TRACE_PQFREEMEM; PQfreemem(tempbuf); } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_getline (0)\n", THEADER_slow); return 0; } /* end of pg_db_getline */ /* ================================================================== */ int pg_db_getcopydata (SV * dbh, SV * dataline, int async) { dTHX; D_imp_dbh(dbh); int copystatus; char * tempbuf; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_getcopydata\n", THEADER_slow); /* We must be in COPY OUT state */ if (PGRES_COPY_OUT != imp_dbh->copystate && PGRES_COPY_BOTH != imp_dbh->copystate) croak("pg_getcopydata can only be called directly after issuing a COPY TO command\n"); tempbuf = NULL; TRACE_PQGETCOPYDATA; copystatus = PQgetCopyData(imp_dbh->conn, &tempbuf, async); if (copystatus > 0) { sv_setpvn(dataline, tempbuf, copystatus); if (imp_dbh->pg_utf8_flag && !imp_dbh->copybinary) SvUTF8_on(dataline); else SvUTF8_off(dataline); TRACE_PQFREEMEM; PQfreemem(tempbuf); } else if (0 == copystatus) { /* async and still in progress: consume and return */ TRACE_PQCONSUMEINPUT; if (!PQconsumeInput(imp_dbh->conn)) { _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_getcopydata (error: async in progress)\n", THEADER_slow); return -2; } } else if (-1 == copystatus) { PGresult * result; ExecStatusType status; sv_setpv(dataline, ""); imp_dbh->copystate=0; TRACE_PQGETRESULT; result = PQgetResult(imp_dbh->conn); status = _sqlstate(aTHX_ imp_dbh, result); while (result != NULL) { TRACE_PQCLEAR; PQclear(result); TRACE_PQGETRESULT; result = PQgetResult(imp_dbh->conn); } if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); } } else { _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_getcopydata\n", THEADER_slow); return copystatus; } /* end of pg_db_getcopydata */ /* ================================================================== */ int pg_db_putcopydata (SV * dbh, SV * dataline) { dTHX; D_imp_dbh(dbh); int copystatus; const char *copydata; STRLEN copylen; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_putcopydata\n", THEADER_slow); /* We must be in COPY IN state */ if (PGRES_COPY_IN != imp_dbh->copystate && PGRES_COPY_BOTH != imp_dbh->copystate) croak("pg_putcopydata can only be called directly after issuing a COPY FROM command\n"); if (imp_dbh->pg_utf8_flag && !imp_dbh->copybinary) copydata = SvPVutf8(dataline, copylen); else copydata = SvPVbyte(dataline, copylen); TRACE_PQPUTCOPYDATA; copystatus = PQputCopyData(imp_dbh->conn, copydata, copylen); if (1 == copystatus) { if (PGRES_COPY_BOTH == imp_dbh->copystate && PQflush(imp_dbh->conn)) { _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); } } else if (0 == copystatus) { /* non-blocking mode only */ } else { _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_putcopydata\n", THEADER_slow); return copystatus == 1 ? 1 : 0; } /* end of pg_db_putcopydata */ /* ================================================================== */ int pg_db_putcopyend (SV * dbh) { /* If in COPY_IN or COPY_BOTH mode, terminate the COPYing */ /* Returns 1 on success, otherwise 0 (plus a probably warning/error) */ dTHX; D_imp_dbh(dbh); int copystatus; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_putcopyend\n", THEADER_slow); if (0 == imp_dbh->copystate) { warn("pg_putcopyend cannot be called until a COPY is issued"); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_putcopyend (warning: copystate is 0)\n", THEADER_slow); return 0; } if (PGRES_COPY_OUT == imp_dbh->copystate) { warn("PQputcopyend does not need to be called when using PGgetcopydata"); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_putcopyend (warning: copy state is OUT)\n", THEADER_slow); return 0; } /* Must be PGRES_COPY_IN or PGRES_COPY_BOTH at this point */ TRACE_PQPUTCOPYEND; copystatus = PQputCopyEnd(imp_dbh->conn, NULL); if (1 == copystatus) { PGresult * result; ExecStatusType status; imp_dbh->copystate = 0; TRACE_PQGETRESULT; result = PQgetResult(imp_dbh->conn); status = _sqlstate(aTHX_ imp_dbh, result); while (result != NULL) { TRACE_PQCLEAR; PQclear(result); TRACE_PQGETRESULT; result = PQgetResult(imp_dbh->conn); } if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_putcopyend (error: status not OK)\n", THEADER_slow); return 0; } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_putcopyend (1)\n", THEADER_slow); return 1; } else if (0 == copystatus) { /* non-blocking mode only */ if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_putcopyend (0)\n", THEADER_slow); return 0; } else { _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_putcopyend (error: copystatus unknown)\n", THEADER_slow); return 0; } } /* end of pg_db_putcopyend */ /* ================================================================== */ SV * pg_db_error_field (SV *dbh, char * fieldname) { dTHX; D_imp_dbh(dbh); int fieldcode = 0; char ucname[42]; int i; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_error_field (fieldname=%s)\n", THEADER_slow, fieldname); for (i = 0; i < (int)sizeof(ucname) - 1 && fieldname[i]; i++) ucname[i] = toupper((unsigned char)fieldname[i]); ucname[i] = '\0'; /* These allow partial matches, which is why 'severity_nonlocalized' needs to go first */ if ( 0 == strncmp(ucname, "PG_DIAG_SEVERITY_NONLOCALIZED", 25) || 0 == strncmp(ucname, "SEVERITY_NONLOCAL", 17)) { fieldcode = PG_DIAG_SEVERITY_NONLOCALIZED; // i.e. 'V' } else if ( 0 == strncmp(ucname, "PG_DIAG_SEVERITY", 16) || 0 == strncmp(ucname, "SEVERITY", 8)) { fieldcode = PG_DIAG_SEVERITY; // i.e. 'S' } else if ( 0 == strncmp(ucname, "PG_DIAG_MESSAGE_PRIMARY", 20) || 0 == strncmp(ucname, "MESSAGE_PRIMARY", 13) || 0 == strncmp(ucname, "PRIMARY", 4)) { fieldcode = PG_DIAG_MESSAGE_PRIMARY; // i.e. 'M' } else if ( 0 == strncmp(ucname, "PG_DIAG_MESSAGE_DETAIL", 22) || 0 == strncmp(ucname, "MESSAGE_DETAIL", 14) || 0 == strncmp(ucname, "DETAIL", 6)) { fieldcode = PG_DIAG_MESSAGE_DETAIL; // i.e. 'D' } else if ( 0 == strncmp(ucname, "PG_DIAG_MESSAGE_HINT", 20) || 0 == strncmp(ucname, "MESSAGE_HINT", 12) || 0 == strncmp(ucname, "HINT", 4)) { fieldcode = PG_DIAG_MESSAGE_HINT; // i.e. 'H' } else if ( 0 == strncmp(ucname, "PG_DIAG_STATEMENT_POSITION", 21) || 0 == strncmp(ucname, "STATEMENT_POSITION", 13)) { fieldcode = PG_DIAG_STATEMENT_POSITION; // i.e. 'P' } else if ( 0 == strncmp(ucname, "PG_DIAG_INTERNAL_POSITION", 20) || 0 == strncmp(ucname, "INTERNAL_POSITION", 12)) { fieldcode = PG_DIAG_INTERNAL_POSITION; // i.e. 'p' } else if ( 0 == strncmp(ucname, "PG_DIAG_INTERNAL_QUERY", 22) || 0 == strncmp(ucname, "INTERNAL_QUERY", 14)) { fieldcode = PG_DIAG_INTERNAL_QUERY; // i.e. 'q' } else if ( 0 == strncmp(ucname, "PG_DIAG_CONTEXT", 15) || 0 == strncmp(ucname, "CONTEXT", 7)) { fieldcode = PG_DIAG_CONTEXT; // i.e. 'W' } else if ( 0 == strncmp(ucname, "PG_DIAG_SCHEMA_NAME", 14) || 0 == strncmp(ucname, "SCHEMA", 5)) { fieldcode = PG_DIAG_SCHEMA_NAME; // i.e. 's' } else if ( 0 == strncmp(ucname, "PG_DIAG_TABLE_NAME", 13) || 0 == strncmp(ucname, "TABLE", 5)) { fieldcode = PG_DIAG_TABLE_NAME; // i.e. 't' } else if ( 0 == strncmp(ucname, "PG_DIAG_COLUMN_NAME", 11) || 0 == strncmp(ucname, "COLUMN", 3)) { fieldcode = PG_DIAG_COLUMN_NAME; // i.e. 'c' } else if ( 0 == strncmp(ucname, "PG_DIAG_DATATYPE_NAME", 16) || 0 == strncmp(ucname, "DATATYPE", 8) || 0 == strncmp(ucname, "TYPE", 4)) { fieldcode = PG_DIAG_DATATYPE_NAME; // i.e. 'd' } else if ( 0 == strncmp(ucname, "PG_DIAG_CONSTRAINT_NAME", 18) || 0 == strncmp(ucname, "CONSTRAINT", 10)) { fieldcode = PG_DIAG_CONSTRAINT_NAME; // i.e. 'n' } else if ( 0 == strncmp(ucname, "PG_DIAG_SOURCE_FILE", 19) || 0 == strncmp(ucname, "SOURCE_FILE", 11)) { fieldcode = PG_DIAG_SOURCE_FILE; // i.e. 'F' } else if ( 0 == strncmp(ucname, "PG_DIAG_SOURCE_LINE", 19) || 0 == strncmp(ucname, "SOURCE_LINE", 11)) { fieldcode = PG_DIAG_SOURCE_LINE; // i.e. 'L' } else if ( 0 == strncmp(ucname, "PG_DIAG_SOURCE_FUNCTION", 19) || 0 == strncmp(ucname, "SOURCE_FUNCTION", 11)) { fieldcode = PG_DIAG_SOURCE_FUNCTION; // i.e. 'R' } else if ( 0 == strncmp(ucname, "PG_DIAG_SQLSTATE", 16) || 0 == strncmp(ucname, "SQLSTATE", 8) || 0 == strncmp(ucname, "STATE", 5)) { fieldcode = PG_DIAG_SQLSTATE; // i.e. 'C' } else { pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, "Invalid error field"); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_error_field (error: invalid field)\n", THEADER_slow); return &PL_sv_undef; } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_error_field (fieldcode: %d)\n", THEADER_slow, fieldcode); TRACE_PQRESULTERRORFIELD; char *pq_err_field = PQresultErrorField(imp_dbh->last_result, fieldcode); if (NULL == pq_err_field) { return &PL_sv_undef; } else { SV *sv_err_field = newSVpv(pq_err_field, 0); if (imp_dbh->pg_utf8_flag) SvUTF8_on(sv_err_field); return sv_2mortal(sv_err_field); } } /* end of pg_db_error_field */ /* ================================================================== */ int pg_db_endcopy (SV * dbh) { dTHX; D_imp_dbh(dbh); int copystatus; PGresult * result; ExecStatusType status; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_endcopy\n", THEADER_slow); if (0==imp_dbh->copystate) croak("pg_endcopy cannot be called until a COPY is issued"); if (PGRES_COPY_IN == imp_dbh->copystate) { TRACE_PQPUTCOPYEND; copystatus = PQputCopyEnd(imp_dbh->conn, NULL); if (-1 == copystatus) { _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_endcopy (error)\n", THEADER_slow); return 1; } else if (1 != copystatus) croak("PQputCopyEnd returned a value of %d\n", copystatus); /* Get the final result of the copy */ TRACE_PQGETRESULT; result = PQgetResult(imp_dbh->conn); status = _sqlstate(aTHX_ imp_dbh, result); TRACE_PQCLEAR; PQclear(result); if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_endcopy (error: status not OK)\n", THEADER_slow); return 1; } copystatus = 0; } else { TRACE_PQENDCOPY; copystatus = PQendcopy(imp_dbh->conn); } imp_dbh->copystate = 0; if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_endcopy\n", THEADER_slow); return copystatus; } /* end of pg_db_endcopy */ /* ================================================================== */ void pg_db_pg_server_trace (SV * dbh, FILE * fh) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_pg_server_trace\n", THEADER_slow); TRACE_PQTRACE; PQtrace(imp_dbh->conn, fh); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_pg_server_trace\n", THEADER_slow); } /* end of pg_db_pg_server_trace */ /* ================================================================== */ void pg_db_pg_server_untrace (SV * dbh) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_pg_server_untrace\n", THEADER_slow); TRACE_PQUNTRACE; PQuntrace(imp_dbh->conn); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_pg_server_untrace\n", THEADER_slow); } /* end of pg_db_pg_server_untrace */ /* ================================================================== */ int pg_db_savepoint (SV * dbh, imp_dbh_t * imp_dbh, char * savepoint) { dTHX; int status; char * action; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_savepoint (name: %s)\n", THEADER_slow, savepoint); /* no action if AutoCommit = on or the connection is invalid */ if ((NULL == imp_dbh->conn) || (DBIc_has(imp_dbh, DBIcf_AutoCommit))) { if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_savepoint (0)\n", THEADER_slow); return 0; } /* Start a new transaction if this is the first command */ if (!imp_dbh->done_begin) { status = _result(aTHX_ imp_dbh, "begin"); if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_savepoint (error: status not OK for begin)\n", THEADER_slow); return -2; } imp_dbh->done_begin = DBDPG_TRUE; } New(0, action, strlen(savepoint) + 11, char); /* freed below */ sprintf(action, "savepoint %s", savepoint); status = _result(aTHX_ imp_dbh, action); Safefree(action); if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_savepoint (error: status not OK for savepoint)\n", THEADER_slow); return 0; } av_push(imp_dbh->savepoints, newSVpv(savepoint,0)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_savepoint\n", THEADER_slow); return 1; } /* end of pg_db_savepoint */ /* ================================================================== */ int pg_db_rollback_to (SV * dbh, imp_dbh_t * imp_dbh, const char *savepoint) { dTHX; int status; char * action; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_rollback_to (name: %s)\n", THEADER_slow, savepoint); /* no action if AutoCommit = on or the connection is invalid */ if ((NULL == imp_dbh->conn) || (DBIc_has(imp_dbh, DBIcf_AutoCommit))) { if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_rollback_to (0)\n", THEADER_slow); return 0; } New(0, action, strlen(savepoint) + 13, char); sprintf(action, "rollback to %s", savepoint); status = _result(aTHX_ imp_dbh, action); Safefree(action); if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_rollback_to (error: status not OK for rollback)\n", THEADER_slow); return 0; } pg_db_free_savepoints_to(aTHX_ imp_dbh, savepoint); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_rollback_to\n", THEADER_slow); return 1; } /* end of pg_db_rollback_to */ /* ================================================================== */ int pg_db_release (SV * dbh, imp_dbh_t * imp_dbh, char * savepoint) { dTHX; int status; char * action; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_release (name: %s)\n", THEADER_slow, savepoint); /* no action if AutoCommit = on or the connection is invalid */ if ((NULL == imp_dbh->conn) || (DBIc_has(imp_dbh, DBIcf_AutoCommit))) { if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_release (0)\n", THEADER_slow); return 0; } New(0, action, strlen(savepoint) + 9, char); sprintf(action, "release %s", savepoint); status = _result(aTHX_ imp_dbh, action); Safefree(action); if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_release (error: status not OK for release)\n", THEADER_slow); return 0; } pg_db_free_savepoints_to(aTHX_ imp_dbh, savepoint); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_release\n", THEADER_slow); return 1; } /* end of pg_db_release */ /* ================================================================== */ /* For lo_* functions. Used to ensure we are in a transaction */ static int pg_db_start_txn (pTHX_ SV * dbh, imp_dbh_t * imp_dbh) { if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_start_txn\n", THEADER_slow); /* If not autocommit, start a new transaction */ if (!imp_dbh->done_begin) { int status = _result(aTHX_ imp_dbh, "begin"); if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_start_txn (error: status not OK for begin)\n", THEADER_slow); return 0; } imp_dbh->done_begin = DBDPG_TRUE; } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_start_txn\n", THEADER_slow); return 1; } /* end of pg_db_start_txn */ /* ================================================================== */ /* For lo_import and lo_export functions. Used to commit or rollback a transaction, but only if AutoCommit is on. */ static int pg_db_end_txn (pTHX_ SV * dbh, imp_dbh_t * imp_dbh, int commit) { int status; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_end_txn with %s\n", THEADER_slow, commit ? "commit" : "rollback"); status = _result(aTHX_ imp_dbh, commit ? "commit" : "rollback"); imp_dbh->done_begin = DBDPG_FALSE; if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ dbh, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_end_txn (error: status not OK for %s)\n", THEADER_slow, commit ? "commit" : "rollback"); return 0; } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_end_txn\n", THEADER_slow); return 1; } /* end of pg_db_end_txn */ /* Large object functions */ /* ================================================================== */ unsigned int pg_db_lo_creat (SV * dbh, int mode) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_pg_lo_creat (mode: %d)\n", THEADER_slow, mode); if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { croak("Cannot call pg_lo_creat when AutoCommit is on"); } if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) { return 0; /* No other option, because lo_creat returns an Oid */ } if (TLIBPQ_slow) { TRC(DBILOGFP, "%slo_creat\n", THEADER_slow); } return lo_creat(imp_dbh->conn, mode); /* 0 on error */ } /* ================================================================== */ int pg_db_lo_open (SV * dbh, unsigned int lobjId, int mode) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_pg_lo_open (mode: %d objectid: %u)\n", THEADER_slow, mode, lobjId); if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { croak("Cannot call pg_lo_open when AutoCommit is on"); } if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) return -2; if (TLIBPQ_slow) { TRC(DBILOGFP, "%slo_open\n", THEADER_slow); } return lo_open(imp_dbh->conn, lobjId, mode); /* -1 on error */ } /* ================================================================== */ int pg_db_lo_close (SV * dbh, int fd) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_close (fd: %d)\n", THEADER_slow, fd); if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { croak("Cannot call pg_lo_close when AutoCommit is on"); } if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) return -1; if (TLIBPQ_slow) { TRC(DBILOGFP, "%slo_close\n", THEADER_slow); } return lo_close(imp_dbh->conn, fd); /* <0 on error, 0 if ok */ } /* ================================================================== */ int pg_db_lo_read (SV * dbh, int fd, char * buf, size_t len) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_read (fd: %d length: %" UVuf ")\n", THEADER_slow, fd, (UV)len); if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { croak("Cannot call pg_lo_read when AutoCommit is on"); } if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) return -1; if (TLIBPQ_slow) { TRC(DBILOGFP, "%slo_read\n", THEADER_slow); } return lo_read(imp_dbh->conn, fd, buf, len); /* bytes read, <0 on error */ } /* ================================================================== */ int pg_db_lo_write (SV * dbh, int fd, char * buf, size_t len) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_write (fd: %d length: %" UVuf ")\n", THEADER_slow, fd, (UV)len); if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { croak("Cannot call pg_lo_write when AutoCommit is on"); } if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) return -1; if (TLIBPQ_slow) { TRC(DBILOGFP, "%slo_write\n", THEADER_slow); } return lo_write(imp_dbh->conn, fd, buf, len); /* bytes written, <0 on error */ } /* ================================================================== */ IV pg_db_lo_lseek (SV * dbh, int fd, IV offset, int whence) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_lseek (fd: %d offset: %" IVdf " whence: %d)\n", THEADER_slow, fd, offset, whence); if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { croak("Cannot call pg_lo_lseek when AutoCommit is on"); } if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) return -1; #ifdef HAS64BITLO if (imp_dbh->pg_server_version >= 90300) { if (TLIBPQ_slow) TRC(DBILOGFP, "%slo_lseek64\n", THEADER_slow); return lo_lseek64(imp_dbh->conn, fd, offset, whence); /* new position, -1 on error */ } if (offset < INT_MIN || offset > INT_MAX) croak("lo_lseek offset out of range of integer"); #endif if (TLIBPQ_slow) TRC(DBILOGFP, "%slo_lseek\n", THEADER_slow); return lo_lseek(imp_dbh->conn, fd, offset, whence); /* new position, -1 on error */ } /* ================================================================== */ IV pg_db_lo_tell (SV * dbh, int fd) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_tell (fd: %d)\n", THEADER_slow, fd); if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { croak("Cannot call pg_lo_tell when AutoCommit is on"); } if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) return -1; #ifdef HAS64BITLO if (TLIBPQ_slow) TRC(DBILOGFP, "%slo_tell64\n", THEADER_slow); if (imp_dbh->pg_server_version >= 90300) return lo_tell64(imp_dbh->conn, fd); /* current position, <0 on error */ #endif if (TLIBPQ_slow) TRC(DBILOGFP, "%slo_tell\n", THEADER_slow); return lo_tell(imp_dbh->conn, fd); /* current position, <0 on error */ } /* ================================================================== */ int pg_db_lo_truncate (SV * dbh, int fd, IV len) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_truncate (fd: %d length: %" IVdf ")\n", THEADER_slow, fd, len); if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { croak("Cannot call pg_lo_truncate when AutoCommit is on"); } if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) return -1; #ifdef HAS64BITLO if (TLIBPQ_slow) TRC(DBILOGFP, "%slo_truncate64\n", THEADER_slow); if (imp_dbh->pg_server_version >= 90300) return lo_truncate64(imp_dbh->conn, fd, len); /* 0 success, <0 on error */ if (len < INT_MIN || len > INT_MAX) croak("lo_truncate len out of range of integer"); #endif if (TLIBPQ_slow) TRC(DBILOGFP, "%slo_truncate\n", THEADER_slow); return lo_truncate(imp_dbh->conn, fd, len); /* 0 success, <0 on error */ } /* ================================================================== */ int pg_db_lo_unlink (SV * dbh, unsigned int lobjId) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_unlink (objectid: %u)\n", THEADER_slow, lobjId); if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { croak("Cannot call pg_lo_unlink when AutoCommit is on"); } if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) return -1; if (TLIBPQ_slow) { TRC(DBILOGFP, "%slo_unlink\n", THEADER_slow); } return lo_unlink(imp_dbh->conn, lobjId); /* 1 on success, -1 on failure */ } /* ================================================================== */ unsigned int pg_db_lo_import (SV * dbh, char * filename) { Oid loid; dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_import (filename: %s)\n", THEADER_slow, filename); if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) return 0; /* No other option, because lo_import returns an Oid */ if (TLIBPQ_slow) { TRC(DBILOGFP, "%slo_import\n", THEADER_slow); } loid = lo_import(imp_dbh->conn, filename); /* 0 on error */ if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { if (!pg_db_end_txn(aTHX_ dbh, imp_dbh, 0==loid ? 0 : 1)) return 0; } return loid; } /* ================================================================== */ unsigned int pg_db_lo_import_with_oid (SV * dbh, char * filename, unsigned int lobjId) { Oid loid; dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_import_with_oid (filename: %s, oid: %u)\n", THEADER_slow, filename, lobjId); if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) return 0; /* No other option, because lo_import* returns an Oid */ if (TLIBPQ_slow) { TRC(DBILOGFP, "%slo_import_with_oid\n", THEADER_slow); } loid = lo_import_with_oid(imp_dbh->conn, filename, lobjId); /* 0 on error */ if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { if (!pg_db_end_txn(aTHX_ dbh, imp_dbh, 0==loid ? 0 : 1)) return 0; } return loid; } /* ================================================================== */ int pg_db_lo_export (SV * dbh, unsigned int lobjId, char * filename) { int result; dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_export (objectid: %u filename: %s)\n", THEADER_slow, lobjId, filename); if (!pg_db_start_txn(aTHX_ dbh,imp_dbh)) return -2; if (TLIBPQ_slow) { TRC(DBILOGFP, "%slo_export\n", THEADER_slow); } result = lo_export(imp_dbh->conn, lobjId, filename); /* 1 on success, -1 on failure */ if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { if (!pg_db_end_txn(aTHX_ dbh, imp_dbh, result==-1 ? 0 : 1)) return -1; } return result; } /* ================================================================== */ int dbd_st_blob_read (SV * sth, imp_sth_t * imp_sth, int lobjId, long offset, long len, SV * destrv, long destoffset) { dTHX; D_imp_dbh_from_sth; int ret, lobj_fd, nbytes; STRLEN nread; SV * bufsv; char * tmp; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_st_blob_read (objectid: %d offset: %ld length: %ld)\n", THEADER_slow, lobjId, offset, len); /* safety checks */ if (lobjId <= 0) { pg_error(aTHX_ sth, PGRES_FATAL_ERROR, "dbd_st_blob_read: lobjId <= 0"); return 0; } if (offset < 0) { pg_error(aTHX_ sth, PGRES_FATAL_ERROR, "dbd_st_blob_read: offset < 0"); return 0; } if (len < 0) { pg_error(aTHX_ sth, PGRES_FATAL_ERROR, "dbd_st_blob_read: len < 0"); return 0; } if (! SvROK(destrv)) { pg_error(aTHX_ sth, PGRES_FATAL_ERROR, "dbd_st_blob_read: destrv not a reference"); return 0; } if (destoffset < 0) { pg_error(aTHX_ 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) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ sth, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_blob_read (error: open failed)\n", THEADER_slow); return 0; } /* seek on large object */ if (offset > 0) { ret = lo_lseek(imp_dbh->conn, lobj_fd, (int)offset, SEEK_SET); if (ret < 0) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ sth, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_blob_read (error: bad seek)\n", THEADER_slow); 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) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ sth, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_blob_read (error: close failed)\n", THEADER_slow); return 0; } if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_blob_read (bytes: %d)\n", THEADER_slow, (int)nread); return (int)nread; } /* end of dbd_st_blob_read */ /* ================================================================== */ /* Return the result of an asynchronous query, waiting if needed */ long pg_db_result (SV *h, imp_dbh_t *imp_dbh) { dTHX; PGresult *result; ExecStatusType status; long rows = 0; /* Determine if we were called from a statement handle or database handle */ /* The Pg.xs passes sth/dbh as h, but imp_dbh is always the database handle */ D_imp_xxh(h); imp_sth_t *imp_sth = NULL; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_result\n", THEADER_slow); if (DBIt_ST == DBIc_TYPE(imp_xxh)) { imp_sth = (imp_sth_t*)imp_xxh; } /* Handle auto-retrieved results from PG_OLDQUERY_WAIT */ if (imp_sth && STH_ASYNC_AUTORETRIEVED == imp_sth->async_status) { if (NULL == imp_sth->result) { pg_error(aTHX_ h, PGRES_FATAL_ERROR, "Auto-retrieved results already consumed"); return -2; } status = _sqlstate(aTHX_ imp_dbh, imp_sth->result); if (PGRES_TUPLES_OK == status || PGRES_COMMAND_OK == status) { rows = imp_sth->rows; } else { TRACE_PQERRORMESSAGE; pg_error(aTHX_ h, status, PQerrorMessage(imp_dbh->conn)); rows = -2; } imp_sth->async_status = STH_NO_ASYNC; if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_result (auto-retrieved, %ld rows)\n", THEADER_slow, rows); return rows; } /* Handle auto-retrieved error results from PG_OLDQUERY_WAIT */ if (imp_sth && STH_ASYNC_AUTOERROR == imp_sth->async_status) { if (NULL == imp_sth->result) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ h, PGRES_FATAL_ERROR, "Auto-retrieved error already reported"); return -2; } status = _sqlstate(aTHX_ imp_dbh, imp_sth->result); TRACE_PQRESULTERRORMESSAGE; pg_error(aTHX_ h, status, PQresultErrorMessage(imp_sth->result)); imp_sth->async_status = STH_NO_ASYNC; if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_result (auto-retrieved error)\n", THEADER_slow); return -2; } /* No auto-retrieved results: check that an async query is actually running */ if (DBH_ASYNC != imp_dbh->async_status) { pg_error(aTHX_ h, PGRES_FATAL_ERROR, "No asynchronous query is running\n"); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_result (error: no async)\n", THEADER_slow); return -2; } /* Verify ownership: only the statement that started the async query can retrieve it */ if (imp_sth && imp_dbh->async_sth && imp_sth != imp_dbh->async_sth) { pg_error(aTHX_ h, PGRES_FATAL_ERROR, "pg_result() called on wrong statement handle - this statement does not own the async query\n"); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_result (wrong statement)\n", THEADER_slow); return -2; } imp_dbh->copystate = 0; /* Assume not in copy mode until told otherwise */ TRACE_PQGETRESULT; while ((result = PQgetResult(imp_dbh->conn)) != NULL) { /* TODO: Better multiple result-set handling */ status = _sqlstate(aTHX_ imp_dbh, result); switch ((int)status) { case PGRES_TUPLES_OK: TRACE_PQNTUPLES; rows = PQntuples(result); /* Store metadata in the appropriate statement handle */ if (imp_sth && imp_sth == imp_dbh->async_sth) { imp_sth->cur_tuple = 0; TRACE_PQNFIELDS; DBIc_NUM_FIELDS(imp_sth) = PQnfields(result); DBIc_ACTIVE_on(imp_sth); } else if (!imp_sth && imp_dbh->async_sth) { /* Called via $dbh->pg_result - store in the async statement */ imp_dbh->async_sth->cur_tuple = 0; TRACE_PQNFIELDS; DBIc_NUM_FIELDS(imp_dbh->async_sth) = PQnfields(result); DBIc_ACTIVE_on(imp_dbh->async_sth); if (TRACE3_slow) { TRC(DBILOGFP, "%sUsing imp_dbh->async_sth for $dbh->pg_result()\n", THEADER_slow); } } break; case PGRES_COMMAND_OK: /* non-select statement */ TRACE_PQCMDTUPLES; rows = atol(PQcmdTuples(result)); break; case PGRES_COPY_OUT: case PGRES_COPY_IN: case PGRES_COPY_BOTH: /* Copy Out/In data transfer in progress */ imp_dbh->copystate = status; imp_dbh->copybinary = PQbinaryTuples(result); rows = -1; break; case PGRES_EMPTY_QUERY: case PGRES_BAD_RESPONSE: case PGRES_NONFATAL_ERROR: rows = -2; TRACE_PQERRORMESSAGE; pg_error(aTHX_ h, status, PQerrorMessage(imp_dbh->conn)); break; case PGRES_FATAL_ERROR: /* query cancelled? */ if (0 == strncmp(imp_dbh->sqlstate, "57014", 5)) { rows = 0; break; } default: rows = -2; TRACE_PQERRORMESSAGE; pg_error(aTHX_ h, status, PQerrorMessage(imp_dbh->conn)); break; } /* Store the result in the appropriate statement handle */ if (imp_sth && imp_sth == imp_dbh->async_sth) { if (imp_dbh->last_result && imp_dbh->result_clearable) { TRACE_PQCLEAR; PQclear(imp_dbh->last_result); } if (imp_sth->result && imp_sth->result != imp_dbh->last_result) { TRACE_PQCLEAR; PQclear(imp_sth->result); } imp_dbh->last_result = imp_sth->result = result; imp_dbh->result_clearable = DBDPG_FALSE; } else if (NULL == imp_sth && NULL != imp_dbh->async_sth) { if (imp_dbh->last_result && imp_dbh->result_clearable) { TRACE_PQCLEAR; PQclear(imp_dbh->last_result); } /* If the above wasn't the async handle's result, free that too */ if (imp_dbh->async_sth->result && imp_dbh->async_sth->result != imp_dbh->last_result) { TRACE_PQCLEAR; PQclear(imp_dbh->async_sth->result); } imp_dbh->last_result = imp_dbh->async_sth->result = result; imp_dbh->result_clearable = DBDPG_FALSE; } else { if (imp_dbh->last_result && imp_dbh->result_clearable) { TRACE_PQCLEAR; PQclear(imp_dbh->last_result); } imp_dbh->last_result = result; imp_dbh->result_clearable = DBDPG_TRUE; } if (rows == -1) { break; } } if (imp_sth && imp_sth == imp_dbh->async_sth) { imp_sth->rows = rows; imp_sth->async_status = STH_NO_ASYNC; } else if (NULL == imp_sth && NULL != imp_dbh->async_sth) { imp_dbh->async_sth->rows = rows; imp_dbh->async_sth->async_status = STH_NO_ASYNC; } imp_dbh->async_status = DBH_NO_ASYNC; if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_result (rows: %ld)\n", THEADER_slow, rows); return rows; } /* end of pg_db_result */ /* ================================================================== */ /* Indicates if an asynchronous query has finished yet Accepts either a database or a statement handle Returns: -1 if no query is running (and raises an exception) +1 if the query is finished 0 if the query is still running -2 for other errors */ static int pg_db_ready_error(SV *h, imp_dbh_t *imp_dbh, char *pq_call) { dTHX; if (strcmp(imp_dbh->sqlstate, "00000") != 0) _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ h, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_ready (error: %s failed)\n", THEADER_slow, pq_call); return -2; } int pg_db_ready(SV *h, imp_dbh_t *imp_dbh) { struct imp_sth_st *imp_sth; PGresult *result; int ret, status; dTHX; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_ready (async status: %d)\n", THEADER_slow, imp_dbh->async_status); switch (imp_dbh->async_status) { case DBH_NO_ASYNC: pg_error(aTHX_ h, PGRES_FATAL_ERROR, "No asynchronous query is running\n"); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_ready (error: no async)\n", THEADER_slow); return -1; case DBH_ASYNC_CONNECT: case DBH_ASYNC_CONNECT_POLL: if (TRACE5_slow) TRC(DBILOGFP, "%snot yet connected\n", THEADER_slow); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_ready (error: not connected)\n", THEADER_slow); return -1; } TRACE_PQCONSUMEINPUT; if (!PQconsumeInput(imp_dbh->conn)) { _fatal_sqlstate(aTHX_ imp_dbh); TRACE_PQERRORMESSAGE; pg_error(aTHX_ h, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_ready (error: consume failed)\n", THEADER_slow); return -2; } strcpy(imp_dbh->sqlstate, "00000"); ret = 0; TRACE_PQISBUSY; if (!PQisBusy(imp_dbh->conn)) { ret = 1; /* If async prepare has been used, deal with the result of the prepare call and send the actual query afterwards if the prepare was successful. */ imp_sth = imp_dbh->async_sth; if (imp_sth && STH_ASYNC_PREPARE == imp_sth->async_status) { status = PGRES_COMMAND_OK; TRACE_PQGETRESULT; while ((result = PQgetResult(imp_dbh->conn))) { ret = _sqlstate(aTHX_ imp_dbh, result); if (ret != PGRES_COMMAND_OK) status = ret; TRACE_PQCLEAR; PQclear(result); } if (PGRES_COMMAND_OK != status) { Safefree(imp_sth->prepare_name); imp_sth->prepare_name = NULL; imp_sth->async_status = STH_NO_ASYNC; imp_dbh->async_status = 0; imp_dbh->async_sth = NULL; return pg_db_ready_error(h, imp_dbh, "PQsendPrepare"); } imp_sth->prepared_by_us = DBDPG_TRUE; ++imp_dbh->prepare_number; ret = pq_send_prepared_query(aTHX_ imp_dbh, imp_sth); if (!ret) return pg_db_ready_error(h, imp_dbh, "PQsendQueryPrepared"); imp_sth->async_status = STH_ASYNC; ret = 0; } } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_ready\n", THEADER_slow); return ret; } /* end of pg_db_ready */ /* ================================================================== */ /* Send a cancel request for a running asynchronous query to the server. The result of the query - which may be "query was cancelled" (SQLSTATE 57014) - still needs to be determined in the ordinary way. */ int pg_db_send_cancel(SV *h, imp_dbh_t *imp_dbh) { dTHX; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_send_cancel (async status: %d)\n", THEADER_slow, imp_dbh->async_status); if (0 == imp_dbh->async_status) { pg_error(aTHX_ h, PGRES_FATAL_ERROR, "No asynchronous query is running"); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_send_cancel (error: no async)\n", THEADER_slow); return DBDPG_FALSE; } if (!do_send_cancel(h, imp_dbh, "pg_db_send_cancel")) return DBDPG_FALSE; if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_send_cancel\n", THEADER_slow); return DBDPG_TRUE; } /* end of pg_db_send_cancel */ /* ================================================================== */ /* Attempt to cancel a running asynchronous query Returns true if the cancel succeeded, and false if it did not In this case, pg_cancel will return false. NOTE: We only return true if we cancelled */ int pg_db_cancel(SV *h, imp_dbh_t *imp_dbh) { dTHX; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_cancel (async status: %d)\n", THEADER_slow, imp_dbh->async_status); if (!pg_db_send_cancel(h, imp_dbh)) return DBDPG_FALSE; pg_db_result(h, imp_dbh); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_cancel\n", THEADER_slow); return 0 == strncmp(imp_dbh->sqlstate, "57014", 5); } /* end of pg_db_cancel */ /* ================================================================== */ int pg_db_cancel_sth(SV *sth, imp_sth_t *imp_sth) { dTHX; D_imp_dbh_from_sth; bool cancel_result; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_cancel_sth (async status: %d)\n", THEADER_slow, imp_dbh->async_status); cancel_result = pg_db_cancel(sth, imp_dbh); dbd_st_finish(sth, imp_sth); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_cancel_sth\n", THEADER_slow); return cancel_result; } /* end of pg_db_cancel_sth */ /* ================================================================== */ /* Finish up an existing async query, either by cancelling it, or by waiting for a result. */ static int handle_old_async(pTHX_ SV * handle, imp_dbh_t * imp_dbh, const int asyncflag) { imp_sth_t * async_sth; PGresult *result; ExecStatusType ret; int status; if (TSTART_slow) TRC(DBILOGFP, "%sBegin handle_old_async (flag: %d)\n", THEADER_slow, asyncflag); async_sth = imp_dbh->async_sth; if (asyncflag & PG_OLDQUERY_CANCEL) { /* Cancel the outstanding query */ if (TRACE3_slow) { TRC(DBILOGFP, "%sCancelling old async command\n", THEADER_slow); } TRACE_PQISBUSY; if (PQisBusy(imp_dbh->conn)) { if (TRACE3_slow) TRC(DBILOGFP, "%sAttempting to cancel query\n", THEADER_slow); if (!do_send_cancel(handle, imp_dbh, "handle_old_async")) return -2; /* Suck up the cancellation notice */ status = 0; TRACE_PQGETRESULT; while ((result = PQgetResult(imp_dbh->conn)) != NULL) { TRACE_PQRESULTSTATUS; ret = PQresultStatus(result); TRACE_PQCLEAR; PQclear(result); if (!(ret == PGRES_COMMAND_OK || ret == PGRES_TUPLES_OK)) status = -1; } if (async_sth && STH_ASYNC_PREPARE == async_sth->async_status && -1 == status) { Safefree(async_sth->prepare_name); async_sth->prepare_name = NULL; } TRACE_PQTRANSACTIONSTATUS; if (PQTRANS_IDLE != PQtransactionStatus(imp_dbh->conn)) { /* We need to rollback! - reprepare!? */ TRACE_PQEXEC; PQexec(imp_dbh->conn, "rollback"); imp_dbh->done_begin = DBDPG_FALSE; } } } else if (asyncflag & PG_OLDQUERY_WAIT) { /* Finish up the outstanding query and throw out the result, unless an error */ if (TRACE3_slow) { TRC(DBILOGFP, "%sWaiting for old async command to finish\n", THEADER_slow); } wait_for_result: TRACE_PQGETRESULT; while ((result = PQgetResult(imp_dbh->conn)) != NULL) { status = _sqlstate(aTHX_ imp_dbh, result); /* Auto-retrieve results for the owning statement instead of discarding */ if (NULL != async_sth && STH_ASYNC == async_sth->async_status && (PGRES_TUPLES_OK == status || PGRES_COMMAND_OK == status)) { imp_sth_t *orig_sth = async_sth; if (orig_sth->result) { TRACE_PQCLEAR; PQclear(orig_sth->result); } orig_sth->result = result; if (PGRES_TUPLES_OK == status) { TRACE_PQNTUPLES; orig_sth->rows = PQntuples(result); orig_sth->cur_tuple = 0; TRACE_PQNFIELDS; DBIc_NUM_FIELDS(orig_sth) = PQnfields(result); DBIc_ACTIVE_on(orig_sth); } else { TRACE_PQCMDTUPLES; const char *ct = PQcmdTuples(result); orig_sth->rows = ct[0] ? atol(ct) : 0; } orig_sth->async_status = STH_ASYNC_AUTORETRIEVED; if (TRACE3_slow) { TRC(DBILOGFP, "%sPG_OLDQUERY_WAIT: Auto-retrieved %ld rows for original statement\n", THEADER_slow, orig_sth->rows); } result = NULL; } /* Auto-retrieve error: store for the owning statement */ else if (NULL != async_sth && PGRES_EMPTY_QUERY != status && PGRES_COMMAND_OK != status && PGRES_TUPLES_OK != status) { imp_sth_t *orig_sth = async_sth; if (orig_sth->result) { TRACE_PQCLEAR; PQclear(orig_sth->result); } orig_sth->result = result; orig_sth->rows = -2; /* Error; pg_db_result reports the actual error via pg_error */ orig_sth->async_status = STH_ASYNC_AUTOERROR; if (TRACE3_slow) { TRC(DBILOGFP, "%sPG_OLDQUERY_WAIT: Stored error result for original statement\n", THEADER_slow); } result = NULL; } else { TRACE_PQCLEAR; PQclear(result); } if (status == PGRES_COPY_IN) { /* In theory, this should be caught by copystate, but we'll be careful */ TRACE_PQPUTCOPYEND; if (-1 == PQputCopyEnd(imp_dbh->conn, NULL)) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ handle, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd handle_old_async (error: PQputCopyEnd)\n", THEADER_slow); return -2; } } else if (status == PGRES_COPY_OUT) { /* Won't be as nice with this one */ pg_error(aTHX_ handle, PGRES_FATAL_ERROR, "Must finish copying first"); if (TEND_slow) TRC(DBILOGFP, "%sEnd handle_old_async (error: COPY_OUT status)\n", THEADER_slow); return -2; } else if (status != PGRES_EMPTY_QUERY && status != PGRES_COMMAND_OK && status != PGRES_TUPLES_OK) { /* Only report error to current handle if not PG_OLDQUERY_WAIT */ if (!(asyncflag & PG_OLDQUERY_WAIT)) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ handle, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd handle_old_async (error: bad status)\n", THEADER_slow); return -2; } } } /* If an async prepare has just succeeded, the actual query also needs to be sent & the result dealt with */ if (async_sth && async_sth->async_status == STH_ASYNC_PREPARE && status == PGRES_COMMAND_OK) { ++imp_dbh->prepare_number; ret = pq_send_prepared_query(aTHX_ imp_dbh, async_sth); if (!ret) { TRACE_PQERRORMESSAGE; pg_error(aTHX_ handle, PGRES_FATAL_ERROR, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd handle_old_async (error: PQsendQueryPrepared failed)\n", THEADER_slow); return -2; } async_sth->async_status = STH_ASYNC; goto wait_for_result; } } else { pg_error(aTHX_ handle, PGRES_FATAL_ERROR, "Cannot execute until previous async query has finished"); if (TEND_slow) TRC(DBILOGFP, "%sEnd handle_old_async (error: unfinished)\n", THEADER_slow); return -2; } /* If we made it this far, safe to assume there is no running query */ imp_dbh->async_status = DBH_NO_ASYNC; if (async_sth) { if (STH_ASYNC_AUTORETRIEVED != async_sth->async_status && STH_ASYNC_AUTOERROR != async_sth->async_status) { async_sth->async_status = STH_NO_ASYNC; } imp_dbh->async_sth = NULL; } if (TEND_slow) TRC(DBILOGFP, "%sEnd handle_old_async\n", THEADER_slow); return 0; } /* end of handle_old_async */ /* ================================================================== */ /* Attempt to cancel a synchronous query Returns true if the cancel succeeded, and false if it did not */ int dbd_st_cancel(SV *sth, imp_sth_t *imp_sth) { dTHX; D_imp_dbh_from_sth; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_st_cancel\n", THEADER_slow); if (!do_send_cancel(sth, imp_dbh, "dbd_st_cancel")) return DBDPG_FALSE; if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_cancel\n", THEADER_slow); return DBDPG_TRUE; } /* end of dbd_st_cancel */ /* ================================================================== */ /* Retrieves table oid and column position (in that table) for every column in resultset Returns array of arrays of table oid and column pos or undef if column is not a simple reference */ SV* dbd_st_canonical_ids(SV *sth, imp_sth_t *imp_sth) { dTHX; TRACE_PQNFIELDS; int fields = PQnfields(imp_sth->result); AV* result = newAV(); av_extend(result, fields); while(fields--){ int stored = 0; TRACE_PQFTABLE; Oid oid = PQftable(imp_sth->result, fields); if (oid != InvalidOid){ TRACE_PQFTABLECOL; int pos = PQftablecol(imp_sth->result, fields); if(pos > 0){ AV * row = newAV(); av_extend(row, 2); av_store(row, 0, newSViv(oid)); av_store(row, 1, newSViv(pos)); av_store(result, fields, newRV_noinc((SV *)row)); stored = 1; } } if(!stored){ av_store(result, fields, newSV(0)); } } SV* sv = newRV_noinc((SV*) result); return sv; } /* end of dbd_st_canonical_ids */ /* ================================================================== */ /* Retrieves canonical name (schema.table.column) for every column in resultset Returns array of strings or undef if column is not a simple reference */ SV* dbd_st_canonical_names(SV *sth, imp_sth_t *imp_sth) { dTHX; D_imp_dbh_from_sth; ExecStatusType status; PGresult * result; TRACE_PQNFIELDS; int fields = PQnfields(imp_sth->result); AV* result_av = newAV(); av_extend(result_av, fields); while(fields--){ TRACE_PQFTABLE; Oid oid = PQftable(imp_sth->result, fields); int stored = 0; if(oid != InvalidOid) { TRACE_PQFTABLECOL; int pos = PQftablecol(imp_sth->result, fields); if(pos > 0){ char statement[204]; sprintf(statement, "SELECT n.nspname, c.relname, a.attname FROM pg_class c LEFT JOIN pg_namespace n ON c.relnamespace = n.oid LEFT JOIN pg_attribute a ON a.attrelid = c.oid WHERE c.oid = %u AND a.attnum = %d", oid, pos); TRACE_PQEXEC; result = PQexec(imp_dbh->conn, statement); TRACE_PQRESULTSTATUS; status = PQresultStatus(result); if (PGRES_TUPLES_OK == status) { TRACE_PQNTUPLES; if (PQntuples(result)!=0) { int len = PQgetlength(result, 0, 0) + 1; len += PQgetlength(result, 0, 1) + 1; len += PQgetlength(result, 0, 2); SV* table_name = newSV(len); char *nsp = PQgetvalue(result, 0, 0); char *tbl = PQgetvalue(result, 0, 1); char *col = PQgetvalue(result, 0, 2); sv_setpvf(table_name, "%s.%s.%s", nsp, tbl, col); if (imp_dbh->pg_utf8_flag) SvUTF8_on(table_name); av_store(result_av, fields, table_name); stored = 1; } } TRACE_PQCLEAR; PQclear(result); } } if(!stored){ av_store(result_av, fields, newSV(0)); } } SV* sv = newRV_noinc((SV*) result_av); return sv; } /* end of dbd_st_canonical_names */ /* Some information to keep you sane: typedef enum { PGRES_EMPTY_QUERY = 0, // empty query string was executed 1 PGRES_COMMAND_OK, // a query command that doesn't return anything was executed properly by the backend 2 PGRES_TUPLES_OK, // a query command that returns tuples was executed properly by the backend, PGresult contains the result tuples 3 PGRES_COPY_OUT, // Copy Out data transfer in progress 4 PGRES_COPY_IN, // Copy In data transfer in progress 5 PGRES_BAD_RESPONSE, // an unexpected response was recv'd from the backend 6 PGRES_NONFATAL_ERROR, // notice or warning message 7 PGRES_FATAL_ERROR // query failed } ExecStatusType; */ /* end of dbdimp.c */ DBD-Pg-3.20.2/README.win320000644000175000017500000000450115116315266013014 0ustar greggreg How to get a working DBD::Pg on Windows Warning! This information is outdated. Please ask on the mailing list for help if you encounter any problems. Also see the notes about Strawberry Perl in the README file. 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: dbd-pg@perl.org DBD-Pg-3.20.2/lib/0000755000175000017500000000000015175422003011732 5ustar greggregDBD-Pg-3.20.2/lib/Bundle/0000755000175000017500000000000015175422003013143 5ustar greggregDBD-Pg-3.20.2/lib/Bundle/DBD/0000755000175000017500000000000015175422003013534 5ustar greggregDBD-Pg-3.20.2/lib/Bundle/DBD/Pg.pm0000644000175000017500000000107015175421130014436 0ustar greggreg package Bundle::DBD::Pg; use strict; use warnings; use 5.008001; our $VERSION = '3.20.2'; 1; __END__ =head1 NAME Bundle::DBD::Pg - A bundle to install all DBD::Pg related modules =head1 SYNOPSIS C =head1 CONTENTS DBI DBD::Pg =head1 DESCRIPTION This bundle includes all the modules needed for DBD::Pg (the Perl interface to the Postgres database system). Please feel free to ask for help or report any problems to dbd-pg@perl.org. =cut =head1 AUTHOR Greg Sabino Mullane EFE =cut DBD-Pg-3.20.2/quote.c0000644000175000017500000016764115166170753012520 0ustar greggreg/* Copyright (c) 2003-2026 Greg Sabino Mullane and others: see the Changes file 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" #if defined (_WIN32) && !defined (strncasecmp) int strncasecmp(const char *s1, const char *s2, size_t n) { while(n > 0 && toupper((unsigned char)*s1) == toupper((unsigned char)*s2)) { if(*s1 == '\0') return 0; s1++; s2++; n--; } if(n == 0) return 0; return toupper((unsigned char)*s1) - toupper((unsigned char)*s2); } #endif /* The 'estring' indicates if the server is capable of using the E'' syntax In other words, is it 8.1 or better? It must arrive as 0 or 1 */ char * null_quote(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring) { char *result; New(0, result, len+1, char); strncpy(result,string,len); result[len]='\0'; *retlen = len; return result; } char * quote_string(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring) { char * result; STRLEN oldlen = len; const char * const tmp = string; (*retlen) = 2; while (len > 0 && *string != '\0') { if (*string == '\'') (*retlen)++; else if (*string == '\\') { if (estring == 1) estring = 2; (*retlen)++; } (*retlen)++; string++; len--; } if (estring == 2) (*retlen)++; string = tmp; New(0, result, 1+(*retlen), char); if (estring == 2) *result++ = 'E'; *result++ = '\''; len = oldlen; while (len > 0 && *string != '\0') { if (*string == '\'' || *string == '\\') { *result++ = *string; } *result++ = *string++; len--; } *result++ = '\''; *result = '\0'; return result - (*retlen); } /* Quote a geometric constant. */ /* Note: we only verify correct characters here, not for 100% valid input */ /* Covers: points, lines, lsegs, boxes, polygons */ char * quote_geom(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring) { char * result; const char *tmp; len = 0; /* stops compiler warnings. Remove entirely someday */ tmp = string; (*retlen) = 2; while (*string != '\0') { if (*string != '\t' && *string != ' ' && *string != '(' && *string != ')' && *string != '-' && *string != '+' && *string != '.' && *string != 'e' && *string != 'E' && *string != ',' && (*string < '0' || *string > '9')) croak("Invalid input for geometric type"); (*retlen)++; string++; } string = tmp; New(0, result, 1+(*retlen), char); *result++ = '\''; while (*string != '\0') { *result++ = *string++; } *result++ = '\''; *result = '\0'; return result - (*retlen); } /* Same as quote_geom, but also allows square brackets */ char * quote_path(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring) { char * result; const char * const tmp = string; len = 0; /* stops compiler warnings. Remove entirely someday */ (*retlen) = 2; while (*string != '\0') { if (*string !=9 && *string != 32 && *string != '(' && *string != ')' && *string != '-' && *string != '+' && *string != '.' && *string != 'e' && *string != 'E' && *string != '[' && *string != ']' && *string != ',' && (*string < '0' || *string > '9')) croak("Invalid input for path type"); (*retlen)++; string++; } string = tmp; New(0, result, 1+(*retlen), char); *result++ = '\''; while (*string != '\0') { *result++ = *string++; } *result++ = '\''; *result = '\0'; return result - (*retlen); } /* Same as quote_geom, but also allows less than / greater than signs */ char * quote_circle(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring) { char * result; const char * const tmp = string; len = 0; /* stops compiler warnings. Remove entirely someday */ (*retlen) = 2; while (*string != '\0') { if (*string !=9 && *string != 32 && *string != '(' && *string != ')' && *string != '-' && *string != '+' && *string != '.' && *string != 'e' && *string != 'E' && *string != '<' && *string != '>' && *string != ',' && (*string < '0' || *string > '9')) croak("Invalid input for circle type"); (*retlen)++; string++; } string = tmp; New(0, result, 1+(*retlen), char); *result++ = '\''; while (*string != '\0') { *result++ = *string++; } *result++ = '\''; *result = '\0'; return result - (*retlen); } char * quote_bytea(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring) { char * result; STRLEN oldlen = len; /* For this one, always use the E'' format if we can */ result = (char *)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; if (estring) (*retlen)++; New(0, result, 1+(*retlen), char); if (estring) *result++ = 'E'; *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) sprintf((char *)result, "\\\\%03o", (unsigned char)*string++); result += 5; } else { *result++ = *string++; } len--; } *result++ = '\''; *result = '\0'; return (char *)result - (*retlen); } char * quote_sql_binary(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring) { /* 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(aTHX_ string, len, retlen, estring); } /* Return TRUE, FALSE, or throws an error */ char * quote_bool(pTHX_ const char *value, STRLEN len, STRLEN *retlen, int estring) { char *result; /* Things that are true: t, T, 1, true, TRUE, 0E0, 0 but true */ if ( (1 == len && (0 == strncasecmp(value, "t", 1) || '1' == *value)) || (4 == len && 0 == strncasecmp(value, "true", 4)) || (3 == len && 0 == strncasecmp(value, "0e0", 3)) || (10 == len && 0 == strncasecmp(value, "0 but true", 10)) ) { New(0, result, 5, char); strcpy(result,"TRUE"); *retlen = 4; return result; } /* Things that are false: f, F, 0, false, FALSE, 0, zero-length string */ if ( (1 == len && (0 == strncasecmp(value, "f", 1) || '0' == *value)) || (5 == len && 0 == strncasecmp(value, "false", 5)) || (0 == len) ) { New(0, result, 6, char); strcpy(result,"FALSE"); *retlen = 5; return result; } croak("Invalid boolean value"); } char * quote_int(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring) { char * result; const char *p = string; STRLEN left = len; bool seendigit = DBDPG_FALSE; while (left-- > 0 && *p != '\0') { if (isdigit(*p)) { seendigit = DBDPG_TRUE; p++; continue; } if (!seendigit && (' ' == *p || '+' == *p || '-' == *p)) { p++; continue; } croak("Invalid integer"); } New(0, result, len+1, char); strcpy(result,string); *retlen = len; return result; } char * quote_float(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring) { char * result; /* Empty string is always an error. Here for dumb compilers. */ if (len<1) croak("Invalid float"); result = (char*)string; *retlen = len; /* Allow some standard strings in */ if (0 != strncasecmp(string, "NaN", 4) && 0 != strncasecmp(string, "Infinity", 9) && 0 != strncasecmp(string, "-Infinity", 10)) { while (len > 0 && *string != '\0') { len--; if (isdigit(*string) || '.' == *string || ' ' == *string || '+' == *string || '-' == *string || 'e' == *string || 'E' == *string) { string++; continue; } croak("Invalid float"); } } string = result; New(0, result, 1+(*retlen), char); strcpy(result,string); return result; } char * quote_name(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring) { char * result; const char *ptr; int nquotes = 0; int x; bool safe; if (len < 1) croak("Empty identifier name"); /* We throw double quotes around the whole thing, if: 1. It starts with anything other than [a-z_] OR 2. It has characters other than [a-z_0-9] OR 3. It is a reserved word (e.g. `user`) */ /* 1. It starts with anything other than [a-z_] */ safe = ((string[0] >= 'a' && string[0] <= 'z') || '_' == string[0]); /* 2. It has characters other than [a-z_0-9] (also count number of quotes) */ for (ptr = string; *ptr; ptr++) { char ch = *ptr; if ( (ch < 'a' || ch > 'z') && (ch < '0' || ch > '9') && ch != '_') { safe = DBDPG_FALSE; if (ch == '"') nquotes++; } } /* 3. Is it a reserved word (e.g. `user`) */ if (safe) { if (! is_keyword(string)) { New(0, result, len+1, char); strcpy(result,string); *retlen = len; return result; } } /* Need room for the string, the outer quotes, any inner quotes (which get doubled) and \0 */ *retlen = len + 2 + nquotes; New(0, result, *retlen + 1, char); x=0; result[x++] = '"'; for (ptr = string; *ptr; ptr++) { char ch = *ptr; result[x++] = ch; if (ch == '"') result[x++] = '"'; } result[x++] = '"'; result[x] = '\0'; return result; } void dequote_char(pTHX_ char *string, STRLEN *retlen) { /* TODO: chop_blanks if requested */ *retlen = strlen(string); } void dequote_string(pTHX_ char *string, STRLEN *retlen) { *retlen = strlen(string); } static void _dequote_bytea_escape(char *string, STRLEN *retlen) { char *result; (*retlen) = 0; if (NULL != string) { 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'; } } static int _decode_hex_digit(char digit) { if (digit >= '0' && digit <= '9') return digit - '0'; if (digit >= 'a' && digit <= 'f') return 10 + digit - 'a'; if (digit >= 'A' && digit <= 'F') return 10 + digit - 'A'; return -1; } static void _dequote_bytea_hex(char *string, STRLEN *retlen) { char *result; (*retlen) = 0; if (NULL != string) { result = string; while (*string != '\0') { int digit1, digit2; digit1 = _decode_hex_digit(*string); digit2 = _decode_hex_digit(*(string+1)); if (digit1 >= 0 && digit2 >= 0) { *result++ = 16 * digit1 + digit2; (*retlen)++; } string += 2; } *result = '\0'; } } void dequote_bytea(pTHX_ char *string, STRLEN *retlen) { if (NULL != string) { if ('\\' == *string && 'x' == *(string+1)) _dequote_bytea_hex(string, retlen); else _dequote_bytea_escape(string, retlen); } } /* 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(pTHX_ char *string, STRLEN *retlen) { /* We are going to return a dequote_bytea(), just in case */ warn("Use of SQL_BINARY invalid in dequote()"); dequote_bytea(aTHX_ string, retlen); /* Put dequote_sql_binary function here at some point */ } void dequote_bool(pTHX_ char *string, STRLEN *retlen) { if (NULL != string) { 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(pTHX_ char *string, STRLEN *retlen) { *retlen = strlen(string); } bool is_keyword(const char *string) { int max_keyword_length = 17; int keyword_len; int i; char word[64]; const char *test_str; keyword_len = (int)strlen(string); if (keyword_len > max_keyword_length || keyword_len > 64) { return DBDPG_FALSE; } /* Because of locale issues, we manually downcase A-Z only */ for (i = 0; i < keyword_len; i++) { char ch = string[i]; if (ch >= 'A' && ch <= 'Z') ch += 'a' - 'A'; word[i] = ch; } word[keyword_len] = '\0'; /* Check for each reserved word */ switch (keyword_len) { case 2: if (word[0] < 'n') { if (word[0] < 'd') { if (word[0] < 'b') { if (word[1] < 't') { test_str = "as"; } else { test_str = "at"; } } else { test_str = "by"; } } else if (word[1] < 'o') { if (word[1] < 'n') { test_str = "if"; } else { test_str = "in"; } } else if (word[0] < 'i') { test_str = "do"; } else { test_str = "is"; } } else if (word[1] < 'o') { if (word[1] < 'n') { test_str = "of"; } else { test_str = "on"; } } else if (word[0] < 'o') { test_str = "no"; } else if (word[0] < 't') { test_str = "or"; } else { test_str = "to"; } break; case 3: if (word[0] < 'n') { if (word[0] < 'c') { if (word[1] < 'n') { if (word[0] < 'b') { if (word[1] < 'l') { test_str = "add"; } else { test_str = "all"; } } else { test_str = "bit"; } } else if (word[1] < 's') { if (word[2] < 'y') { test_str = "and"; } else { test_str = "any"; } } else { test_str = "asc"; } } else if (word[0] < 'e') { if (word[0] < 'd') { test_str = "csv"; } else if (word[1] < 'e') { test_str = "day"; } else { test_str = "dec"; } } else if (word[0] < 'i') { if (word[0] < 'f') { test_str = "end"; } else { test_str = "for"; } } else if (word[0] < 'k') { test_str = "int"; } else { test_str = "key"; } } else if (word[0] < 'r') { if (word[0] < 'o') { if (word[2] < 't') { if (word[2] < 'd') { test_str = "nfc"; } else { test_str = "nfd"; } } else if (word[1] < 'o') { test_str = "new"; } else { test_str = "not"; } } else if (word[1] < 'l') { test_str = "off"; } else if (word[1] < 'u') { test_str = "old"; } else { test_str = "out"; } } else if (word[1] < 'm') { if (word[0] < 's') { test_str = "ref"; } else if (word[0] < 'y') { test_str = "set"; } else { test_str = "yes"; } } else if (word[0] < 's') { test_str = "row"; } else if (word[0] < 'x') { test_str = "sql"; } else { test_str = "xml"; } break; case 4: if (word[1] < 'n') { if (word[2] < 'm') { if (word[0] < 'r') { if (word[2] < 'k') { if (word[0] < 'l') { if (word[0] < 'e') { test_str = "char"; } else { test_str = "each"; } } else if (word[0] < 'o') { test_str = "left"; } else { test_str = "oids"; } } else if (word[0] < 'n') { if (word[0] < 'l') { test_str = "call"; } else { test_str = "like"; } } else if (word[3] < 'd') { test_str = "nfkc"; } else { test_str = "nfkd"; } } else if (word[3] < 'p') { if (word[0] < 't') { if (word[3] < 'l') { test_str = "read"; } else { test_str = "real"; } } else if (word[0] < 'w') { test_str = "then"; } else { test_str = "when"; } } else if (word[0] < 'v') { if (word[0] < 't') { test_str = "skip"; } else { test_str = "ties"; } } else if (word[0] < 'y') { test_str = "view"; } else { test_str = "year"; } } else if (word[0] < 'n') { if (word[1] < 'e') { if (word[0] < 'd') { if (word[3] < 't') { test_str = "case"; } else { test_str = "cast"; } } else if (word[0] < 'l') { test_str = "data"; } else { test_str = "last"; } } else if (word[0] < 'e') { if (word[0] < 'd') { test_str = "also"; } else { test_str = "desc"; } } else if (word[0] < 'k') { test_str = "else"; } else { test_str = "keys"; } } else if (word[0] < 't') { if (word[0] < 's') { if (word[1] < 'e') { test_str = "name"; } else { test_str = "next"; } } else if (word[1] < 'h') { test_str = "sets"; } else { test_str = "show"; } } else if (word[1] < 'i') { if (word[2] < 'x') { test_str = "temp"; } else { test_str = "text"; } } else if (word[0] < 'w') { test_str = "time"; } else { test_str = "with"; } } else if (word[0] < 'm') { if (word[0] < 'h') { if (word[0] < 'd') { if (word[2] < 's') { if (word[1] < 'u') { test_str = "copy"; } else { test_str = "cube"; } } else if (word[0] < 'c') { test_str = "both"; } else { test_str = "cost"; } } else if (word[0] < 'f') { if (word[0] < 'e') { test_str = "drop"; } else { test_str = "enum"; } } else if (word[1] < 'u') { test_str = "from"; } else { test_str = "full"; } } else if (word[0] < 'j') { if (word[0] < 'i') { if (word[2] < 'u') { test_str = "hold"; } else { test_str = "hour"; } } else { test_str = "into"; } } else if (word[0] < 'l') { if (word[1] < 's') { test_str = "join"; } else { test_str = "json"; } } else if (word[2] < 'c') { test_str = "load"; } else { test_str = "lock"; } } else if (word[2] < 'm') { if (word[0] < 'r') { if (word[0] < 'o') { if (word[0] < 'n') { test_str = "mode"; } else { test_str = "null"; } } else if (word[1] < 'v') { test_str = "only"; } else { test_str = "over"; } } else if (word[0] < 't') { if (word[1] < 'u') { test_str = "role"; } else { test_str = "rule"; } } else if (word[0] < 'u') { test_str = "trim"; } else { test_str = "user"; } } else if (word[0] < 't') { if (word[0] < 'r') { if (word[0] < 'n') { test_str = "move"; } else { test_str = "none"; } } else if (word[0] < 's') { test_str = "rows"; } else { test_str = "some"; } } else if (word[0] < 'w') { if (word[1] < 'y') { test_str = "true"; } else { test_str = "type"; } } else if (word[0] < 'z') { test_str = "work"; } else { test_str = "zone"; } break; case 5: if (word[0] < 'm') { if (word[1] < 'l') { if (word[0] < 'f') { if (word[0] < 'c') { if (word[1] < 'e') { if (word[1] < 'd') { test_str = "abort"; } else { test_str = "admin"; } } else if (word[0] < 'b') { test_str = "after"; } else { test_str = "begin"; } } else if (word[1] < 'h') { if (word[0] < 'd') { test_str = "cache"; } else { test_str = "depth"; } } else if (word[2] < 'e') { test_str = "chain"; } else { test_str = "check"; } } else if (word[2] < 'r') { if (word[1] < 'e') { if (word[0] < 'l') { test_str = "false"; } else { test_str = "label"; } } else if (word[1] < 'i') { test_str = "least"; } else { test_str = "limit"; } } else if (word[0] < 'l') { if (word[1] < 'i') { test_str = "fetch"; } else { test_str = "first"; } } else if (word[1] < 'e') { test_str = "large"; } else { test_str = "level"; } } else if (word[0] < 'g') { if (word[1] < 'r') { if (word[0] < 'f') { if (word[0] < 'c') { test_str = "alter"; } else if (word[2] < 'o') { test_str = "class"; } else { test_str = "close"; } } else if (word[1] < 'o') { test_str = "float"; } else { test_str = "force"; } } else if (word[1] < 'v') { if (word[0] < 'c') { test_str = "array"; } else { test_str = "cross"; } } else if (word[0] < 'e') { test_str = "cycle"; } else { test_str = "event"; } } else if (word[2] < 'n') { if (word[1] < 'o') { if (word[1] < 'n') { test_str = "ilike"; } else { test_str = "index"; } } else if (word[0] < 'l') { test_str = "grant"; } else { test_str = "local"; } } else if (word[4] < 't') { if (word[0] < 'i') { test_str = "group"; } else { test_str = "inner"; } } else if (word[2] < 'p') { test_str = "inout"; } else { test_str = "input"; } } else if (word[4] < 'n') { if (word[0] < 't') { if (word[0] < 'q') { if (word[1] < 'o') { if (word[1] < 'e') { test_str = "match"; } else { test_str = "merge"; } } else if (word[0] < 'o') { test_str = "month"; } else { test_str = "owned"; } } else if (word[0] < 's') { if (word[0] < 'r') { test_str = "quote"; } else { test_str = "range"; } } else if (word[1] < 'h') { test_str = "setof"; } else if (word[1] < 'y') { test_str = "share"; } else { test_str = "sysid"; } } else if (word[1] < 'm') { if (word[2] < 'l') { if (word[0] < 'w') { test_str = "table"; } else { test_str = "where"; } } else if (word[3] < 'u') { test_str = "valid"; } else { test_str = "value"; } } else if (word[0] < 'w') { if (word[1] < 's') { test_str = "until"; } else { test_str = "using"; } } else if (word[0] < 'x') { test_str = "write"; } else { test_str = "xmlpi"; } } else if (word[0] < 'r') { if (word[2] < 'l') { if (word[0] < 'p') { if (word[0] < 'o') { test_str = "nchar"; } else { test_str = "order"; } } else if (word[1] < 'r') { test_str = "plans"; } else { test_str = "prior"; } } else if (word[0] < 'o') { if (word[1] < 'u') { test_str = "names"; } else { test_str = "nulls"; } } else if (word[1] < 'w') { test_str = "outer"; } else { test_str = "owner"; } } else if (word[0] < 't') { if (word[0] < 's') { if (word[1] < 'i') { test_str = "reset"; } else { test_str = "right"; } } else if (word[2] < 'd') { test_str = "start"; } else if (word[2] < 'r') { test_str = "stdin"; } else { test_str = "strip"; } } else if (word[0] < 'u') { if (word[1] < 'y') { test_str = "treat"; } else { test_str = "types"; } } else if (word[0] < 'v') { test_str = "union"; } else { test_str = "views"; } break; case 6: if (word[1] < 'm') { if (word[0] < 'o') { if (word[3] < 'i') { if (word[0] < 'd') { if (word[1] < 'i') { if (word[1] < 'c') { test_str = "absent"; } else { test_str = "access"; } } else if (word[0] < 'b') { test_str = "always"; } else { test_str = "binary"; } } else if (word[0] < 'g') { if (word[2] < 't') { test_str = "delete"; } else { test_str = "detach"; } } else if (word[0] < 'h') { test_str = "global"; } else if (word[0] < 'm') { test_str = "header"; } else { test_str = "method"; } } else if (word[0] < 'f') { if (word[1] < 'e') { if (word[0] < 'c') { test_str = "action"; } else { test_str = "called"; } } else if (word[1] < 'i') { test_str = "before"; } else { test_str = "bigint"; } } else if (word[0] < 'h') { if (word[1] < 'i') { test_str = "family"; } else { test_str = "filter"; } } else if (word[0] < 'l') { test_str = "having"; } else if (word[0] < 'm') { test_str = "listen"; } else { test_str = "minute"; } } else if (word[2] < 'm') { if (word[2] < 'f') { if (word[0] < 't') { if (word[1] < 'e') { test_str = "scalar"; } else if (word[2] < 'c') { test_str = "search"; } else { test_str = "second"; } } else if (word[0] < 'v') { test_str = "tables"; } else { test_str = "vacuum"; } } else if (word[0] < 's') { if (word[1] < 'f') { test_str = "object"; } else { test_str = "offset"; } } else if (word[0] < 'v') { if (word[1] < 'e') { test_str = "schema"; } else { test_str = "select"; } } else { test_str = "values"; } } else if (word[0] < 's') { if (word[2] < 't') { if (word[0] < 'r') { test_str = "parser"; } else { test_str = "rename"; } } else if (word[2] < 'v') { test_str = "return"; } else { test_str = "revoke"; } } else if (word[0] < 'w') { if (word[1] < 'e') { test_str = "scroll"; } else if (word[1] < 'i') { test_str = "server"; } else { test_str = "simple"; } } else if (word[2] < 't') { test_str = "window"; } else { test_str = "within"; } } else if (word[4] < 'm') { if (word[2] < 'o') { if (word[0] < 'l') { if (word[0] < 'e') { if (word[0] < 'd') { test_str = "commit"; } else { test_str = "domain"; } } else if (word[0] < 'i') { test_str = "enable"; } else { test_str = "isnull"; } } else if (word[0] < 'n') { if (word[2] < 'g') { test_str = "locked"; } else { test_str = "logged"; } } else if (word[0] < 'p') { test_str = "nullif"; } else if (word[0] < 's') { test_str = "policy"; } else { test_str = "stable"; } } else if (word[0] < 'n') { if (word[0] < 'd') { if (word[2] < 't') { test_str = "atomic"; } else { test_str = "attach"; } } else if (word[0] < 'f') { test_str = "double"; } else { test_str = "format"; } } else if (word[0] < 's') { if (word[2] < 'w') { test_str = "notify"; } else { test_str = "nowait"; } } else if (word[1] < 'y') { if (word[2] < 'r') { test_str = "stored"; } else { test_str = "strict"; } } else { test_str = "system"; } } else if (word[1] < 'r') { if (word[0] < 'o') { if (word[2] < 'p') { if (word[0] < 'i') { test_str = "column"; } else if (word[2] < 'l') { test_str = "indent"; } else { test_str = "inline"; } } else if (word[1] < 'n') { test_str = "import"; } else { test_str = "insert"; } } else if (word[0] < 'u') { if (word[0] < 'r') { test_str = "option"; } else { test_str = "rollup"; } } else if (word[1] < 'p') { test_str = "unique"; } else { test_str = "update"; } } else if (word[0] < 'f') { if (word[0] < 'e') { if (word[1] < 'u') { test_str = "create"; } else { test_str = "cursor"; } } else if (word[1] < 'x') { test_str = "escape"; } else if (word[2] < 'i') { test_str = "except"; } else { test_str = "exists"; } } else if (word[0] < 'o') { if (word[0] < 'g') { test_str = "freeze"; } else { test_str = "groups"; } } else if (word[0] < 's') { test_str = "others"; } else { test_str = "stdout"; } break; case 7: if (word[0] < 'n') { if (word[2] < 'o') { if (word[2] < 'e') { if (word[0] < 'e') { if (word[0] < 'd') { if (word[5] < 'z') { test_str = "analyse"; } else { test_str = "analyze"; } } else if (word[3] < 'l') { test_str = "decimal"; } else { test_str = "declare"; } } else if (word[0] < 'i') { if (word[0] < 'g') { test_str = "exclude"; } else { test_str = "granted"; } } else if (word[0] < 'l') { if (word[2] < 'd') { test_str = "include"; } else { test_str = "indexes"; } } else { test_str = "leading"; } } else if (word[0] < 'd') { if (word[2] < 'm') { if (word[0] < 'c') { test_str = "breadth"; } else if (word[3] < 'u') { test_str = "collate"; } else { test_str = "columns"; } } else if (word[2] < 'n') { test_str = "comment"; } else { test_str = "content"; } } else if (word[0] < 'e') { if (word[3] < 'i') { test_str = "default"; } else { test_str = "definer"; } } else if (word[0] < 'h') { test_str = "execute"; } else if (word[0] < 'i') { test_str = "handler"; } else { test_str = "inherit"; } } else if (word[0] < 'e') { if (word[1] < 'i') { if (word[1] < 'e') { if (word[2] < 't') { test_str = "cascade"; } else { test_str = "catalog"; } } else if (word[0] < 'd') { test_str = "between"; } else { test_str = "depends"; } } else if (word[0] < 'd') { if (word[0] < 'c') { test_str = "boolean"; } else if (word[1] < 'u') { test_str = "cluster"; } else { test_str = "current"; } } else if (word[3] < 'c') { test_str = "disable"; } else { test_str = "discard"; } } else if (word[2] < 't') { if (word[0] < 'i') { if (word[0] < 'f') { test_str = "explain"; } else if (word[3] < 'w') { test_str = "foreign"; } else { test_str = "forward"; } } else if (word[0] < 'm') { test_str = "instead"; } else { test_str = "mapping"; } } else if (word[0] < 'l') { if (word[0] < 'i') { test_str = "extract"; } else if (word[2] < 'v') { test_str = "integer"; } else { test_str = "invoker"; } } else if (word[0] < 'm') { test_str = "lateral"; } else { test_str = "matched"; } } else if (word[1] < 'i') { if (word[3] < 'r') { if (word[0] < 's') { if (word[2] < 'l') { if (word[2] < 'i') { test_str = "recheck"; } else { test_str = "reindex"; } } else if (word[2] < 'p') { test_str = "release"; } else if (word[4] < 'i') { test_str = "replace"; } else { test_str = "replica"; } } else if (word[0] < 'v') { if (word[0] < 'u') { test_str = "schemas"; } else { test_str = "uescape"; } } else if (word[1] < 'e') { test_str = "varchar"; } else { test_str = "verbose"; } } else if (word[1] < 'e') { if (word[2] < 's') { if (word[0] < 'v') { test_str = "partial"; } else { test_str = "varying"; } } else if (word[0] < 'p') { test_str = "natural"; } else { test_str = "passing"; } } else if (word[0] < 's') { if (word[2] < 's') { test_str = "refresh"; } else if (word[2] < 't') { test_str = "restart"; } else { test_str = "returns"; } } else if (word[0] < 'v') { test_str = "session"; } else { test_str = "version"; } } else if (word[0] < 'r') { if (word[0] < 'p') { if (word[0] < 'o') { if (word[1] < 'u') { if (word[3] < 'n') { test_str = "nothing"; } else { test_str = "notnull"; } } else { test_str = "numeric"; } } else if (word[1] < 'v') { test_str = "options"; } else { test_str = "overlay"; } } else if (word[2] < 'i') { if (word[1] < 'r') { test_str = "placing"; } else { test_str = "prepare"; } } else if (word[2] < 'o') { test_str = "primary"; } else { test_str = "program"; } } else if (word[1] < 'r') { if (word[0] < 'u') { if (word[0] < 's') { test_str = "routine"; } else { test_str = "similar"; } } else if (word[0] < 'w') { test_str = "unknown"; } else if (word[0] < 'x') { test_str = "without"; } else { test_str = "xmlroot"; } } else if (word[0] < 't') { if (word[1] < 'u') { test_str = "storage"; } else { test_str = "support"; } } else if (word[0] < 'w') { if (word[2] < 'u') { test_str = "trigger"; } else { test_str = "trusted"; } } else { test_str = "wrapper"; } break; case 8: if (word[0] < 'n') { if (word[1] < 'n') { if (word[0] < 'f') { if (word[0] < 'd') { if (word[0] < 'b') { test_str = "absolute"; } else if (word[0] < 'c') { test_str = "backward"; } else { test_str = "cascaded"; } } else if (word[2] < 's') { if (word[3] < 'e') { test_str = "defaults"; } else { test_str = "deferred"; } } else if (word[1] < 'i') { test_str = "database"; } else { test_str = "distinct"; } } else if (word[0] < 'l') { if (word[0] < 'i') { test_str = "finalize"; } else if (word[1] < 'm') { test_str = "identity"; } else { test_str = "implicit"; } } else if (word[0] < 'm') { test_str = "language"; } else if (word[1] < 'i') { test_str = "maxvalue"; } else { test_str = "minvalue"; } } else if (word[0] < 'f') { if (word[0] < 'd') { if (word[2] < 'n') { if (word[2] < 'm') { test_str = "coalesce"; } else { test_str = "comments"; } } else if (word[3] < 't') { test_str = "conflict"; } else { test_str = "continue"; } } else if (word[0] < 'e') { test_str = "document"; } else if (word[1] < 'x') { test_str = "encoding"; } else { test_str = "external"; } } else if (word[0] < 'i') { if (word[0] < 'g') { test_str = "function"; } else if (word[2] < 'o') { test_str = "greatest"; } else { test_str = "grouping"; } } else if (word[0] < 'l') { if (word[2] < 't') { test_str = "inherits"; } else { test_str = "interval"; } } else { test_str = "location"; } } else if (word[0] < 's') { if (word[1] < 'o') { if (word[0] < 'r') { if (word[0] < 'p') { test_str = "national"; } else if (word[2] < 's') { test_str = "parallel"; } else { test_str = "password"; } } else if (word[2] < 'l') { test_str = "reassign"; } else if (word[2] < 's') { test_str = "relative"; } else { test_str = "restrict"; } } else if (word[1] < 'p') { if (word[0] < 'r') { test_str = "position"; } else if (word[2] < 'u') { test_str = "rollback"; } else { test_str = "routines"; } } else if (word[0] < 'p') { if (word[1] < 'v') { test_str = "operator"; } else { test_str = "overlaps"; } } else if (word[3] < 's') { test_str = "prepared"; } else { test_str = "preserve"; } } else if (word[0] < 'u') { if (word[0] < 't') { if (word[1] < 'm') { if (word[2] < 'q') { test_str = "security"; } else { test_str = "sequence"; } } else if (word[1] < 'n') { test_str = "smallint"; } else { test_str = "snapshot"; } } else if (word[1] < 'r') { test_str = "template"; } else if (word[2] < 'u') { test_str = "trailing"; } else { test_str = "truncate"; } } else if (word[1] < 'n') { if (word[0] < 'x') { if (word[2] < 'r') { test_str = "validate"; } else { test_str = "variadic"; } } else if (word[3] < 't') { test_str = "xmlparse"; } else { test_str = "xmltable"; } } else if (word[0] < 'v') { if (word[3] < 'o') { test_str = "unlisten"; } else { test_str = "unlogged"; } } else { test_str = "volatile"; } break; case 9: if (word[4] < 'o') { if (word[0] < 'l') { if (word[0] < 'd') { if (word[0] < 'c') { if (word[1] < 't') { test_str = "aggregate"; } else { test_str = "attribute"; } } else if (word[1] < 'o') { test_str = "character"; } else if (word[2] < 'm') { test_str = "collation"; } else { test_str = "committed"; } } else if (word[2] < 'm') { if (word[0] < 'i') { test_str = "delimiter"; } else if (word[2] < 'i') { test_str = "increment"; } else { test_str = "initially"; } } else if (word[0] < 'i') { test_str = "extension"; } else if (word[1] < 's') { test_str = "immediate"; } else { test_str = "isolation"; } } else if (word[1] < 'r') { if (word[1] < 'e') { if (word[0] < 'v') { if (word[3] < 't') { test_str = "parameter"; } else { test_str = "partition"; } } else { test_str = "validator"; } } else if (word[0] < 'n') { test_str = "localtime"; } else if (word[0] < 's') { test_str = "normalize"; } else { test_str = "sequences"; } } else if (word[0] < 's') { if (word[2] < 'o') { if (word[4] < 'i') { test_str = "preceding"; } else { test_str = "precision"; } } else { test_str = "procedure"; } } else if (word[1] < 'y') { test_str = "statement"; } else { test_str = "symmetric"; } } else if (word[0] < 'r') { if (word[0] < 'g') { if (word[1] < 'u') { if (word[0] < 'e') { test_str = "assertion"; } else if (word[0] < 'f') { test_str = "encrypted"; } else { test_str = "following"; } } else if (word[0] < 'f') { if (word[5] < 's') { test_str = "excluding"; } else { test_str = "exclusive"; } } else { test_str = "functions"; } } else if (word[1] < 'm') { if (word[0] < 'l') { test_str = "generated"; } else { test_str = "leakproof"; } } else if (word[1] < 'n') { test_str = "immutable"; } else if (word[2] < 't') { test_str = "including"; } else { test_str = "intersect"; } } else if (word[1] < 'm') { if (word[0] < 's') { if (word[2] < 't') { test_str = "recursive"; } else { test_str = "returning"; } } else if (word[0] < 't') { test_str = "savepoint"; } else if (word[1] < 'i') { test_str = "temporary"; } else { test_str = "timestamp"; } } else if (word[0] < 'x') { if (word[0] < 't') { test_str = "substring"; } else if (word[0] < 'u') { test_str = "transform"; } else { test_str = "unbounded"; } } else if (word[3] < 'e') { test_str = "xmlconcat"; } else if (word[3] < 'f') { test_str = "xmlexists"; } else { test_str = "xmlforest"; } break; case 10: if (word[0] < 'n') { if (word[0] < 'd') { if (word[0] < 'c') { if (word[2] < 's') { test_str = "asensitive"; } else if (word[2] < 'y') { test_str = "assignment"; } else { test_str = "asymmetric"; } } else if (word[3] < 's') { if (word[1] < 'o') { test_str = "checkpoint"; } else { test_str = "connection"; } } else if (word[3] < 'v') { test_str = "constraint"; } else { test_str = "conversion"; } } else if (word[1] < 'i') { if (word[2] < 'f') { test_str = "deallocate"; } else if (word[2] < 'l') { test_str = "deferrable"; } else { test_str = "delimiters"; } } else if (word[0] < 'e') { test_str = "dictionary"; } else if (word[0] < 'j') { test_str = "expression"; } else { test_str = "json_array"; } } else if (word[0] < 'r') { if (word[0] < 'p') { if (word[0] < 'o') { test_str = "normalized"; } else if (word[1] < 'v') { test_str = "ordinality"; } else { test_str = "overriding"; } } else if (word[2] < 'o') { test_str = "privileges"; } else if (word[8] < 'e') { test_str = "procedural"; } else { test_str = "procedures"; } } else if (word[0] < 't') { if (word[0] < 's') { if (word[2] < 'p') { test_str = "references"; } else { test_str = "repeatable"; } } else if (word[3] < 't') { test_str = "standalone"; } else { test_str = "statistics"; } } else if (word[0] < 'w') { test_str = "tablespace"; } else if (word[0] < 'x') { test_str = "whitespace"; } else { test_str = "xmlelement"; } break; case 11: if (word[0] < 'r') { if (word[0] < 'j') { if (word[0] < 'i') { if (word[2] < 'n') { test_str = "compression"; } else { test_str = "constraints"; } } else { test_str = "insensitive"; } } else if (word[0] < 'p') { if (word[5] < 's') { test_str = "json_object"; } else { test_str = "json_scalar"; } } else { test_str = "publication"; } } else if (word[2] < 'e') { if (word[0] < 'u') { if (word[1] < 'r') { test_str = "tablesample"; } else { test_str = "transaction"; } } else { test_str = "uncommitted"; } } else if (word[0] < 's') { test_str = "referencing"; } else if (word[0] < 'u') { test_str = "system_user"; } else { test_str = "unencrypted"; } break; case 12: if (word[0] < 'm') { if (word[8] < 'r') { if (word[1] < 'u') { test_str = "concurrently"; } else { test_str = "current_date"; } } else if (word[8] < 't') { test_str = "current_role"; } else if (word[8] < 'u') { test_str = "current_time"; } else { test_str = "current_user"; } } else if (word[1] < 'm') { if (word[0] < 's') { test_str = "materialized"; } else if (word[2] < 's') { test_str = "serializable"; } else { test_str = "session_user"; } } else if (word[0] < 'x') { test_str = "subscription"; } else { test_str = "xmlserialize"; } break; case 13: if (word[0] < 'j') { if (word[0] < 'c') { test_str = "authorization"; } else { test_str = "configuration"; } } else if (word[0] < 'x') { test_str = "json_arrayagg"; } else if (word[3] < 'n') { test_str = "xmlattributes"; } else { test_str = "xmlnamespaces"; } break; case 14: if (word[4] < 'e') { if (word[5] < 's') { test_str = "json_objectagg"; } else { test_str = "json_serialize"; } } else if (word[0] < 'l') { test_str = "current_schema"; } else { test_str = "localtimestamp"; } break; case 15: if (word[1] < 'u') { test_str = "characteristics"; } else { test_str = "current_catalog"; } break; case 17: test_str = "current_timestamp"; break; default: return DBDPG_FALSE; } if (0 == strcmp(word, test_str)) return DBDPG_TRUE; /* We made it! */ return DBDPG_FALSE; } /* end of quote.c */ /* #!perl ## Autogenerate the list of reserved keywords ## 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; 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/parser/kwlist.h"; open my $fh, '<', $file or die qq{Could not open file "$file": $!\n}; my @word; my $maxlen = 10; while (<$fh>) { next unless /^PG_KEYWORD\("(.+?)"/; ## We don't care what type of word it is - when in doubt, quote it! my $word = $1; push @word => $word; $maxlen = length $word if length $word > $maxlen; } close $fh or die qq{Could not close "$file": $!\n}; my $tempfile = 'quote.c.tmp'; open my $fh2, '>', $tempfile or die qq{Could not open "$tempfile": $!\n}; seek(DATA,0,0); my $gotlist = 0; while () { s/(int max_keyword_length =) \d+/$1 $maxlen/; if (!$gotlist) { if (/Check for each reserved word/) { $gotlist = 1; print $fh2 $_; print $fh2 generate_binary_search(\@word); print $fh2 "\n"; next; } } elsif (1==$gotlist) { if (/We made it/) { $gotlist = 2; } else { next; } } print $fh2 $_; } close $fh2 or die qq{Could not close "$tempfile": $!\n}; my $ofile = 'quote.c'; rename($tempfile, $ofile); print "Wrote $ofile\n"; my $testfile= "t/01keywords.t"; open my $fh3, '<', $testfile or die "open($testfile): $!"; my @lines = <$fh3>; my ($start, $end); for (0..$#lines) { $start = $_ if $lines[$_] =~ /BEGIN GENERATED KEYWORDS/; $end = $_ if $lines[$_] =~ /END GENERATED KEYWORDS/; } if ($start && $end) { splice(@lines, $start+1, $end-$start-1, map " '$_',\n", @word); } else { die "Can't find keyword comment markers in $testfile"; } open my $fh4, '>', "$testfile.tmp" or die "open($testfile.tmp): $!"; print $fh4 @lines; close $fh4 or die "close: $!"; rename("$testfile.tmp", $testfile); print "Wrote $testfile\n"; exit; sub generate_binary_search { my $words = shift; my $code = " switch (keyword_len) {\n"; my %len_map; for (@$words) { push @{$len_map{length $_}}, $_; } sub _binary_split { my $vals = shift; # Stop at length 1 return qq{test_str = "$vals->[0]";} if @$vals == 1; # Find a character comparison that splits the list roughly in half. my ($best_i, $best_ch, $best_less); my $goal = .5 * scalar @$vals; for (my $i = 0; $i < length $vals->[0]; ++$i) { my %seen; for my $ch (grep !$seen{$_}++, map substr($_, $i, 1), @$vals) { my @less= grep substr($_, $i, 1) lt $ch, @$vals; ($best_i, $best_ch, $best_less) = ($i, $ch, \@less) if !defined $best_i || abs($goal - @less) < abs($goal - @$best_less); } } my %less = map +($_ => 1), @$best_less; my @less_src = _binary_split($best_less); my @ge_src = _binary_split([ grep !$less{$_}, @$vals ]); if (@ge_src > 1) { # combine "else { if" $ge_src[0] = '} else '.$ge_src[0]; } return ( "if (word[$best_i] < '$best_ch') {", (map " $_", @less_src), (@ge_src > 1 ? @ge_src : ( '} else {', (map " $_", @ge_src), '}' ) ) ); } for (sort { $a <=> $b } keys %len_map) { my @split_expr = _binary_split($len_map{$_}); local $" = "\n "; $code .= <<~C; case $_: @split_expr break; C } $code .= <<~C; default: return DBDPG_FALSE; } if (0 == strcmp(word, test_str)) return DBDPG_TRUE; C return $code; } __END__ */ DBD-Pg-3.20.2/Pg.pm0000644000175000017500000060060715175421036012106 0ustar greggreg# -*-cperl-*- # # Copyright (c) 2002-2026 Greg Sabino Mullane and others: see the Changes file # Portions Copyright (c) 2002 Jeffrey W. Baker # Portions Copyright (c) 1997-2001 Edmund Mergl # Portions Copyright (c) 1994-1997 Tim Bunce # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use 5.008001; { package DBD::Pg; use version; our $VERSION = qv('3.20.2'); use DBI 1.614 (); use Exporter (); use XSLoader; our @ISA = qw(Exporter); use constant { PG_MIN_SMALLINT => -32768, PG_MAX_SMALLINT => 32767, PG_MIN_INTEGER => -2147483648, PG_MAX_INTEGER => 2147483647, PG_MIN_BIGINT => '-9223372036854775808', PG_MAX_BIGINT => '9223372036854775807', PG_MIN_SMALLSERIAL => 1, PG_MAX_SMALLSERIAL => 32767, PG_MIN_SERIAL => 1, PG_MAX_SERIAL => 2147483647, PG_MIN_BIGSERIAL => 1, PG_MAX_BIGSERIAL => '9223372036854775807', }; our %EXPORT_TAGS = ( async => [qw($DBDPG_DEFAULT PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT)], pg_limits => [qw($DBDPG_DEFAULT PG_MIN_SMALLINT PG_MAX_SMALLINT PG_MIN_INTEGER PG_MAX_INTEGER PG_MAX_BIGINT PG_MIN_BIGINT PG_MIN_SMALLSERIAL PG_MAX_SMALLSERIAL PG_MIN_SERIAL PG_MAX_SERIAL PG_MIN_BIGSERIAL PG_MAX_BIGSERIAL)], pg_types => [qw($DBDPG_DEFAULT PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT PG_ACLITEM PG_ACLITEMARRAY PG_ANY PG_ANYARRAY PG_ANYCOMPATIBLE PG_ANYCOMPATIBLEARRAY PG_ANYCOMPATIBLEMULTIRANGE PG_ANYCOMPATIBLENONARRAY PG_ANYCOMPATIBLERANGE PG_ANYELEMENT PG_ANYENUM PG_ANYMULTIRANGE PG_ANYNONARRAY PG_ANYRANGE PG_BIT PG_BITARRAY PG_BOOL PG_BOOLARRAY PG_BOX PG_BOXARRAY PG_BPCHAR PG_BPCHARARRAY PG_BYTEA PG_BYTEAARRAY PG_CHAR PG_CHARARRAY PG_CID PG_CIDARRAY PG_CIDR PG_CIDRARRAY PG_CIRCLE PG_CIRCLEARRAY PG_CSTRING PG_CSTRINGARRAY PG_DATE PG_DATEARRAY PG_DATEMULTIRANGE PG_DATEMULTIRANGEARRAY PG_DATERANGE PG_DATERANGEARRAY PG_EVENT_TRIGGER PG_FDW_HANDLER PG_FLOAT4 PG_FLOAT4ARRAY PG_FLOAT8 PG_FLOAT8ARRAY PG_GTSVECTOR PG_GTSVECTORARRAY PG_INDEX_AM_HANDLER PG_INET PG_INETARRAY PG_INT2 PG_INT2ARRAY PG_INT2VECTOR PG_INT2VECTORARRAY PG_INT4 PG_INT4ARRAY PG_INT4MULTIRANGE PG_INT4MULTIRANGEARRAY PG_INT4RANGE PG_INT4RANGEARRAY PG_INT8 PG_INT8ARRAY PG_INT8MULTIRANGE PG_INT8MULTIRANGEARRAY PG_INT8RANGE PG_INT8RANGEARRAY PG_INTERNAL PG_INTERVAL PG_INTERVALARRAY PG_JSON PG_JSONARRAY PG_JSONB PG_JSONBARRAY PG_JSONPATH PG_JSONPATHARRAY PG_LANGUAGE_HANDLER PG_LINE PG_LINEARRAY PG_LSEG PG_LSEGARRAY PG_MACADDR PG_MACADDR8 PG_MACADDR8ARRAY PG_MACADDRARRAY PG_MONEY PG_MONEYARRAY PG_NAME PG_NAMEARRAY PG_NUMERIC PG_NUMERICARRAY PG_NUMMULTIRANGE PG_NUMMULTIRANGEARRAY PG_NUMRANGE PG_NUMRANGEARRAY PG_OID PG_OID8 PG_OID8ARRAY PG_OIDARRAY PG_OIDVECTOR PG_OIDVECTORARRAY PG_PATH PG_PATHARRAY PG_PG_ATTRIBUTE PG_PG_ATTRIBUTEARRAY PG_PG_BRIN_BLOOM_SUMMARY PG_PG_BRIN_MINMAX_MULTI_SUMMARY PG_PG_CLASS PG_PG_CLASSARRAY PG_PG_DDL_COMMAND PG_PG_DEPENDENCIES PG_PG_LSN PG_PG_LSNARRAY PG_PG_MCV_LIST PG_PG_NDISTINCT PG_PG_NODE_TREE PG_PG_PROC PG_PG_PROCARRAY PG_PG_SNAPSHOT PG_PG_SNAPSHOTARRAY PG_PG_TYPE PG_PG_TYPEARRAY PG_POINT PG_POINTARRAY PG_POLYGON PG_POLYGONARRAY PG_RECORD PG_RECORDARRAY PG_REFCURSOR PG_REFCURSORARRAY PG_REGCLASS PG_REGCLASSARRAY PG_REGCOLLATION PG_REGCOLLATIONARRAY PG_REGCONFIG PG_REGCONFIGARRAY PG_REGDATABASE PG_REGDATABASEARRAY PG_REGDICTIONARY PG_REGDICTIONARYARRAY PG_REGNAMESPACE PG_REGNAMESPACEARRAY PG_REGOPER PG_REGOPERARRAY PG_REGOPERATOR PG_REGOPERATORARRAY PG_REGPROC PG_REGPROCARRAY PG_REGPROCEDURE PG_REGPROCEDUREARRAY PG_REGROLE PG_REGROLEARRAY PG_REGTYPE PG_REGTYPEARRAY PG_TABLE_AM_HANDLER PG_TEXT PG_TEXTARRAY PG_TID PG_TIDARRAY PG_TIME PG_TIMEARRAY PG_TIMESTAMP PG_TIMESTAMPARRAY PG_TIMESTAMPTZ PG_TIMESTAMPTZARRAY PG_TIMETZ PG_TIMETZARRAY PG_TRIGGER PG_TSMULTIRANGE PG_TSMULTIRANGEARRAY PG_TSM_HANDLER PG_TSQUERY PG_TSQUERYARRAY PG_TSRANGE PG_TSRANGEARRAY PG_TSTZMULTIRANGE PG_TSTZMULTIRANGEARRAY PG_TSTZRANGE PG_TSTZRANGEARRAY PG_TSVECTOR PG_TSVECTORARRAY PG_TXID_SNAPSHOT PG_TXID_SNAPSHOTARRAY PG_UNKNOWN PG_UUID PG_UUIDARRAY PG_VARBIT PG_VARBITARRAY PG_VARCHAR PG_VARCHARARRAY PG_VOID PG_XID PG_XID8 PG_XID8ARRAY PG_XIDARRAY PG_XML PG_XMLARRAY )], ); { package DBD::Pg::DefaultValue; sub new { my $class = shift; return bless {}, $class; } } our $DBDPG_DEFAULT = DBD::Pg::DefaultValue->new(); Exporter::export_ok_tags('pg_types', 'async', 'pg_limits'); our @EXPORT = qw($DBDPG_DEFAULT PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT PG_BYTEA); XSLoader::load(__PACKAGE__, $VERSION); our $err = 0; # holds error code for DBI::err our $errstr = ''; # holds error string for DBI::errstr our $sqlstate = ''; # holds five character SQLSTATE code our $drh = undef; # holds driver handle once initialized ## These two methods are here to allow calling before connect() sub parse_trace_flag { my ($class, $flag) = @_; return (0x7FFFFF00 - 0x08000000) if $flag eq 'DBD'; ## all but the prefix return 0x01000000 if $flag eq 'pglibpq'; return 0x02000000 if $flag eq 'pgstart'; return 0x04000000 if $flag eq 'pgend'; return 0x08000000 if $flag eq 'pgprefix'; return 0x10000000 if $flag eq 'pglogin'; return 0x20000000 if $flag eq 'pgquote'; return DBI::parse_trace_flag($class, $flag); } sub parse_trace_flags { my ($class, $flags) = @_; return DBI::parse_trace_flags($class, $flags); } ## Both CLONE and driver are required by DBI, see perldoc DBI::DBD sub CLONE { $drh = undef; return; } my $methods_are_installed = 0; sub driver { return $drh if defined $drh; my $class = shift; $class .= '::dr'; ## Work around for issue found in https://rt.cpan.org/Ticket/Display.html?id=83057 my $realversion = qv('3.20.2'); $drh = DBI::_new_drh($class, { 'Name' => 'Pg', 'Version' => $realversion, 'Err' => \$DBD::Pg::err, 'Errstr' => \$DBD::Pg::errstr, 'State' => \$DBD::Pg::sqlstate, 'Attribution' => "DBD::Pg $realversion by Greg Sabino Mullane and others", }); # uncoverable branch false if (!$methods_are_installed) { DBD::Pg::db->install_method('pg_cancel'); DBD::Pg::db->install_method('pg_continue_connect'); DBD::Pg::db->install_method('pg_endcopy'); DBD::Pg::db->install_method('pg_error_field'); DBD::Pg::db->install_method('pg_getline'); DBD::Pg::db->install_method('pg_getcopydata'); DBD::Pg::db->install_method('pg_getcopydata_async'); DBD::Pg::db->install_method('pg_notifies'); DBD::Pg::db->install_method('pg_putcopydata'); DBD::Pg::db->install_method('pg_putcopyend'); DBD::Pg::db->install_method('pg_ping'); DBD::Pg::db->install_method('pg_putline'); DBD::Pg::db->install_method('pg_ready'); DBD::Pg::db->install_method('pg_release'); DBD::Pg::db->install_method('pg_result'); ## NOT duplicated below! DBD::Pg::db->install_method('pg_rollback_to'); DBD::Pg::db->install_method('pg_savepoint'); DBD::Pg::db->install_method('pg_send_cancel'); DBD::Pg::db->install_method('pg_server_trace'); DBD::Pg::db->install_method('pg_server_untrace'); DBD::Pg::db->install_method('pg_type_info'); DBD::Pg::st->install_method('pg_cancel'); DBD::Pg::st->install_method('pg_result'); DBD::Pg::st->install_method('pg_ready'); DBD::Pg::st->install_method('pg_canonical_ids'); DBD::Pg::st->install_method('pg_canonical_names'); DBD::Pg::db->install_method('pg_lo_creat'); DBD::Pg::db->install_method('pg_lo_open'); DBD::Pg::db->install_method('pg_lo_write'); DBD::Pg::db->install_method('pg_lo_read'); DBD::Pg::db->install_method('pg_lo_lseek'); DBD::Pg::db->install_method('pg_lo_lseek64'); DBD::Pg::db->install_method('pg_lo_tell'); DBD::Pg::db->install_method('pg_lo_tell64'); DBD::Pg::db->install_method('pg_lo_truncate'); DBD::Pg::db->install_method('pg_lo_truncate64'); DBD::Pg::db->install_method('pg_lo_close'); DBD::Pg::db->install_method('pg_lo_unlink'); DBD::Pg::db->install_method('pg_lo_import'); DBD::Pg::db->install_method('pg_lo_import_with_oid'); DBD::Pg::db->install_method('pg_lo_export'); $methods_are_installed = 1; } return $drh; } ## end of driver 1; } ## end of package DBD::Pg { package DBD::Pg::dr; use strict; ## Returns an array of formatted database names from the pg_database table sub data_sources { my $drh = shift; my $extra_conninfo = shift || ''; $extra_conninfo =~ s/^([^;])/;$1/; my $connstring = 'dbname=postgres'; if ($ENV{DBI_DSN}) { ($connstring = $ENV{DBI_DSN}) =~ s/dbi:Pg://i; } my $dbh = DBD::Pg::dr::connect($drh, $connstring) or die 'Could not connect to the database'; my @sources; eval { my $SQL = 'SELECT pg_catalog.quote_ident(datname) FROM pg_catalog.pg_database ORDER BY 1'; my $sth = $dbh->prepare($SQL) or die $dbh->errstr; $sth->execute() or die $sth->errstr; @sources = map { "dbi:Pg:dbname=$_->[0]$extra_conninfo" } @{$sth->fetchall_arrayref()}; }; my $error = $@; $dbh->disconnect; die $error if $error; return @sources; } sub connect { ## no critic (ProhibitBuiltinHomonyms) my ($drh, $dsn, $user, $pass, $attr) = @_; ## Allow "db" and "database" as synonyms for "dbname" $dsn =~ s/\b(?:db|database)\s*=/dbname=/; ## If the database name is wrapped in double quotes, change to single quotes $dsn =~ s/dbname\s*=\s*"(.+?)"/dbname='$1'/; ## No other escaping needed here: docs indicate this is a client job: #e.g. C. $user = defined($user) ? $user : defined $ENV{DBI_USER} ? $ENV{DBI_USER} : ''; $pass = defined($pass) ? $pass : defined $ENV{DBI_PASS} ? $ENV{DBI_PASS} : ''; my ($dbh) = DBI::_new_dbh($drh, { 'Name' => $dsn, 'Username' => $user, 'CURRENT_USER' => $user, }); DBD::Pg::db::_login($dbh, $dsn, $user, $pass, $attr) or return; $dbh->{private_dbdpg}{version} = $dbh->{pg_server_version}; if ($attr and $attr->{dbd_verbose}) { $dbh->trace('DBD'); } return $dbh; } sub private_attribute_info { return {}; } } ## end of package DBD::Pg::dr { package DBD::Pg::db; use DBI qw(:sql_types); use strict; sub parse_trace_flag { return DBD::Pg->parse_trace_flag($_[1]); } sub prepare { my($dbh, $statement, @attribs) = @_; return undef if ! defined $statement; # Create a 'blank' statement handle: my $sth = DBI::_new_sth($dbh, { 'Statement' => $statement, }); DBD::Pg::st::_prepare($sth, $statement, @attribs) or return; return $sth; } sub last_insert_id { my ($dbh, undef, $schema, $table, undef, $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 (arguments 2 and 5) are not used $schema = '' if ! defined $schema; $table = '' if ! defined $table; my $cachename = join("\0", 'lii', $schema, $table); if (defined $attr and length $attr) { ## If not a hash, assume it is a sequence name if (! ref $attr) { $attr = {sequence => $attr}; } elsif (ref $attr ne 'HASH') { $dbh->set_err(1, 'last_insert_id must be passed a hashref as the final argument'); return undef; } ## Named sequence overrides any table or schema settings if (exists $attr->{sequence} and length $attr->{sequence}) { $sequence = $attr->{sequence}; } if (exists $attr->{pg_cache}) { $cache = $attr->{pg_cache}; } } if (! defined $sequence and exists $dbh->{private_dbdpg}{$cachename} and $cache) { $sequence = $dbh->{private_dbdpg}{$cachename}; } elsif (! defined $sequence) { ## At this point, we must have a valid table name if (! length $table) { $dbh->set_err(1, 'last_insert_id needs at least a sequence or table name'); return undef; } my @args = ($table); my $schemawhere; if (length $schema) { # if given a schema, use that $schemawhere = 'n.nspname = ?'; push @args, $schema; } else { # otherwise it must be visible via the search path $schemawhere = 'pg_catalog.pg_table_is_visible(c.oid)'; } ## Is there a sequence associated with the table via a unique, indexed column, ## either via ownership (e.g. serial, identity) or a manual default? my $idcond = $dbh->{private_dbdpg}{version} >= 100000 ? q{a.attidentity <> ''} : q{false}; $SQL = sprintf(q{ SELECT i.indisprimary, COALESCE( -- this takes the table name as text, not regclass pg_catalog.pg_get_serial_sequence( -- and pre-8.3 doesn't have a cast from regclass to text, -- and pre-9.3 doesn't have format, so do it the long way quote_ident(n.nspname) || '.' || quote_ident(c.relname), a.attname), (SELECT replace(substring(pg_catalog.pg_get_expr(d.adbin, d.adrelid) from $r$^nextval\('(.+)'::[\w\s]+\)$$r$), -- unescape any single quotes from the default $$''$$, $$'$$) FROM pg_catalog.pg_attrdef d WHERE a.atthasdef AND a.attrelid = d.adrelid AND a.attnum = d.adnum) ) AS seqname FROM pg_class c JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace) -- LEFT JOIN so we can distinguish between table not found (zero rows) -- and no suitable column found (at least one all-NULL row) LEFT JOIN pg_catalog.pg_index i ON c.oid = i.indrelid AND i.indisunique LEFT JOIN pg_catalog.pg_attribute a ON i.indrelid = a.attrelid AND i.indkey[0]=a.attnum AND (a.atthasdef OR %s) WHERE c.relname = ? AND %s }, $idcond, $schemawhere); $sth = $dbh->prepare_cached($SQL); $count = $sth->execute(@args); if (!defined $count or $count eq '0E0') { $sth->finish(); my $message = qq{Could not find the table "$table"}; length $schema and $message .= qq{ in the schema "$schema"}; $dbh->set_err(1, $message); return undef; } my $info = $sth->fetchall_arrayref(); ## We have at least one with a default value. See if we found any sequences my @def = grep { defined $_->[1] } @$info; if (!@def) { ## This may be an inherited table, in which case we can use the parent's info $SQL = 'SELECT inhparent::regclass FROM pg_inherits WHERE inhrelid = ?::regclass::oid'; my $isth = $dbh->prepare($SQL); $count = $isth->execute($table); if (!defined $count or $count eq '0E0') { $isth->finish(); $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n}); return undef; } my $parent = $isth->fetch->[0]; $args[0] = $parent; $count = $sth->execute(@args); if (1 == $count) { $info = $sth->fetchall_arrayref(); @def = grep { defined $_->[1] } @$info; } if (!@def) { $sth->finish(); $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n}); return undef; } ## Fall through with inherited information } ## Tiebreaker goes to the primary keys if (@def > 1) { my @pri = grep { $_->[0] } @def; if (1 != @pri) { $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n}); return undef; } @def = @pri; } $sequence = $def[0]->[1]; ## Cache this information for subsequent calls $dbh->{private_dbdpg}{$cachename} = $sequence; } $sth = $dbh->prepare_cached('SELECT pg_catalog.currval(?)'); $count = $sth->execute($sequence); return undef if ! defined $count; return $sth->fetchall_arrayref()->[0][0]; } ## end of last_insert_id sub ping { my $dbh = shift; local $SIG{__WARN__} = sub {} if $dbh->FETCH('PrintError'); my $ret = DBD::Pg::db::_ping($dbh); return $ret < 1 ? 0 : $ret; } sub pg_ping { my $dbh = shift; local $SIG{__WARN__} = sub {} if $dbh->FETCH('PrintError'); return DBD::Pg::db::_ping($dbh); } sub pg_type_info { my($dbh,$pg_type) = @_; return DBD::Pg::db::_pg_type_info($pg_type); } sub column_info { # Columns expected in statement handle returned (Per DBI, must be in order): # 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. my ($dbh, $catalog, $schema, $table, $column) = @_; my (@search, @args); ## If the schema or table has an underscore or a %, use a LIKE comparison if (defined $schema and length $schema) { push @search, 'n.nspname ' . ($schema =~ /[_%]/ ? 'LIKE ?' : '= ?'); push @args, $schema; } if (defined $table and length $table) { push @search, 'c.relname ' . ($table =~ /[_%]/ ? 'LIKE ?' : '= ?'); push @args, $table; } if (defined $column and length $column) { push @search, 'a.attname ' . ($column =~ /[_%]/ ? 'LIKE ?' : '= ?'); push @args, $column; } my $whereclause = @search ? (' AND ' . join ' AND ', @search) : ''; ## Note: we do not need to check attisdropped because attypid will be 0 ## for dropped columns and thus fail to join to pg_type my $col_info_sql = <<"EOSQL"; SELECT pg_catalog.quote_ident(pg_catalog.current_database()) AS "TABLE_CAT", pg_catalog.quote_ident(n.nspname) AS "TABLE_SCHEM", pg_catalog.quote_ident(c.relname) AS "TABLE_NAME", pg_catalog.quote_ident(a.attname) AS "COLUMN_NAME", a.atttypid AS "DATA_TYPE", pg_catalog.format_type(a.atttypid, NULL) AS "TYPE_NAME", a.attlen AS "COLUMN_SIZE", NULL::text AS "BUFFER_LENGTH", NULL::text AS "DECIMAL_DIGITS", NULL::text AS "NUM_PREC_RADIX", CASE WHEN a.attnotnull THEN 0 ELSE 1 END AS "NULLABLE", pg_catalog.col_description(a.attrelid, a.attnum) AS "REMARKS", pg_catalog.pg_get_expr(af.adbin, af.adrelid) 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 WHEN a.attnotnull THEN 'NO' ELSE 'YES' END AS "IS_NULLABLE", pg_catalog.format_type(a.atttypid, a.atttypmod) AS "pg_type", NULL::text AS "pg_constraint", pg_catalog.current_database() AS "pg_database", n.nspname AS "pg_schema", c.relname AS "pg_table", a.attname AS "pg_column", NULL::text[] AS "pg_enum_values", a.attrelid AS "_pg_attrelid", a.attnum AS "_pg_attnum", a.atttypmod AS "_pg_atttypmod", t.typtype AS "_pg_type_typtype", t.oid AS "_pg_type_oid" FROM pg_catalog.pg_type t JOIN pg_catalog.pg_attribute a ON (t.oid = a.atttypid) JOIN pg_catalog.pg_class c ON (a.attrelid = c.oid) JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace) LEFT JOIN pg_catalog.pg_attrdef af ON (a.attnum = af.adnum AND a.attrelid = af.adrelid) WHERE a.attnum >= 1 AND c.relkind IN ('r','p','v','m','f')$whereclause ORDER BY n.nspname, c.relname, a.attnum EOSQL local $dbh->{FetchHashKeyName} = 'NAME'; my $sth = $dbh->prepare($col_info_sql); $sth->execute(@args) or die $sth->errstr; ## Immediately grab all the column names in order, but exclude internal ones my @colnames = grep { ! /^_pg/ } @{ $sth->{NAME} }; my $data = $sth->fetchall_arrayref({}); if (!@$data) { return _prepare_from_data('column_info', [], \@colnames); } ## Grab any constraints that match the columns we are looking at my %colconstraint; ## Also grab the list of possible enums for any relevant columns my %enuminfo; ## We cast conkey to text because we cannot control if pg_expand_array is set my $csql = q{SELECT conrelid, conkey::text, pg_catalog.pg_get_constraintdef(oid) }. q{FROM pg_catalog.pg_constraint WHERE contype = 'c' AND conrelid = ANY(?)}; my $csth = $dbh->prepare($csql); my @relidlist = do { my %seen; grep { !$seen{$_}++ } map { $_->{_pg_attrelid} } @$data; }; $csth->execute(\@relidlist) or die $csth->errstr; for my $row (@{ $csth->fetchall_arrayref() }) { for my $attnum ($row->[1] =~ /(\d+)/g) { push @{ $colconstraint{$row->[0]}{$attnum}}, $row->[2]; } } my @typelist = do { my %seen; grep { !$seen{$_}++ } map { $_->{_pg_type_oid} } grep { $_->{_pg_type_typtype} eq 'e' } @$data; }; if (@typelist) { ## Postgres version 9.1 added the pg_enum.enumsortorder column my $order = $dbh->{private_dbdpg}{version} >= 90100 ? 'enumsortorder' : 'oid'; my $esql = "SELECT enumtypid, enumlabel FROM pg_catalog.pg_enum WHERE enumtypid = ANY(?) ORDER BY enumtypid, $order"; my $esth = $dbh->prepare($esql); $esth->execute(\@typelist) or die $esth->errstr; for my $row (@{ $esth->fetchall_arrayref() }) { push @{$enuminfo{$row->[0]}}, $row->[1]; } } ## Final transformations for my $row (@$data) { ## Decode attribute mod and length into friendlier forms my $attlen = $row->{COLUMN_SIZE}; if ($attlen <= 0) { my $mod = $row->{_pg_atttypmod} - 4; if ($mod < 0) { $row->{COLUMN_SIZE} = undef; } elsif ($mod <= 0xffff) { $row->{COLUMN_SIZE} = $mod; } else { $row->{COLUMN_SIZE} = $mod >> 16; $row->{DECIMAL_DIGITS} = $mod & 0xffff; } } # Replace the Pg type with the SQL_ type $row->{DATA_TYPE} = DBD::Pg::db::pg_type_info($dbh, $row->{DATA_TYPE}); # Add pg_constraint information my $aid = $row->{_pg_attrelid}; if (exists $colconstraint{ $aid }{ $row->{_pg_attnum} }) { $row->{pg_constraint} = join "\n", @{ $colconstraint{ $aid }{ $row->{_pg_attnum} }}; } else { $row->{pg_constraint} = undef; } ## Add enum information as an arrayref of allowed values $row->{pg_enum_values} = $enuminfo{ $row->{_pg_type_oid} }; } ## Use DBD::Sponge to turn this into a statement handle return _prepare_from_data( 'column_info', [ map { [ @{$_}{@colnames} ] } @$data ], \@colnames ); } sub _prepare_from_data { my ($statement, $data, $names, %attrinfo) = @_; my $sponge = DBI->connect('dbi:Sponge:', '', '', { RaiseError => 1 }); my $sth = $sponge->prepare($statement, { rows => $data, NAME => $names, %attrinfo }); return $sth; } sub statistics_info { ## Gather statistics about a table and its columns ## See https://metacpan.org/pod/DBI#statistics_info my ($dbh, $catalog, $schema, $table, $unique_only, $quick) = @_; ## Catalog is ignored, schema is optional, and table is mandatory return undef if ! defined $table or $table eq ''; my $schema_where = ''; my @exe_args = ($table); if (defined $schema and $schema ne '') { $schema_where = 'AND n.nspname = ?'; push @exe_args, $schema; } my $stats_sql = ''; # Table-level stats if (!$unique_only) { ## DBI requires NULL in most fields if the type is 'table' $stats_sql = <<"EOSQL"; SELECT pg_catalog.current_database() AS "TABLE_CAT", n.nspname AS "TABLE_SCHEM", c.relname AS "TABLE_NAME", NULL AS "NON_UNIQUE", NULL AS "INDEX_QUALIFIER", NULL AS "INDEX_NAME", 'table' AS "TYPE", NULL AS "ORDINAL_POSITION", NULL AS "COLUMN_NAME", NULL AS "ASC_OR_DESC", c.reltuples AS "CARDINALITY", c.relpages AS "PAGES", NULL AS "FILTER_CONDITION", NULL AS "pg_expression", NULL AS "pg_is_key_column", NULL AS "pg_null_ordering" FROM pg_catalog.pg_class c JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace WHERE c.relname = ? $schema_where UNION ALL EOSQL push @exe_args, $table; push @exe_args, $schema if $schema_where; } my $pgversion = $dbh->{private_dbdpg}{version}; ## Postgres version 11 added the pg_index.indnkeyatts column, ## which tells the number of non-included columns in the index my $is_key_column = $pgversion >= 110000 ? 'col.i <= i.indnkeyatts' : 'true'; my ($asc_or_desc, $null_ordering); ## Postgres version 9.6 added pg_index_column_has_property(), ## which can tell if the index sorts ascending or descending, ## and if it sorts nulls first or nulls last if ($pgversion >= 90600) { $asc_or_desc = <<'EOSQL'; CASE WHEN pg_catalog.pg_index_column_has_property(c.oid, col.i, 'asc') THEN 'A' WHEN pg_catalog.pg_index_column_has_property(c.oid, col.i, 'desc') THEN 'D' ELSE NULL END EOSQL $null_ordering = <<'EOSQL'; CASE WHEN pg_catalog.pg_index_column_has_property(c.oid, col.i, 'nulls_first') THEN 'first' WHEN pg_catalog.pg_index_column_has_property(c.oid, col.i, 'nulls_last') THEN 'last' ELSE NULL END EOSQL } ## Postgres version 8.3 added the pg_am.amcanorder column, ## which tells if ordering is supported elsif ($pgversion >= 80300) { $asc_or_desc = <<'EOSQL'; CASE WHEN a.amcanorder THEN CASE WHEN i.indoption[col.i - 1] & 1 = 0 THEN 'A' ELSE 'D' END END EOSQL $null_ordering = <<'EOSQL'; CASE WHEN a.amcanorder THEN CASE WHEN i.indoption[col.i - 1] & 2 = 0 THEN 'last' ELSE 'first' END END EOSQL } ## Postgres version 8.2 and older is simply ordered or not else { $asc_or_desc = q{CASE WHEN a.amorderstrategy <> 0 THEN 'A' ELSE NULL END}; $null_ordering = q{CASE WHEN a.amorderstrategy <> 0 THEN 'last' ELSE NULL END}; } my $unique_where = $unique_only ? 'AND i.indisunique' : ''; ## Grab column-level statistics $stats_sql .= <<"EOSQL"; SELECT pg_catalog.current_database() AS "TABLE_CAT", n.nspname AS "TABLE_SCHEM", d.relname AS "TABLE_NAME", CASE WHEN i.indisunique THEN 0 ELSE 1 END AS "NON_UNIQUE", NULL AS "INDEX_QUALIFIER", c.relname AS "INDEX_NAME", CASE WHEN a.amname = 'btree' THEN 'btree' WHEN a.amname = 'hash' THEN 'hashed' ELSE 'other' END AS "TYPE", col.i AS "ORDINAL_POSITION", att.attname AS "COLUMN_NAME", $asc_or_desc AS "ASC_OR_DESC", c.reltuples AS "CARDINALITY", c.relpages AS "PAGES", pg_catalog.pg_get_expr(i.indpred,i.indrelid) AS "FILTER_CONDITION", pg_catalog.pg_get_indexdef(i.indexrelid, col.i, true) AS "pg_expression", $is_key_column AS "pg_is_key_column", $null_ordering AS "pg_null_ordering" FROM pg_catalog.pg_index i JOIN pg_catalog.pg_class c ON c.oid = i.indexrelid JOIN pg_catalog.pg_class d ON d.oid = i.indrelid JOIN pg_catalog.pg_am a ON a.oid = c.relam JOIN pg_catalog.pg_namespace n ON n.oid = d.relnamespace JOIN pg_catalog.generate_series(1, pg_catalog.current_setting('max_index_keys')::integer) col(i) ON col.i <= i.indnatts LEFT JOIN pg_catalog.pg_attribute att ON att.attrelid = d.oid AND att.attnum = i.indkey[col.i - 1] WHERE d.relname = ? $schema_where $unique_where ORDER BY "NON_UNIQUE", "TYPE", "INDEX_QUALIFIER", "INDEX_NAME", "ORDINAL_POSITION" EOSQL local $dbh->{FetchHashKeyName} = 'NAME'; my $sth = $dbh->prepare($stats_sql); $sth->execute(@exe_args) or die $sth->errstr; return $sth; } sub primary_key_info { ## Return a statement handle with info on the columns of a primary key ## See https://metacpan.org/pod/DBI#primary_key_info my ($dbh, $catalog, $schema, $table, $attr) = @_; my @cols = (qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME DATA_TYPE pg_tablespace_name pg_tablespace_location pg_schema pg_table pg_column ) ); ## If no table is given, we return an empty list if (! defined $table || ! length $table) { return _prepare_from_data('primary_key_info', [], \@cols); } my $schema_where = ''; my @exe_args = ($table); if (defined $schema && $schema ne '') { $schema_where = 'AND n.nspname = ?'; push @exe_args, $schema; } my $pri_key_sql = <<"EOSQL"; SELECT pg_catalog.quote_ident(pg_catalog.current_database()) AS "TABLE_CAT", pg_catalog.quote_ident(n.nspname) AS "TABLE_SCHEM", pg_catalog.quote_ident(c.relname) AS "TABLE_NAME", NULL AS "COLUMN_NAME", NULL AS "KEY_SEQ", pg_catalog.quote_ident(c2.relname) AS "PK_NAME", NULL AS "DATA_TYPE", pg_catalog.quote_ident(t.spcname) AS pg_tablespace_name, pg_catalog.quote_ident(pg_catalog.pg_tablespace_location(t.oid)) AS pg_tablespace_location, n.nspname AS pg_schema, c.relname AS pg_table, NULL AS pg_column, c.oid AS "_pg_reloid", i.indkey AS "_pg_indkey" FROM pg_catalog.pg_class c JOIN pg_catalog.pg_index i ON (i.indrelid = c.oid) JOIN pg_catalog.pg_class c2 ON (c2.oid = i.indexrelid) LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace) LEFT JOIN pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace) WHERE i.indisprimary IS TRUE AND c.relname = ? $schema_where EOSQL ## Postgres version 9.2 added the pg_tablespace_location() function if ($dbh->{private_dbdpg}{version} < 90200) { $pri_key_sql =~ s/\Qpg_catalog.pg_tablespace_location(t.oid)/t.spclocation/; } local $dbh->{FetchHashKeyName} = 'NAME'; my $sth = $dbh->prepare($pri_key_sql); $sth->execute(@exe_args) or die $sth->errstr; my $info = $sth->fetchall_arrayref({})->[0]; if (! defined $info) { return _prepare_from_data('primary_key_info', [], \@cols); } ## Map pg_index.indkey to name/type for each column my @index_cols = grep { /\d+/ } split /\s+/, delete $info->{_pg_indkey}; my $index_cols = join ', ', @index_cols; my $sql = <<"EOSQL"; SELECT a.attnum, pg_catalog.quote_ident(a.attname) AS colname, a.attname AS raw_colname, pg_catalog.quote_ident(t.typname) AS typename FROM pg_catalog.pg_attribute a JOIN pg_catalog.pg_type t ON (t.oid = a.atttypid) WHERE a.attrelid = ? AND attnum IN ($index_cols); EOSQL $sth = $dbh->prepare($sql); $sth->execute(delete $info->{_pg_reloid}) or die $sth->errstr; my $attribinfo = $sth->fetchall_hashref('attnum'); my $pkinfo = []; ## Normal way: complete "row" per column in the primary key if (! defined $attr || ! $attr->{'pg_onerow'}) { for my $colnum (@index_cols) { push @$pkinfo, [ $info->{TABLE_CAT}, $info->{TABLE_SCHEM}, $info->{TABLE_NAME}, $attribinfo->{$colnum}{colname}, ## COLUMN_NAME $colnum, ## KEY_SEQ $info->{PK_NAME}, $attribinfo->{$colnum}{typename}, ## DATA_TYPE $info->{pg_tablespace_name}, $info->{pg_tablespace_location}, $info->{pg_schema}, $info->{pg_table}, $attribinfo->{$colnum}{raw_colname}, ## pg_column ]; } } else { ## Nicer way if pg_onerow is set $info->{COLUMN_NAME} = 2==$attr->{'pg_onerow'} ? [ map { $attribinfo->{$_}{colname} } @index_cols ] : join ', ', map { $attribinfo->{$_}{colname} } @index_cols; $info->{DATA_TYPE} = 2==$attr->{'pg_onerow'} ? [ map { $attribinfo->{$_}{typename} } @index_cols ] : join ', ', map { $attribinfo->{$_}{typename} } @index_cols; $info->{KEY_SEQ} = 2==$attr->{'pg_onerow'} ? [@index_cols] : $index_cols; $info->{pg_column} = 2==$attr->{'pg_onerow'} ? [ map { $attribinfo->{$_}{raw_colname} } @index_cols ] : join ', ', map { $attribinfo->{$_}{raw_colname} } @index_cols; $pkinfo = [[map { $info->{$_} } @cols]]; } return _prepare_from_data('primary_key_info', $pkinfo, \@cols); } ## end of primary_key_info sub primary_key { ## Simple interface to the primary_key_info() method. ## See https://metacpan.org/pod/DBI#primary_key my ($dbh, $catalog, $schema, $table) = @_; my $sth = $dbh->primary_key_info($catalog, $schema, $table, {pg_onerow => 2}); my $result = $sth->fetchall_arrayref(); return defined $result->[0] ? @{$result->[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 @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 )); if ($dbh->{FetchHashKeyName} eq 'NAME_lc') { for my $col (@cols) { $col = lc $col; } } ## Must have at least one named table if (!length($ptable) and !length($ftable)) { return _prepare_from_data('foreign_key_info', [], \@cols); } ## 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. ## If no schema is given, respect search_path by using pg_table_is_visible() my @where; for ([$ptable, $pschema, 'uk'], [$ftable, $fschema, 'fk']) { my ($table, $schema, $type) = @$_; if (length $table) { push @where, "${type}_class.relname = " . $dbh->quote($table); if (length $schema) { push @where, "${type}_ns.nspname = " . $dbh->quote($schema); } else { push @where, "pg_catalog.pg_table_is_visible(${type}_class.oid)" } } } my $WHERE = join ' AND ', @where; my $SQL = qq{ SELECT pg_catalog.quote_ident(pg_catalog.current_database()), pg_catalog.quote_ident(uk_ns.nspname), pg_catalog.quote_ident(uk_class.relname), pg_catalog.quote_ident(uk_col.attname), pg_catalog.quote_ident(pg_catalog.current_database()), pg_catalog.quote_ident(fk_ns.nspname), pg_catalog.quote_ident(fk_class.relname), pg_catalog.quote_ident(fk_col.attname), colnum.i, CASE constr.confupdtype WHEN 'c' THEN 0 WHEN 'r' THEN 1 WHEN 'n' THEN 2 WHEN 'a' THEN 3 WHEN 'd' THEN 4 ELSE -1 END, CASE constr.confdeltype WHEN 'c' THEN 0 WHEN 'r' THEN 1 WHEN 'n' THEN 2 WHEN 'a' THEN 3 WHEN 'd' THEN 4 ELSE -1 END, pg_catalog.quote_ident(constr.conname), pg_catalog.quote_ident(uk_constr.conname), CASE WHEN constr.condeferrable = 'f' THEN 7 WHEN constr.condeferred = 't' THEN 6 WHEN constr.condeferred = 'f' THEN 5 ELSE -1 END, CASE coalesce(uk_constr.contype, 'u') WHEN 'u' THEN 'UNIQUE' WHEN 'p' THEN 'PRIMARY' END, pg_catalog.quote_ident(uk_type.typname), pg_catalog.quote_ident(fk_type.typname) FROM pg_catalog.pg_constraint constr JOIN pg_catalog.pg_class uk_class ON constr.confrelid = uk_class.oid JOIN pg_catalog.pg_namespace uk_ns ON uk_class.relnamespace = uk_ns.oid JOIN pg_catalog.pg_class fk_class ON constr.conrelid = fk_class.oid JOIN pg_catalog.pg_namespace fk_ns ON fk_class.relnamespace = fk_ns.oid -- can't do unnest() until 8.4, and would need WITH ORDINALITY to get the array indices, -- which isn't available until 9.4 at the earliest, so we join against a series table instead JOIN pg_catalog.generate_series(1, pg_catalog.current_setting('max_index_keys')::integer) colnum(i) ON colnum.i <= pg_catalog.array_upper(constr.conkey,1) JOIN pg_catalog.pg_attribute uk_col ON uk_col.attrelid = constr.confrelid AND uk_col.attnum = constr.confkey[colnum.i] JOIN pg_catalog.pg_type uk_type ON uk_col.atttypid = uk_type.oid JOIN pg_catalog.pg_attribute fk_col ON fk_col.attrelid = constr.conrelid AND fk_col.attnum = constr.conkey[colnum.i] JOIN pg_catalog.pg_type fk_type ON fk_col.atttypid = fk_type.oid -- We can't match confkey from the fk constraint to conkey of the unique constraint, -- because the unique constraint might not exist or there might be more than one -- matching one. However, there must be at least a unique _index_ on the key -- columns, so we look for that; but we can't find it via pg_index, since there may -- again be more than one matching index. -- So instead, we look at pg_depend for the dependency that was created by the fk -- constraint. This dependency is of type 'n' (normal) and ties the pg_constraint -- row oid to the pg_class oid for the index relation (a single arbitrary one if -- more than one matching unique index existed at the time the constraint was -- created). Fortunately, the constraint does not create dependencies on the -- referenced table itself, but on the _columns_ of the referenced table, so the -- index can be distinguished easily. Then we look for another pg_depend entry, -- this time an 'i' (implementation) dependency from a pg_constraint oid (the unique -- constraint if one exists) to the index oid; but we have to allow for the -- possibility that this one doesn't exist. - Andrew Gierth (RhodiumToad) JOIN pg_catalog.pg_depend dep ON ( dep.classid = 'pg_catalog.pg_constraint'::regclass AND dep.objid = constr.oid AND dep.objsubid = 0 AND dep.deptype = 'n' AND dep.refclassid = 'pg_catalog.pg_class'::regclass AND dep.refobjsubid=0 ) JOIN pg_catalog.pg_class idx ON ( idx.oid = dep.refobjid AND idx.relkind='i' ) LEFT JOIN pg_catalog.pg_depend dep2 ON ( dep2.classid = 'pg_catalog.pg_class'::regclass AND dep2.objid = idx.oid AND dep2.objsubid = 0 AND dep2.deptype = 'i' AND dep2.refclassid = 'pg_catalog.pg_constraint'::regclass AND dep2.refobjsubid = 0 ) LEFT JOIN pg_catalog.pg_constraint uk_constr ON ( uk_constr.oid = dep2.refobjid AND uk_constr.contype IN ('p','u') ) WHERE $WHERE AND uk_class.relkind ~ 'r|p' AND fk_class.relkind ~ 'r|p' AND constr.contype = 'f' ORDER BY constr.conname, colnum.i }; my $fkinfo = $dbh->selectall_arrayref($SQL); return _prepare_from_data('foreign_key_info', $fkinfo, \@cols); } ## end of foreign_key_info sub table_info { my $dbh = shift; my ($catalog, $schema, $table, $type) = @_; my $tbl_sql = ''; my $extracols = q{,NULL::text AS pg_schema, NULL::text AS pg_table}; if ( # Rule 19a (defined $catalog and $catalog eq '%') and (defined $schema and $schema eq '') and (defined $table and $table eq '') ) { $tbl_sql = qq{ SELECT pg_catalog.quote_ident(pg_catalog.current_database()) AS "TABLE_CAT" , NULL::text AS "TABLE_SCHEM" , NULL::text AS "TABLE_NAME" , NULL::text AS "TABLE_TYPE" , NULL::text AS "REMARKS" $extracols }; } elsif (# Rule 19b (defined $catalog and $catalog eq '') and (defined $schema and $schema eq '%') and (defined $table and $table eq '') ) { $extracols = q{,n.nspname AS pg_schema, NULL::text AS pg_table}; $tbl_sql = qq{SELECT NULL::text AS "TABLE_CAT" , pg_catalog.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_catalog.pg_get_userbyid(n.nspowner) END AS "REMARKS" $extracols FROM pg_catalog.pg_namespace n ORDER BY "TABLE_SCHEM" }; } elsif (# Rule 19c (defined $catalog and $catalog eq '') and (defined $schema and $schema eq '') and (defined $table and $table eq '') and (defined $type and $type eq '%') ) { $tbl_sql = q{ SELECT "TABLE_CAT" , "TABLE_SCHEM" , "TABLE_NAME" , "TABLE_TYPE" , "REMARKS" FROM (SELECT NULL::text AS "TABLE_CAT" , NULL::text AS "TABLE_SCHEM" , NULL::text AS "TABLE_NAME") dummy_cols CROSS JOIN (SELECT 'TABLE' AS "TABLE_TYPE" , 'relkind ~ r|p' AS "REMARKS" UNION SELECT 'SYSTEM TABLE' , 'relkind ~ r|p; nspname ~ ^pg_(catalog|toast)$' UNION SELECT 'VIEW' , 'relkind: v' UNION SELECT 'SYSTEM VIEW' , 'relkind: v; nspname ~ ^pg_(catalog|toast)$' UNION SELECT 'MATERIALIZED VIEW' , 'relkind: m' UNION SELECT 'SYSTEM MATERIALIZED VIEW' , 'relkind: m; nspname ~ ^pg_(catalog|toast)$' UNION SELECT 'FOREIGN TABLE' , 'relkind: f' UNION SELECT 'SYSTEM FOREIGN TABLE' , 'relkind: f; nspname ~ ^pg_(catalog|toast)$' UNION SELECT 'LOCAL TEMPORARY' , 'relkind ~ r|p; nspname ~ ^pg_(toast_)?temp') type_info ORDER BY "TABLE_TYPE" ASC }; } else { # Default SQL $extracols = q{,n.nspname AS pg_schema, c.relname AS pg_table}; my @search = (q|c.relkind IN ('r', 'p', 'v', 'm', 'f')|, # No sequences, etc. for now q|NOT (pg_catalog.quote_ident(n.nspname) ~ '^pg_(toast_)?temp_' AND NOT pg_catalog.has_schema_privilege(n.nspname, 'USAGE'))|); # No others' temp objects my $showtablespace = sprintf q{pg_catalog.quote_ident(%s) AS "pg_tablespace_location"}, $dbh->{private_dbdpg}{version} < 90200 ? 't.spclocation' : 'pg_catalog.pg_tablespace_location(t.oid)'; ## If the schema or table has an underscore or a %, use a LIKE comparison if (defined $schema and length $schema) { push @search, 'n.nspname ' . ($schema =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($schema); } if (defined $table and length $table) { push @search, 'c.relname ' . ($table =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($table); } my $whereclause = join "\n\t\t\t\t\t AND " => @search; $tbl_sql = qq{ SELECT pg_catalog.quote_ident(pg_catalog.current_database()) AS "TABLE_CAT" , pg_catalog.quote_ident(n.nspname) AS "TABLE_SCHEM" , pg_catalog.quote_ident(c.relname) AS "TABLE_NAME" -- any temp table or temp view is LOCAL TEMPORARY for us , CASE WHEN pg_catalog.quote_ident(n.nspname) ~ '^pg_(toast_)?temp_' THEN 'LOCAL TEMPORARY' WHEN c.relkind ~ 'r|p' THEN CASE WHEN pg_catalog.quote_ident(n.nspname) ~ '^pg_' THEN 'SYSTEM TABLE' ELSE 'TABLE' END WHEN c.relkind = 'v' THEN CASE WHEN pg_catalog.quote_ident(n.nspname) ~ '^pg_' THEN 'SYSTEM VIEW' ELSE 'VIEW' END WHEN c.relkind = 'm' THEN CASE WHEN pg_catalog.quote_ident(n.nspname) ~ '^pg_' THEN 'SYSTEM MATERIALIZED VIEW' ELSE 'MATERIALIZED VIEW' END WHEN c.relkind = 'f' THEN CASE WHEN pg_catalog.quote_ident(n.nspname) ~ '^pg_' THEN 'SYSTEM FOREIGN TABLE' ELSE 'FOREIGN TABLE' END ELSE 'UNKNOWN' END AS "TABLE_TYPE" , d.description AS "REMARKS" , pg_catalog.quote_ident(t.spcname) AS "pg_tablespace_name" , $showtablespace $extracols FROM pg_catalog.pg_class AS c LEFT JOIN pg_catalog.pg_description AS d ON (c.oid = d.objoid AND c.tableoid = d.classoid AND d.objsubid = 0) LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace) LEFT JOIN pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace) WHERE $whereclause ORDER BY "TABLE_TYPE", "TABLE_CAT", "TABLE_SCHEM", "TABLE_NAME" }; if (defined($type) and length($type) and $type ne '%') { my $type_restrict = join ', ' => map { /^'/ ? $_ : $dbh->quote($_) } grep {length} split(',', $type); ## no critic $tbl_sql = qq{SELECT * FROM ($tbl_sql) ti WHERE "TABLE_TYPE" IN ($type_restrict)}; } } local $dbh->{FetchHashKeyName} = 'NAME'; my $sth = $dbh->prepare($tbl_sql); $sth->execute(); return $sth; } sub tables { my ($dbh, @args) = @_; my $attr = $args[4]; my $sth = $dbh->table_info(@args); my $tablelist = $sth->fetchall_arrayref(); my @tables = map { (! (ref $attr eq 'HASH' and $attr->{pg_noprefix})) ? "$_->[1].$_->[2]" : $_->[2] } @$tablelist; 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); my @pri_keys = $dbh->primary_key( undef, undef, $table ); 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); $row->{PRIMARY_KEY} = scalar(grep { /^\Q$row->{NAME}\E$/i } @pri_keys) ? 1 : 0; } return $attrs; } sub type_info_all { my $names = { TYPE_NAME => 0, DATA_TYPE => 1, COLUMN_SIZE => 2, LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE => 9, FIXED_PREC_SCALE => 10, AUTO_UNIQUE_VALUE => 11, LOCAL_TYPE_NAME => 12, MINIMUM_SCALE => 13, MAXIMUM_SCALE => 14, SQL_DATA_TYPE => 15, SQL_DATETIME_SUB => 16, NUM_PREC_RADIX => 17, INTERVAL_PRECISION => 18, }; ## This list is derived from dbi_sql.h in DBI, from types.c and types.h, and from the PG docs ## Aids to make the list more readable: my $GIG = 1073741824; my $PS = 'precision/scale'; my $LEN = 'length'; my $UN; my $ti = [ $names, # name sql_type size pfx/sfx crt n/c/s +-/P/I local min max sub rdx itvl ['unknown', SQL_UNKNOWN_TYPE, 0, $UN,$UN, $UN, 1,0,0, $UN,0,0, 'UNKNOWN', $UN,$UN, SQL_UNKNOWN_TYPE, $UN, $UN, $UN ], ['bytea', SQL_VARBINARY, $GIG, q{'},q{'}, $UN, 1,0,3, $UN,0,0, 'BYTEA', $UN,$UN, SQL_VARBINARY, $UN, $UN, $UN ], ['bpchar', SQL_CHAR, $GIG, q{'},q{'}, $LEN, 1,1,3, $UN,0,0, 'CHARACTER', $UN,$UN, SQL_CHAR, $UN, $UN, $UN ], ['numeric', SQL_DECIMAL, 1000, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,1000, SQL_DECIMAL, $UN, $UN, $UN ], ['numeric', SQL_NUMERIC, 1000, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,1000, SQL_NUMERIC, $UN, $UN, $UN ], ['int4', SQL_INTEGER, 10, $UN,$UN, $UN, 1,0,2, 0,0,0, 'INTEGER', 0,0, SQL_INTEGER, $UN, $UN, $UN ], ['int2', SQL_SMALLINT, 5, $UN,$UN, $UN, 1,0,2, 0,0,0, 'SMALLINT', 0,0, SQL_SMALLINT, $UN, $UN, $UN ], ['float4', SQL_FLOAT, 6, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,6, SQL_FLOAT, $UN, $UN, $UN ], ['float8', SQL_REAL, 15, $UN,$UN, $PS, 1,0,2, 0,0,0, 'REAL', 0,15, SQL_REAL, $UN, $UN, $UN ], ['int8', SQL_BIGINT, 20, $UN,$UN, $UN, 1,0,2, 0,0,0, 'INT8', 0,0, SQL_BIGINT, $UN, $UN, $UN ], ['date', SQL_DATE, 10, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'DATE', 0,0, SQL_DATE, $UN, $UN, $UN ], ['tinterval',SQL_TIME, 18, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TINTERVAL', 0,6, SQL_TIME, $UN, $UN, $UN ], ['timestamp',SQL_TIMESTAMP, 29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMP', 0,6, SQL_TIMESTAMP, $UN, $UN, $UN ], ['text', SQL_LONGVARCHAR, $GIG, q{'},q{'}, $LEN, 1,1,3, $UN,0,0, 'TEXT', $UN,$UN, SQL_LONGVARCHAR, $UN, $UN, $UN ], ['bool', SQL_BOOLEAN, 1, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'BOOLEAN', $UN,$UN, SQL_BOOLEAN, $UN, $UN, $UN ], ['array', SQL_ARRAY, 1, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'ARRAY', $UN,$UN, SQL_ARRAY, $UN, $UN, $UN ], ['date', SQL_TYPE_DATE, 10, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'DATE', 0,0, SQL_TYPE_DATE, $UN, $UN, $UN ], ['time', SQL_TYPE_TIME, 18, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIME', 0,6, SQL_TYPE_TIME, $UN, $UN, $UN ], ['timestamp',SQL_TYPE_TIMESTAMP,29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMP', 0,6, SQL_TYPE_TIMESTAMP, $UN, $UN, $UN ], ['timetz', SQL_TYPE_TIME_WITH_TIMEZONE, 29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMETZ', 0,6, SQL_TYPE_TIME_WITH_TIMEZONE, $UN, $UN, $UN ], ['timestamptz',SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, 29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMPTZ',0,6, SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, $UN, $UN, $UN ], # # intentionally omitted: char, all geometric types, internal types ]; return $ti; } my %get_info_type = ( ## Driver information: 116 => ['SQL_ACTIVE_ENVIRONMENTS', 0 ], ## unlimited 10021 => ['SQL_ASYNC_MODE', 2 ], ## SQL_AM_STATEMENT 120 => ['SQL_BATCH_ROW_COUNT', 2 ], ## SQL_BRC_EXPLICIT 121 => ['SQL_BATCH_SUPPORT', 3 ], ## 12 SELECT_PROC + ROW_COUNT_PROC 2 => ['SQL_DATA_SOURCE_NAME', sub { sprintf 'dbi:Pg:%s', shift->{Name} } ], 3 => ['SQL_DRIVER_HDBC', 0 ], ## not applicable 135 => ['SQL_DRIVER_HDESC', 0 ], ## not applicable 4 => ['SQL_DRIVER_HENV', 0 ], ## not applicable 76 => ['SQL_DRIVER_HLIB', 0 ], ## not applicable 5 => ['SQL_DRIVER_HSTMT', 0 ], ## not applicable ## Not clear what should go here. Some things suggest 'Pg', others 'Pg.pm'. We'll use DBD::Pg for now 6 => ['SQL_DRIVER_NAME', 'DBD::Pg' ], 77 => ['SQL_DRIVER_ODBC_VERSION', '03.00' ], 7 => ['SQL_DRIVER_VER', 'DBDVERSION' ], ## magic word 144 => ['SQL_DYNAMIC_CURSOR_ATTRIBUTES1', 0 ], ## we can FETCH, but not via methods 145 => ['SQL_DYNAMIC_CURSOR_ATTRIBUTES2', 0 ], ## same as above 84 => ['SQL_FILE_USAGE', 0 ], ## SQL_FILE_NOT_SUPPORTED (this is good) 146 => ['SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1', 519 ], ## not clear what this refers to in DBD context 147 => ['SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2', 5209 ], ## see above 81 => ['SQL_GETDATA_EXTENSIONS', 15 ], ## 1+2+4+8 149 => ['SQL_INFO_SCHEMA_VIEWS', 3932149 ], ## not: assert, charset, collat, trans 150 => ['SQL_KEYSET_CURSOR_ATTRIBUTES1', 0 ], ## applies to us? 151 => ['SQL_KEYSET_CURSOR_ATTRIBUTES2', 0 ], ## see above 10022 => ['SQL_MAX_ASYNC_CONCURRENT_STATEMENTS', 0 ], ## unlimited, probably 0 => ['SQL_MAX_DRIVER_CONNECTIONS', \'SHOW max_connections' ], 152 => ['SQL_ODBC_INTERFACE_CONFORMANCE', 1 ], ## SQL_OIC_LEVEL_1 10 => ['SQL_ODBC_VER', '03.00.0000' ], 153 => ['SQL_PARAM_ARRAY_ROW_COUNTS', 2 ], ## correct? 154 => ['SQL_PARAM_ARRAY_SELECTS', 3 ], ## PAS_NO_SELECT 11 => ['SQL_ROW_UPDATES', 'N' ], 14 => ['SQL_SEARCH_PATTERN_ESCAPE', '\\' ], 13 => ['SQL_SERVER_NAME', \'SELECT pg_catalog.current_database()' ], 166 => ['SQL_STANDARD_CLI_CONFORMANCE', 2 ], ## ?? 167 => ['SQL_STATIC_CURSOR_ATTRIBUTES1', 519 ], ## ?? 168 => ['SQL_STATIC_CURSOR_ATTRIBUTES2', 5209 ], ## ?? 9000 => ['9000', 1 ], ## can escape placeholders ## DBMS Information 16 => ['SQL_DATABASE_NAME', \'SELECT pg_catalog.current_database()' ], 17 => ['SQL_DBMS_NAME', 'PostgreSQL' ], 18 => ['SQL_DBMS_VERSION', 'ODBCVERSION' ], ## magic word ## Data source information 20 => ['SQL_ACCESSIBLE_PROCEDURES', 'Y' ], ## is this really true? 19 => ['SQL_ACCESSIBLE_TABLES', 'Y' ], ## is this really true? 82 => ['SQL_BOOKMARK_PERSISTENCE', 0 ], 42 => ['SQL_CATALOG_TERM', '' ], ## empty = catalogs are not supported 10004 => ['SQL_COLLATION_SEQ', \'SHOW server_encoding' ], 22 => ['SQL_CONCAT_NULL_BEHAVIOR', 0 ], ## SQL_CB_NULL 23 => ['SQL_CURSOR_COMMIT_BEHAVIOR', 1 ], ## SQL_CB_CLOSE 24 => ['SQL_CURSOR_ROLLBACK_BEHAVIOR', 1 ], ## SQL_CB_CLOSE 10001 => ['SQL_CURSOR_SENSITIVITY', 1 ], ## SQL_INSENSITIVE 25 => ['SQL_DATA_SOURCE_READ_ONLY', 'READONLY' ], ## magic word 26 => ['SQL_DEFAULT_TXN_ISOLATION', 'DEFAULTTXN' ], ## magic word (2 or 8) 10002 => ['SQL_DESCRIBE_PARAMETER', 'Y' ], 36 => ['SQL_MULT_RESULT_SETS', 'Y' ], 37 => ['SQL_MULTIPLE_ACTIVE_TXN', 'Y' ], 111 => ['SQL_NEED_LONG_DATA_LEN', 'N' ], 85 => ['SQL_NULL_COLLATION', 0 ], ## SQL_NC_HIGH 40 => ['SQL_PROCEDURE_TERM', 'function' ], ## for now 39 => ['SQL_SCHEMA_TERM', 'schema' ], 44 => ['SQL_SCROLL_OPTIONS', 8 ], ## not really for DBD? 45 => ['SQL_TABLE_TERM', 'table' ], 46 => ['SQL_TXN_CAPABLE', 2 ], ## SQL_TC_ALL 72 => ['SQL_TXN_ISOLATION_OPTION', 10 ], ## 2+8 47 => ['SQL_USER_NAME', sub { shift->{CURRENT_USER} } ], ## Supported SQL 169 => ['SQL_AGGREGATE_FUNCTIONS', 127 ], ## all of 'em 117 => ['SQL_ALTER_DOMAIN', 31 ], ## all but deferred 86 => ['SQL_ALTER_TABLE', 32639 ], ## no collate 114 => ['SQL_CATALOG_LOCATION', 0 ], 10003 => ['SQL_CATALOG_NAME', 'N' ], 41 => ['SQL_CATALOG_NAME_SEPARATOR', '' ], 92 => ['SQL_CATALOG_USAGE', 0 ], 87 => ['SQL_COLUMN_ALIAS', 'Y' ], 74 => ['SQL_CORRELATION_NAME', 2 ], ## SQL_CN_ANY 127 => ['SQL_CREATE_ASSERTION', 0 ], 128 => ['SQL_CREATE_CHARACTER_SET', 0 ], 129 => ['SQL_CREATE_COLLATION', 0 ], 130 => ['SQL_CREATE_DOMAIN', 23 ], ## no collation, no defer 131 => ['SQL_CREATE_SCHEMA', 3 ], ## 1+2 schema + authorize 132 => ['SQL_CREATE_TABLE', 13845 ], ## no collation 133 => ['SQL_CREATE_TRANSLATION', 0 ], 134 => ['SQL_CREATE_VIEW', 9 ], ## local + create? 119 => ['SQL_DATETIME_LITERALS', 65535 ], ## all? 170 => ['SQL_DDL_INDEX', 3 ], ## create + drop 136 => ['SQL_DROP_ASSERTION', 0 ], 137 => ['SQL_DROP_CHARACTER_SET', 0 ], 138 => ['SQL_DROP_COLLATION', 0 ], 139 => ['SQL_DROP_DOMAIN', 7 ], 140 => ['SQL_DROP_SCHEMA', 7 ], 141 => ['SQL_DROP_TABLE', 7 ], 142 => ['SQL_DROP_TRANSLATION', 0 ], 143 => ['SQL_DROP_VIEW', 7 ], 27 => ['SQL_EXPRESSIONS_IN_ORDERBY', 'Y' ], 88 => ['SQL_GROUP_BY', 2 ], ## GROUP_BY_CONTAINS_SELECT 28 => ['SQL_IDENTIFIER_CASE', 2 ], ## SQL_IC_LOWER 29 => ['SQL_IDENTIFIER_QUOTE_CHAR', q{"} ], 148 => ['SQL_INDEX_KEYWORDS', 0 ], ## not needed for Pg 172 => ['SQL_INSERT_STATEMENT', 7 ], ## 1+2+4 = all 73 => ['SQL_INTEGRITY', 'Y' ], ## e.g. ON DELETE CASCADE? 89 => ['SQL_KEYWORDS', 'KEYWORDS' ], ## magic word 113 => ['SQL_LIKE_ESCAPE_CLAUSE', 'Y' ], 75 => ['SQL_NON_NULLABLE_COLUMNS', 1 ], ## NNC_NOT_NULL 115 => ['SQL_OJ_CAPABILITIES', 127 ], ## all 90 => ['SQL_ORDER_BY_COLUMNS_IN_SELECT', 'N' ], 38 => ['SQL_OUTER_JOINS', 'Y' ], 21 => ['SQL_PROCEDURES', 'Y' ], 93 => ['SQL_QUOTED_IDENTIFIER_CASE', 3 ], ## SQL_IC_SENSITIVE 91 => ['SQL_SCHEMA_USAGE', 31 ], ## all 94 => ['SQL_SPECIAL_CHARACTERS', '$' ], ## there are actually many more... 118 => ['SQL_SQL_CONFORMANCE', 4 ], ## SQL92_INTERMEDIATE ?? 95 => ['SQL_SUBQUERIES', 31 ], ## all 96 => ['SQL_UNION', 3 ], ## 1+2 = all ## SQL limits 112 => ['SQL_MAX_BINARY_LITERAL_LEN', 0 ], 34 => ['SQL_MAX_CATALOG_NAME_LEN', 0 ], 108 => ['SQL_MAX_CHAR_LITERAL_LEN', 0 ], 30 => ['SQL_MAX_COLUMN_NAME_LEN', 'NAMEDATALEN' ], ## magic word 97 => ['SQL_MAX_COLUMNS_IN_GROUP_BY', 0 ], 98 => ['SQL_MAX_COLUMNS_IN_INDEX', 0 ], 99 => ['SQL_MAX_COLUMNS_IN_ORDER_BY', 0 ], 100 => ['SQL_MAX_COLUMNS_IN_SELECT', 0 ], 101 => ['SQL_MAX_COLUMNS_IN_TABLE', 250 ], ## 250-1600 (depends on column types) 31 => ['SQL_MAX_CURSOR_NAME_LEN', 'NAMEDATALEN' ], ## magic word 10005 => ['SQL_MAX_IDENTIFIER_LEN', 'NAMEDATALEN' ], ## magic word 102 => ['SQL_MAX_INDEX_SIZE', 0 ], 33 => ['SQL_MAX_PROCEDURE_NAME_LEN', 'NAMEDATALEN' ], ## magic word 104 => ['SQL_MAX_ROW_SIZE', 0 ], ## actually 1.6 TB, but too big to represent here 103 => ['SQL_MAX_ROW_SIZE_INCLUDES_LONG', 'Y' ], 32 => ['SQL_MAX_SCHEMA_NAME_LEN', 'NAMEDATALEN' ], ## magic word 105 => ['SQL_MAX_STATEMENT_LEN', 0 ], 35 => ['SQL_MAX_TABLE_NAME_LEN', 'NAMEDATALEN' ], ## magic word 106 => ['SQL_MAX_TABLES_IN_SELECT', 0 ], 107 => ['SQL_MAX_USER_NAME_LEN', 'NAMEDATALEN' ], ## magic word ## Scalar function information 48 => ['SQL_CONVERT_FUNCTIONS', 2 ], ## CVT_CAST only? 49 => ['SQL_NUMERIC_FUNCTIONS', 16777215 ], ## ?? all but some naming clashes: rand(om), trunc(ate), log10=ln, etc. 50 => ['SQL_STRING_FUNCTIONS', 16280984 ], ## ?? 51 => ['SQL_SYSTEM_FUNCTIONS', 0 ], ## ?? 109 => ['SQL_TIMEDATE_ADD_INTERVALS', 0 ], ## ?? no explicit timestampadd? 110 => ['SQL_TIMEDATE_DIFF_INTERVALS', 0 ], ## ?? 52 => ['SQL_TIMEDATE_FUNCTIONS', 1966083 ], ## Conversion information - all but BIT, LONGVARBINARY, and LONGVARCHAR 53 => ['SQL_CONVERT_BIGINT', 1830399 ], 54 => ['SQL_CONVERT_BINARY', 1830399 ], 55 => ['SQL_CONVERT_BIT', 0 ], 56 => ['SQL_CONVERT_CHAR', 1830399 ], 57 => ['SQL_CONVERT_DATE', 1830399 ], 58 => ['SQL_CONVERT_DECIMAL', 1830399 ], 59 => ['SQL_CONVERT_DOUBLE', 1830399 ], 60 => ['SQL_CONVERT_FLOAT', 1830399 ], 61 => ['SQL_CONVERT_INTEGER', 1830399 ], 123 => ['SQL_CONVERT_INTERVAL_DAY_TIME', 1830399 ], 124 => ['SQL_CONVERT_INTERVAL_YEAR_MONTH', 1830399 ], 71 => ['SQL_CONVERT_LONGVARBINARY', 0 ], 62 => ['SQL_CONVERT_LONGVARCHAR', 0 ], 63 => ['SQL_CONVERT_NUMERIC', 1830399 ], 64 => ['SQL_CONVERT_REAL', 1830399 ], 65 => ['SQL_CONVERT_SMALLINT', 1830399 ], 66 => ['SQL_CONVERT_TIME', 1830399 ], 67 => ['SQL_CONVERT_TIMESTAMP', 1830399 ], 68 => ['SQL_CONVERT_TINYINT', 1830399 ], 69 => ['SQL_CONVERT_VARBINARY', 0 ], 70 => ['SQL_CONVERT_VARCHAR', 1830399 ], 122 => ['SQL_CONVERT_WCHAR', 0 ], 125 => ['SQL_CONVERT_WLONGVARCHAR', 0 ], 126 => ['SQL_CONVERT_WVARCHAR', 0 ], ); ## end of %get_info_type ## Add keys for names into the hash for (keys %get_info_type) { $get_info_type{$get_info_type{$_}->[0]} = $get_info_type{$_}; } sub get_info { my ($dbh,$type) = @_; return undef unless exists $get_info_type{$type}; my $ans = $get_info_type{$type}->[1]; if (ref $ans eq 'CODE') { $ans = $ans->($dbh); } elsif (ref $ans eq 'SCALAR') { # SQL return $dbh->selectall_arrayref($$ans)->[0][0]; } elsif ($ans eq 'NAMEDATALEN') { return $dbh->selectall_arrayref('SHOW max_identifier_length')->[0][0]; } elsif ($ans eq 'ODBCVERSION') { my $version = $dbh->{private_dbdpg}{version}; return '00.00.0000' unless $version =~ /^([0-9][0-9]?)([0-9][0-9])([0-9][0-9])$/; return sprintf '%02d.%02d.%.2d00', $1,$2,$3; } elsif ($ans eq 'DBDVERSION') { my $simpleversion = $DBD::Pg::VERSION; $simpleversion =~ s/_/./g; no if $] >= 5.022, warnings => 'redundant'; return sprintf '%02d.%02d.%1d%1d%1d%1d', split (/\./, "$simpleversion.0.0.0.0.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:2011 return join ',' => (qw(ANALYSE ANALYZE ASC CONCURRENTLY DEFERRABLE DESC DO FREEZE ILIKE INITIALLY ISNULL LIMIT NOTNULL PLACING RETURNING VARIADIC VERBOSE)); } elsif ($ans eq 'READONLY') { my $SQL = q{SELECT CASE WHEN setting = 'on' THEN 'Y' ELSE 'N' END FROM pg_settings WHERE name = 'transaction_read_only'}; my $info = $dbh->selectall_arrayref($SQL); return $info->[0][0]; } elsif ($ans eq 'DEFAULTTXN') { my $SQL = q{SELECT CASE WHEN setting = 'read committed' THEN 2 ELSE 8 END FROM pg_settings WHERE name = 'default_transaction_isolation'}; my $info = $dbh->selectall_arrayref($SQL); return $info->[0][0]; } return $ans; } # end of get_info sub private_attribute_info { return { pg_async_status => undef, pg_bool_tf => undef, pg_int8_as_string => undef, pg_db => undef, pg_default_port => undef, pg_enable_utf8 => undef, pg_utf8_flag => undef, pg_errorlevel => undef, pg_expand_array => undef, pg_host => undef, pg_INV_READ => undef, pg_INV_WRITE => undef, pg_lib_version => undef, pg_options => undef, pg_pass => undef, pg_pid => undef, pg_placeholder_dollaronly => undef, pg_placeholder_nocolons => undef, pg_placeholder_escaped => undef, pg_port => undef, pg_prepare_now => undef, pg_protocol => undef, pg_server_prepare => undef, pg_server_version => undef, pg_skip_deallocate => undef, pg_socket => undef, pg_standard_conforming_strings => undef, pg_switch_prepared => undef, pg_user => undef, }; } } { package DBD::Pg::st; use strict; sub parse_trace_flag { return DBD::Pg->parse_trace_flag($_[1]); } sub bind_param_array { ## Binds an array of data to a specific placeholder in a statement ## The DBI version is broken, so we implement a near-copy here my $sth = shift; my ($p_id, $value_array, $attr) = @_; ## Bail if the second arg is not undef or an arrayref return $sth->set_err(1, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array)) if ref $value_array and ref $value_array ne 'ARRAY'; ## Bail if the first arg is not a number return $sth->set_err(1, q{Can't use named placeholders for non-driver supported bind_param_array}) unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here ## Store the list of items in the hash (will be undef or an arrayref) $sth->{ParamArrays}{$p_id} = $value_array; ## If any attribs were passed in, we need to call bind_param return $sth->bind_param($p_id, '', $attr) if $attr; ## This is the big change so -w does not complain return 1; } ## end bind_param_array sub private_attribute_info { return { pg_async => undef, pg_bound => undef, pg_current_row => undef, pg_direct => undef, pg_numbound => undef, pg_cmd_status => undef, pg_oid_status => undef, pg_placeholder_dollaronly => undef, pg_placeholder_nocolons => undef, pg_prepare_name => undef, pg_prepare_now => undef, pg_segments => undef, pg_server_prepare => undef, pg_size => undef, pg_switch_prepared => undef, pg_type => undef, }; } } ## end st section 1; __END__ =head1 NAME DBD::Pg - PostgreSQL database driver for the DBI module =head1 SYNOPSIS use DBI; $dbh = DBI->connect("dbi:Pg:dbname=$dbname", '', '', {AutoCommit => 0}); # The AutoCommit attribute should always be explicitly set # For some advanced uses you may need PostgreSQL type values: use DBD::Pg qw(:pg_types); $dbh->do('INSERT INTO mytable(a) VALUES (42)'); $sth = $dbh->prepare('INSERT INTO mytable(a) VALUES (?)'); $sth->execute(42); =head1 VERSION This documents version 3.20.2 of the DBD::Pg module =head1 DESCRIPTION DBD::Pg is a Perl module that works with the DBI module to provide access to PostgreSQL databases. =head1 MODULE DOCUMENTATION This documentation describes driver specific behavior and restrictions. It is not supposed to be used as the only reference for the user. In any case consult the B documentation first! L =head1 THE DBI CLASS =head2 DBI Class Methods =head3 B This method creates a database handle by connecting to a database, and is the DBI equivalent of the "new" method. To connect to a Postgres database with a minimum of parameters, use the following syntax: $dbh = DBI->connect("dbi:Pg:dbname=$dbname", '', '', {AutoCommit => 0}); This connects to the database named in the C<$dbname> variable on the default port (usually 5432) without any user authentication. The following connect statement shows almost all possible parameters: $dbh = DBI->connect("dbi:Pg:dbname=$dbname;host=$host;port=$port;options=$options", $username, $password, {AutoCommit => 0, RaiseError => 1, PrintError => 0} ); Parameters containing unusual characters such as spaces must be wrapped in single quotes around the value, and single quotes and backslashes can be escaped with a backslash, e.g. C. If a parameter is not given, the connect() method will first look for specific environment variables, and then fall back to hard-coded defaults: parameter environment variable hard coded default ------------------------------------------------------ host PGHOST local domain socket hostaddr PGHOSTADDR local domain socket port PGPORT 5432 dbname* PGDATABASE current userid options PGOPTIONS (none) service PGSERVICE (none) sslmode PGSSLMODE (none) $username PGUSER current userid $password PGPASSWORD (none) * May also use the aliases C or C If the username and password values passed via C are undefined (as opposed to merely being empty strings), DBI will use the environment variables I and I if they exist. You can also connect by using a service connection file. Service names can be defined in either a per-user service file or a system-wide file. If the same service name exists in both the user and the system file, the user file takes precedence. By default, the per-user service file is named ~/.pg_service.conf. On Microsoft Windows, it is named %APPDATA% \postgresql\.pg_service.conf (where %APPDATA% refers to the Application Data subdirectory in the user's profile). A different file name can be specified by setting the environment variable PGSERVICEFILE. The system-wide file is named F. The location of this file can be controlled by setting the I environment variable. To use one of the named services within the file, set the name by using either the I parameter or the environment variable I. Note that when connecting this way, only the minimum parameters should be used. For example, to connect to a service named "zephyr", you could use: $dbh = DBI->connect("dbi:Pg:service=zephyr", '', ''); You could also set C<$ENV{PGSERVICE}> to "zephyr" and connect like this: $dbh = DBI->connect("dbi:Pg:", '', ''); The format of the F file is simply a bracketed service name, followed by one parameter per line in the format name=value. For example: [zephyr] dbname=winds user=wisp password=W$2Hc00YSgP port=6543 There are four valid arguments to the I parameter, which controls whether to use SSL to connect to the database: =over 4 =item * disable: SSL connections are never used =item * allow: try non-SSL, then SSL =item * prefer: try SSL, then non-SSL =item * require: connect only with SSL =item * verify-ca: connect only with SSL and verify that the server certificate is issued by a trusted certificate authority (CA) =item * verify-full: connect only with SSL, verify that the server certificate is issued by a trusted CA, and verify that the server host name matches that in the certificate =back The latter two options are only supported on Postgres version 8.4 or higher. The I parameter can be used to specify the complete path to a file containing the root certificate for the server (C) or to use the certificates trusted by your OS (C). Other SSL-related connection parameters also can be specified and may need to be. Refer to the L for the complete list and the latest details on how to configure SSL connections. For example, to specify that SSL is required for connecting to a host over the network and and to do full verification of the server's certificate, you might specify this: $dbh = DBI->connect('dbi:Pg:dbname=foo;host=example.com;' . 'sslmode=verify-full;sslrootcert=system', $username, $password, {AutoCommit => 0, RaiseError => 1}); You can also connect using sockets in a specific directory. This may be needed if the server you are connecting to has a different default socket directory from the one used to compile DBD::Pg. Use the complete path to the socket directory as the name of the host, like this: $dbh = DBI->connect('dbi:Pg:dbname=foo;host=/var/tmp/socket', $username, $password, {AutoCommit => 0, RaiseError => 1}); The attribute hash can also contain a key named C, which simply calls C<< $dbh->trace('DBD') >> after the handle is created. This attribute is not recommended, as it is clearer to simply explicitly call C explicitly in your script. =head3 B $dbh = DBI->connect_cached("dbi:Pg:dbname=$dbname", $username, $password, \%options); Implemented by DBI, no driver-specific impact. =head3 B @data_sources = $dbh->data_sources('Pg', \%attr); @data_sources = DBI->data_sources('Pg', \%attr); Returns a list of available databases as DBI connection strings. Unless the environment variable C is set, a connection will be attempted to the database C. The normal connection environment variables also apply, such as C, C, C, C, and C. The first argument should always be 'Pg' The second argument is a list of options to append to the resulting connection strings. For example, to specify an alternate port and host: @data_sources = DBI->data_sources('Pg', 'port=5824;host=example.com'); =head2 Methods Common To All Handles For all of the methods below, B<$h> can be either a database handle (B<$dbh>) or a statement handle (B<$sth>). Note that I<$dbh> and I<$sth> can be replaced with any variable name you choose: these are just the names most often used. Another common variable used in this documentation is $I, which stands for "return value". =head3 B $rv = $h->err; Returns the error code from the last method called. For the connect method it returns C, which is a number used by I (the Postgres connection library). A value of 0 indicates no error (CONNECTION_OK), while any other number indicates a failed connection. The only other number commonly seen is 1 (CONNECTION_BAD). See the libpq documentation for the complete list of return codes. In all other non-connect methods C<< $h->err >> returns the C of the current handle. This is a number used by libpq and is one of: 0 Empty query string 1 A command that returns no data successfully completed. 2 A command that returns data successfully completed. 3 A COPY OUT command is still in progress. 4 A COPY IN command is still in progress. 5 A bad response was received from the backend. 6 A nonfatal error occurred (a notice or warning message) 7 A fatal error was returned: the last query failed. =head3 B $str = $h->errstr; Returns the last error that was reported by Postgres. This message is affected by the L setting. =head3 B $str = $h->state; Returns a five-character "SQLSTATE" code. Success is indicated by a C<00000> code, which gets mapped to an empty string by DBI. A code of C indicates a connection failure, usually because the connection to the Postgres server has been lost. While this method can be called as either C<< $sth->state >> or C<< $dbh->state >>, it is usually clearer to always use C<< $dbh->state >>. The list of codes used by PostgreSQL can be found at: L Note that these codes are part of the SQL standard and only a small number of them will be used by PostgreSQL. Common codes: 00000 Successful completion 25P01 No active SQL transaction 25P02 In failed SQL transaction S8006 Connection failure =head3 B $h->trace($trace_settings); $h->trace($trace_settings, $trace_filename); $trace_settings = $h->trace; Changes the trace settings on a database or statement handle. The optional second argument specifies a file to write the trace information to. If no filename is given, the information is written to F. Note that tracing can be set globally as well by setting C<< DBI->trace >>, or by using the environment variable I. The value is either a numeric level or a named flag. For the flags that DBD::Pg uses, see L. =head3 B $h->trace_msg($message_text); $h->trace_msg($message_text, $min_level); Writes a message to the current trace output (as set by the L method). If a second argument is given, the message is only written if the current tracing level is equal to or greater than the C<$min_level>. =head3 B and B $h->trace($h->parse_trace_flags('SQL|pglibpq')); $h->trace($h->parse_trace_flags('1|pgstart')); ## Simpler: $h->trace('SQL|pglibpq'); $h->trace('1|pgstart'); my $value = DBD::Pg->parse_trace_flag('pglibpq'); DBI->trace($value); The parse_trace_flags method is used to convert one or more named flags to a number which can passed to the L method. DBD::Pg currently supports the DBI-specific flag, C, as well as the ones listed below. Flags can be combined by using the parse_trace_flags method, which simply calls C on each item and combines them. Sometimes you may wish to turn the tracing on before you connect to the database. The second example above shows a way of doing this: the call to C<< DBD::Pg->parse_trace_flags >> provides a number than can be fed to C<< DBI->trace >> before you create a database handle. DBD::Pg supports the following trace flags: =over 4 =item SQL Outputs all SQL statements. Note that the output provided will not necessarily be in a form suitable to passing directly to Postgres, as server-side prepared statements are used extensively by DBD::Pg. For maximum portability of output (but with a potential performance hit), use with C<< $dbh->{pg_server_prepare} = 0 >>. =item DBD Turns on all non-DBI flags, in other words, only the ones that are specific to DBD::Pg (all those below which start with the letters 'pg'). =item pglibpq Outputs the name of each libpq function (without arguments) immediately before running it. This is a good way to trace the flow of your program at a low level. This information is also output if the trace level is set to 4 or greater. =item pgstart Outputs the name of each internal DBD::Pg function, and other information such as the function arguments or important global variables, as each function starts. This information is also output if the trace level is set to 4 or greater. =item pgend Outputs a simple message at the very end of each internal DBD::Pg function. This is also output if the trace level is set to 4 or greater. =item pgprefix Forces each line of trace output to begin with the string B>. This helps to differentiate it from the normal DBI trace output. =item pglogin Outputs a message showing the connection string right before a new database connection is attempted, a message when the connection was successful, and a message right after the database has been disconnected. Also output if trace level is 5 or greater. =back See the L for more information. =head3 B DBD::Pg uses the C method to support a variety of functions. Note that the name of the function comes I, after the arguments. =over =item table_attributes $attrs = $dbh->func($table, 'table_attributes'); Use of the tables_attributes function is no longer recommended. Instead, you can use the more portable C and C methods to access the same information. The table_attributes method returns, for the given table argument, a reference to an array of hashes, each of which contains the following keys: NAME attribute name TYPE attribute type SIZE attribute size (-1 for variable size) NULLABLE flag nullable DEFAULT default value CONSTRAINT constraint PRIMARY_KEY flag is_primary_key REMARKS attribute description =item pg_lo_creat $lobjId = $dbh->pg_lo_creat($mode); Creates a new large object and returns the object-id. C<$mode> is a bitmask describing read and write access to the new object. This setting is ignored since Postgres version 8.1. For backwards compatibility, however, you should set a valid mode anyway (see L for a list of valid modes). Upon failure it returns C. This function cannot be used if AutoCommit is enabled. The old way of calling large objects functions is deprecated: $dbh->func(.., 'lo_); =item pg_lo_open $lobj_fd = $dbh->pg_lo_open($lobjId, $mode); Opens an existing large object and returns an object-descriptor for use in subsequent C calls. C<$mode> is a bitmask describing read and write access to the opened object. It may be one of: $dbh->{pg_INV_READ} $dbh->{pg_INV_WRITE} $dbh->{pg_INV_READ} | $dbh->{pg_INV_WRITE} C and C modes are identical; in both modes, the large object can be read from or written to. Reading from the object will provide the object as written in other committed transactions, along with any writes performed by the current transaction. Objects opened with C cannot be written to. Reading from this object will provide the stored data at the time of the transaction snapshot which was active when C was called. Returns C upon failure. Note that 0 is a perfectly correct (and common) object descriptor! This function cannot be used if AutoCommit is enabled. =item pg_lo_write $nbytes = $dbh->pg_lo_write($lobj_fd, $buffer, $len); Writes C<$len> bytes of C<$buffer> into the large object C<$lobj_fd>. Returns the number of bytes written and C upon failure. This function cannot be used if AutoCommit is enabled. =item pg_lo_read $nbytes = $dbh->pg_lo_read($lobj_fd, $buffer, $len); Reads C<$len> bytes into C<$buffer> from large object C<$lobj_fd>. Returns the number of bytes read and C upon failure. This function cannot be used if AutoCommit is enabled. =item pg_lo_lseek $loc = $dbh->pg_lo_lseek($lobj_fd, $offset, $whence); Changes the current read or write location on the large object C<$obj_id>. Currently C<$whence> can only be 0 (which is L_SET). Returns the current location and C upon failure. This function cannot be used if AutoCommit is enabled. =item pg_lo_lseek64 Backwards compatible alias for L. Since DBD::Pg 3.16, that method handles 64-bit offsets if supported by the Perl and PostgreSQL versions in use. =item pg_lo_tell $loc = $dbh->pg_lo_tell($lobj_fd); Returns the current read or write location on the large object C<$lobj_fd> and C upon failure. This function cannot be used if AutoCommit is enabled. =item pg_lo_tell64 Backwards compatible alias for L. Since DBD::Pg 3.16, that method handles 64-bit offsets if supported by the Perl and PostgreSQL versions in use. =item pg_lo_truncate $loc = $dbh->pg_lo_truncate($lobj_fd, $len); Truncates the given large object to the new size. Returns C on failure, and 0 on success. This function cannot be used if AutoCommit is enabled. =item pg_lo_truncate64 Backwards compatible alias for L. Since DBD::Pg 3.16, that method handles 64-bit offsets if supported by the Perl and PostgreSQL versions in use. =item pg_lo_close $lobj_fd = $dbh->pg_lo_close($lobj_fd); Closes an existing large object. Returns true upon success and false upon failure. This function cannot be used if AutoCommit is enabled. =item pg_lo_unlink $ret = $dbh->pg_lo_unlink($lobjId); Deletes an existing large object. Returns true upon success and false upon failure. This function cannot be used if AutoCommit is enabled. =item pg_lo_import $lobjId = $dbh->pg_lo_import($filename); Imports a Unix file as a large object and returns the object id of the new object or C upon failure. =item pg_lo_import_with_oid $lobjId = $dbh->pg_lo_import($filename, $OID); Same as pg_lo_import, but attempts to use the supplied OID as the large object number. If this number is 0, it falls back to the behavior of pg_lo_import (which assigns the next available OID). This is only available when DBD::Pg is compiled against a Postgres server version 8.4 or later. =item pg_lo_export $ret = $dbh->pg_lo_export($lobjId, $filename); Exports a large object into a Unix file. Returns false upon failure, true otherwise. =item getfd $fd = $dbh->func('getfd'); Deprecated, use $dbh->{pg_socket} instead. =back =head3 B $hashref = $dbh->private_attribute_info(); $hashref = $sth->private_attribute_info(); Returns a hash of all private attributes used by DBD::Pg, for either a database or a statement handle. Currently, all the hash values are undef. =head1 ATTRIBUTES COMMON TO ALL HANDLES =head3 B (boolean) If set to true, then the L method will not be automatically called when the database handle goes out of scope. This is required if you are forking, and even then you must tread carefully and ensure that either the parent or the child (but not both!) handles all database calls from that point forwards, so that messages from the Postgres backend are only handled by one of the processes. If you don't set things up properly, you will see messages such as "I", and "I". The best solution is to either have the child process reconnect to the database with a fresh database handle, or to rewrite your application not to use forking. See the section on L for a way to have your script continue to work while the database is processing a request. =head3 B (boolean) The InactiveDestroy attribute, described above, needs to be explicitly set in the child process after a fork. If the code that performs the fork is in a third party module such as Sys::Syslog, this can present a problem. Use AutoInactiveDestroy to get around this problem. =head3 B (boolean, inherited) Forces errors to always raise an exception. Although it defaults to off, it is recommended that this be turned on, as the alternative is to check the return value of every method (prepare, execute, fetch, etc.) manually, which is easy to forget to do. =head3 B (boolean, inherited) Forces database errors to also generate warnings, which can then be filtered with methods such as locally redefining I<$SIG{__WARN__}> or using modules such as C. This attribute is on by default. =head3 B (boolean, inherited) Appends information about the current statement to error messages. If placeholder information is available, adds that as well. Defaults to false. Note that this will not work when using L without any arguments. =head3 B (boolean, inherited) Enables warnings. This is on by default, and should only be turned off in a local block for a short a time only when absolutely needed. =head3 B (boolean, read-only) Indicates if a handle has been executed. For database handles, this value is true after the L method has been called, or when one of the child statement handles has issued an L. Issuing a L or L always resets the attribute to false for database handles. For statement handles, any call to L or its variants will flip the value to true for the lifetime of the statement handle. =head3 B (integer, inherited) Sets the trace level, similar to the L method. See the sections on L and L for more details. =head3 B (boolean, read-only) Indicates if a handle is active or not. For database handles, this indicates if the database has been disconnected or not. For statement handles, it indicates if all the data has been fetched yet or not. Use of this attribute is not encouraged. =head3 B (integer, read-only) Returns the number of child processes created for each handle type. For a driver handle, indicates the number of database handles created. For a database handle, indicates the number of statement handles created. For statement handles, it always returns zero, because statement handles do not create kids. =head3 B (integer, read-only) Same as C, but only returns those that are active. =head3 B (hash ref) Returns a hashref of handles. If called on a database handle, returns all statement handles created by use of the C method. If called on a driver handle, returns all database handles created by the L method. =head3 B (array ref) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (code ref, inherited) Implemented by DBI, no driver-specific impact. =head3 B (unsigned integer) Implemented by DBI, no driver-specific impact. =head3 B (string, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Supported by DBD::Pg as proposed by DBI. This method is similar to the SQL function C. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (inherited) Implemented by DBI, no driver-specific impact. =head3 B (scalar) Returns C for a driver handle, C for a database handle, and C for a statement handle. Should be rarely needed. =head3 B Not used by DBD::Pg =head3 B Not used by DBD::Pg =head3 B Not used by DBD::Pg =head1 DBI DATABASE HANDLE OBJECTS =head2 Database Handle Methods =head3 B $ary_ref = $dbh->selectall_arrayref($sql); $ary_ref = $dbh->selectall_arrayref($sql, \%attr); $ary_ref = $dbh->selectall_arrayref($sql, \%attr, @bind_values); Returns a reference to an array containing the rows returned by preparing and executing the SQL string. See the DBI documentation for full details. =head3 B $hash_ref = $dbh->selectall_hashref($sql, $key_field); Returns a reference to a hash containing the rows returned by preparing and executing the SQL string. See the DBI documentation for full details. =head3 B $ary_ref = $dbh->selectcol_arrayref($sql, \%attr, @bind_values); Returns a reference to an array containing the first column from each rows returned by preparing and executing the SQL string. It is possible to specify exactly which columns to return. See the DBI documentation for full details. =head3 B $sth = $dbh->prepare($statement, \%attr); WARNING: DBD::Pg now (as of version 1.40) uses true prepared statements by sending them to the backend to be prepared by the Postgres server. Statements that were legal before may no longer work. See below for details. The prepare method prepares a statement for later execution. PostgreSQL supports prepared statements, which enables DBD::Pg to only send the query once, and simply send the arguments for every subsequent call to L. DBD::Pg can use these server-side prepared statements, or it can just send the entire query to the server each time. The best way is automatically chosen for each query. This will be sufficient for most users: keep reading for a more detailed explanation and some optional flags. Queries that do not begin with the word "SELECT", "INSERT", "UPDATE", or "DELETE" are never sent as server-side prepared statements. Deciding whether or not to use prepared statements depends on many factors, but you can force them to be used or not used by using the L attribute when calling L. Setting this to false means to never use prepared statements. Setting pg_server_prepare to true means that prepared statements should be used whenever possible. This is the default. 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. Programs such as PgBouncer which cache connections at a low level should not use prepared statements via DBD::Pg, or must take extra care in the application to account for the fact that prepared statements are not shared across database connections. Further discussion on this subject is beyond the scope of this documentation: please consult the pgsql-performance mailing list, L Only certain commands will be sent to a server-side prepare: currently these include C statements. The "prepare/bind/execute" process has changed significantly for PostgreSQL servers 7.4 and later: please see the C and C entries for much more information. Setting one of the bind_values to "undef" is the equivalent of setting the value to NULL in the database. Setting the bind_value to $DBDPG_DEFAULT is equivalent to sending the literal string 'DEFAULT' to the backend. Note that using this option will force server-side prepares off until such time as PostgreSQL supports using DEFAULT in prepared statements. DBD::Pg also supports passing in arrays to execute: simply pass in an arrayref, and DBD::Pg will flatten it into a string suitable for input on the backend. If you are using Postgres version 8.2 or greater, you can also use any of the fetch methods to retrieve the values of a C clause after you execute an C, C, or C. For example: $dbh->do(q{CREATE TABLE abc (id SERIAL, country TEXT)}); $SQL = q{INSERT INTO abc (country) VALUES (?) RETURNING id}; $sth = $dbh->prepare($SQL); $sth->execute('France'); $countryid = $sth->fetch()->[0]; $sth->execute('New Zealand'); $countryid = $sth->fetch()->[0]; =head3 B $tuples = $sth->execute_array() or die $sth->errstr; $tuples = $sth->execute_array(\%attr) or die $sth->errstr; $tuples = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr; ($tuples, $rows) = $sth->execute_array(\%attr) or die $sth->errstr; ($tuples, $rows) = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr; Execute a prepared statement once for each item in a passed-in hashref, or items that were previously bound via the L method. See the DBI documentation for more details. =head3 B $tuples = $sth->execute_for_fetch($fetch_tuple_sub); $tuples = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status); ($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub); ($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status); Used internally by the L method, and rarely used directly. See the DBI documentation for more details. =head3 B $ary_ref = $sth->fetchrow_arrayref; Fetches the next row of data from the statement handle, and returns a reference to an array holding the column values. Any columns that are NULL are returned as undef within the array. If there are no more rows or if an error occurs, then this method returns undef. You should check C<< $sth->err >> afterwards (or use the L attribute) to discover if the undef returned was due to an error. Note that the same array reference is returned for each fetch, so don't store the reference and then use it after a later fetch. Also, the elements of the array are also reused for each row, so take care if you want to take a reference to an element. See also L. =head3 B @ary = $sth->fetchrow_array; Similar to the L method, but returns a list of column information rather than a reference to a list. Do not use this in a scalar context. =head3 B $hash_ref = $sth->fetchrow_hashref; $hash_ref = $sth->fetchrow_hashref($name); Fetches the next row of data and returns a hashref containing the name of the columns as the keys and the data itself as the values. Any NULL value is returned as an undef value. If there are no more rows or if an error occurs, then this method returns undef. You should check C<< $sth->err >> afterwards (or use the L attribute) to discover if the undef returned was due to an error. The optional C<$name> argument should be either C, C or C, and indicates what sort of transformation to make to the keys in the hash. =head3 B $tbl_ary_ref = $sth->fetchall_arrayref(); $tbl_ary_ref = $sth->fetchall_arrayref( $slice ); $tbl_ary_ref = $sth->fetchall_arrayref( $slice, $max_rows ); Returns a reference to an array of arrays that contains all the remaining rows to be fetched from the statement handle. If there are no more rows, an empty arrayref will be returned. If an error occurs, the data read in so far will be returned. Because of this, you should always check C<< $sth->err >> after calling this method, unless L has been enabled. If C<$slice> is an array reference, fetchall_arrayref uses the L method to fetch each row as an array ref. If the C<$slice> array is not empty then it is used as a slice to select individual columns by perl array index number (starting at 0, unlike column and parameter numbers which start at 1). With no parameters, or if $slice is undefined, fetchall_arrayref acts as if passed an empty array ref. If C<$slice> is a hash reference, fetchall_arrayref uses L to fetch each row as a hash reference. See the DBI documentation for a complete discussion. =head3 B $hash_ref = $sth->fetchall_hashref( $key_field ); Returns a hashref containing all rows to be fetched from the statement handle. See the DBI documentation for a full discussion. =head3 B $rv = $sth->finish; Indicates to DBI that you are finished with the statement handle and are not going to use it again. Only needed when you have not fetched all the possible rows. =head3 B $rv = $sth->rows; Returns the number of rows returned by the last query. In contrast to many other DBD modules, the number of rows is available immediately after calling C<< $sth->execute >>. Note that the L method itself returns the number of rows itself, which means that this method is rarely needed. =head3 B $rv = $sth->bind_col($column_number, \$var_to_bind); $rv = $sth->bind_col($column_number, \$var_to_bind, \%attr ); $rv = $sth->bind_col($column_number, \$var_to_bind, $bind_type ); Binds a Perl variable and/or some attributes to an output column of a SELECT statement. Column numbers count up from 1. You do not need to bind output columns in order to fetch data. See the DBI documentation for a discussion of the optional parameters C<\%attr> and C<$bind_type> =head3 B $rv = $sth->bind_columns(@list_of_refs_to_vars_to_bind); Calls the L method for each column in the SELECT statement, using the supplied list. =head3 B $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh); Fetches all the rows from the statement handle, calls C for each row, and prints the results to C<$fh> (which defaults to F). Rows are separated by C<$lsep> (which defaults to a newline). Columns are separated by C<$fsep> (which defaults to a comma). The C<$maxlen> controls how wide the output can be, and defaults to 35. This method is designed as a handy utility for prototyping and testing queries. Since it uses "neat_list" to format and edit the string for reading by humans, it is not recommended for data transfer applications. =head3 B $blob = $sth->blob_read($id, $offset, $len); Supported by DBD::Pg. This method is implemented by DBI but not currently documented by DBI, so this method might change. This method seems to be heavily influenced by the current implementation of blobs in Oracle. Nevertheless we try to be as compatible as possible. Whereas Oracle suffers from the limitation that blobs are related to tables and every table can have only one blob (datatype LONG), PostgreSQL handles its blobs independent of any table by using so-called object identifiers. This explains why the C method is blessed into the STATEMENT package and not part of the DATABASE package. Here the field parameter has been used to handle this object identifier. The offset and len parameters may be set to zero, in which case the whole blob is fetched at once. See also the PostgreSQL-specific functions concerning blobs, which are available via the C interface. For further information and examples about blobs, please read the chapter about Large Objects in the PostgreSQL Programmer's Guide at L. =head3 B $data = $sth->pg_canonical_ids; DBD::Pg specific method. It returns Oid of table and position in table for every column in result set. Returns array of arrays with F and F for every column in result set or undef if current column is not a simple reference. =head3 B $data = $sth->pg_canonical_names; DBD::Pg specific method. It returns array of original (or canonical) names (from where this data is actually came from) of columns in F.F
.F format or undef if current column is not a simple reference. Note that this method is quite slow because it need additional information from server for every column that is simple reference. Consider to use L instead. =head3 B $rv = $sth->last_insert_id(undef, $schema, $table, undef); $rv = $sth->last_insert_id(undef, $schema, $table, undef, {sequence => $seqname}); This is simply an alternative way to return the same information as C<< $dbh->last_insert_id >>. =head2 Statement Handle Attributes =head3 B (integer, read-only) Returns the number of columns returned by the current statement. A number will only be returned for SELECT statements, for SHOW statements (which always return C<1>), and for INSERT, UPDATE, and DELETE statements which contain a RETURNING clause. This method returns undef if called before C. =head3 B (integer, read-only) Returns the number of placeholders in the current statement. =head3 B (arrayref, read-only) Returns an arrayref of column names for the current statement. This method will only work for SELECT statements, for SHOW statements, and for INSERT, UPDATE, and DELETE statements which contain a RETURNING clause. This method returns undef if called before C. =head3 B (arrayref, read-only) The same as the C attribute, except that all column names are forced to lower case. =head3 B (arrayref, read-only) The same as the C attribute, except that all column names are forced to upper case. =head3 B (hashref, read-only) Similar to the C attribute, but returns a hashref of column names instead of an arrayref. The names of the columns are the keys of the hash, and the values represent the order in which the columns are returned, starting at 0. This method returns undef if called before C. =head3 B (hashref, read-only) The same as the C attribute, except that all column names are forced to lower case. =head3 B (hashref, read-only) The same as the C attribute, except that all column names are forced to lower case. =head3 B (arrayref, read-only) Returns an arrayref indicating the data type for each column in the statement. This method returns undef if called before C. =head3 B (arrayref, read-only) Returns an arrayref of integer values for each column returned by the statement. The number indicates the precision for C columns, the size in number of characters for C and C columns, and for all other types of columns it returns the number of I. This method returns undef if called before C. =head3 B (arrayref, read-only) Returns an arrayref of integer values for each column returned by the statement. The number indicates the scale of the that column. The only type that will return a value is C. This method returns undef if called before C. =head3 B (arrayref, read-only) Returns an arrayref of integer values for each column returned by the statement. The number indicates if the column is nullable or not. 0 = not nullable, 1 = nullable, 2 = unknown. This method returns undef if called before C. =head3 B (dbh, read-only) Returns the database handle this statement handle was created from. =head3 B (hash ref, read-only) Returns a reference to a hash containing the values currently bound to placeholders. If the "named parameters" type of placeholders are being used (such as ":foo"), then the keys of the hash will be the names of the placeholders (without the colon). If the "dollar sign numbers" type of placeholders are being used, the keys of the hash will be the numbers, without the dollar signs. If the "question mark" type is used, integer numbers will be returned, starting at one and increasing for every placeholder. If this method is called before L, the literal values passed in are returned. If called after L, then the quoted versions of the values are returned. =head3 B (hash ref, read-only) Returns a reference to a hash containing the type names currently bound to placeholders. The keys are the same as returned by the ParamValues method. The values are hashrefs containing a single key value pair, in which the key is either 'TYPE' if the type has a generic SQL equivalent, and 'pg_type' if the type can only be expressed by a Postgres type. The value is the internal number corresponding to the type originally passed in. (Placeholders that have not yet been bound will return undef as the value). This allows the output of ParamTypes to be passed back to the L method. =head3 B (string, read-only) Returns the statement string passed to the most recent "prepare" method called in this database handle, even if that method failed. This is especially useful where "RaiseError" is enabled and the exception handler checks $@ and sees that a C method call failed. =head3 B (integer, read-only) DBD::Pg specific attribute. Returns the number of the tuple (row) that was most recently fetched. Returns zero before and after fetching is performed. =head3 B (integer, read-only) DBD::Pg specific attribute. Returns the number of placeholders that are currently bound (via bind_param). =head3 B (hashref, read-only) DBD::Pg specific attribute. Returns a hash of all named placeholders. The key is the name of the placeholder, and the value is a 0 or a 1, indicating if the placeholder has been bound yet (e.g. via bind_param) =head3 B (arrayref, read-only) DBD::Pg specific attribute. It returns a reference to an array of integer values for each column. The integer shows the size of the column in bytes. Variable length columns are indicated by -1. =head3 B (arrayref, read-only) DBD::Pg specific attribute. It returns a reference to an array of strings for each column. The string shows the name of the data_type. =head3 B (arrayref, read-only) DBD::Pg specific attribute. Returns an arrayref of the query split on the placeholders. =head3 B (integer, read-only) DBD::Pg specific attribute. It returns the OID of the last INSERT command. =head3 B (integer, read-only) DBD::Pg specific attribute. It returns the type of the last command. Possible types are: "INSERT", "DELETE", "UPDATE", "SELECT". =head3 B (boolean) DBD::Pg specific attribute. Default is false. If true, the query is passed directly to the backend without parsing for placeholders. =head3 B (boolean) DBD::Pg specific attribute. Default is off. If true, the query will be immediately prepared, rather than waiting for the L call. =head3 B (string) DBD::Pg specific attribute. Specifies the name of the prepared statement to use for this statement handle. Not normally needed, see the section on the L method for more information. =head3 B (boolean) DBD::Pg specific attribute. Indicates if DBD::Pg should attempt to use server-side prepared statements for this statement handle. The default value, true, indicates that prepared statements should be used whenever possible. See the section on the L method for more information. =head3 B (integer) DBD::Pg specific attribute. Indicates when DBD::Pg will internally switch from using PQexecParams to PQexecPrepared. In other words, when it will start using server-side prepared statements (assuming all other requirements for them are met). The default value, 2, means that a prepared statement will be prepared and used the second and subsequent time execute is called. To always use PQexecPrepared instead of PQexecParams, set pg_switch_prepared to 1 (this was the default behavior in earlier versions). Setting pg_switch_prepared to 0 will force DBD::Pg to always use PQexecParams. =head3 B (boolean) DBD::Pg specific attribute. Defaults to false. When true, question marks inside of the query being prepared are not treated as placeholders. Useful for statements that contain unquoted question marks, such as geometric operators. Note that you may also simply escape question marks with a backslash to prevent them from being treated as placeholders. =head3 B (boolean) DBD::Pg specific attribute. Defaults to false. When true, colons inside of statements are not treated as L. Useful for statements that contain an array slice. You may also place a backslash directly before the colon to prevent it from being treated as a placeholder. =head3 B (integer) DBD::Pg specific attribute. Indicates the current behavior for asynchronous queries. See the section on L for more information. =head3 B (integer, read-only) DBD::Pg specific attribute. Returns the current status of an L command. 0 indicates no asynchronous command is in progress, 1 indicates that an asynchronous command has started and -1 indicated that an asynchronous command has been cancelled. =head3 B Not used by DBD::Pg =head3 B Not used by DBD::Pg =head3 B Not used by DBD::Pg. See the note about L elsewhere in this document. =head1 FURTHER INFORMATION =head2 Encoding DBD::Pg has extensive support for a client_encoding of UTF-8, and most things like encoding and decoding should happen automatically. If you are using a different encoding, you will need do the encoding and decoding yourself. For this reason, it is highly recommended to always use a client_encoding of UTF-8. The server_encoding can be anything, and no recommendations are made there, other than avoid SQL_ASCII whenever possible. =head2 Transactions Transaction behavior is controlled via the L attribute. For a complete definition of C please refer to the DBI documentation. According to the DBI specification the default for C is a true value. In this mode, any change to the database becomes valid immediately. Any C, C or C statements will be rejected. Note that preparing a statement does not always contact the server, as the actual C is usually postponed until the first call to L. =head2 Savepoints PostgreSQL version 8.0 introduced the concept of savepoints, which allows transactions to be rolled back to a certain point without affecting the rest of the transaction. DBD::Pg encourages using the following methods to control savepoints: =head3 C Creates a savepoint. This will fail unless you are inside of a transaction. The only argument is the name of the savepoint. Note that PostgreSQL DOES allow multiple savepoints with the same name to exist. $dbh->pg_savepoint("mysavepoint"); =head3 C Rolls the database back to a named savepoint, discarding any work performed after that point. If more than one savepoint with that name exists, rolls back to the most recently created one. $dbh->pg_rollback_to("mysavepoint"); =head3 C Releases (or removes) a named savepoint. If more than one savepoint with that name exists, it will only destroy the most recently created one. Note that all savepoints created after the one being released are also destroyed. $dbh->pg_release("mysavepoint"); =head2 Asynchronous Queries It is possible to send a query to the backend and have your script do other work while the query is running on the backend. Both queries sent by the L method, and by the L method can be sent asynchronously. The basic usage is as follows: print "Async do() example:\n"; $dbh->do("SELECT long_running_query()", {pg_async => PG_ASYNC}); do_something_else(); { if ($dbh->pg_ready()) { $res = $dbh->pg_result(); print "Result of do(): $res\n"; } print "Query is still running...\n"; if (cancel_request_received) { $dbh->pg_cancel(); } sleep 1; redo; } print "Async prepare/execute example:\n"; $sth = $dbh->prepare("SELECT long_running_query(1)", {pg_async => PG_ASYNC}); $sth->execute(); ## Changed our mind, cancel and run again: $sth = $dbh->prepare("SELECT 678", {pg_async => PG_ASYNC + PG_OLDQUERY_CANCEL}); $sth->execute(); do_something_else(); if (!$sth->pg_ready) { do_another_thing(); } ## We wait until it is done, and get the result: $res = $dbh->pg_result(); =head3 Asynchronous Constants There are currently three asynchronous constants automatically exported by DBD::Pg. =over 4 =item PG_ASYNC This is a constant for the number 1. It is passed to either the L or the L method as a value to the pg_async key and indicates that the query should be sent asynchronously. =item PG_OLDQUERY_CANCEL This is a constant for the number 2. When passed to either the L or the L method, it causes any currently running asynchronous query to be cancelled and rolled back. It has no effect if no asynchronous query is currently running. =item PG_OLDQUERY_WAIT This is a constant for the number 4. When passed to either the L or the L method, it waits for any currently running asynchronous query to complete. It has no effect if there is no asynchronous query currently running. =back =head3 Asynchronous Methods =over 4 =item B This database-level method attempts to cancel any currently running asynchronous query. It returns true if the cancel succeeded, and false otherwise. Note that a query that has finished before this method is executed will also return false. B: a successful cancellation may leave the database in an unusable state, so you may need to ROLLBACK or ROLLBACK TO a savepoint. As of version 2.17.0 of DBD::Pg, rollbacks are not done automatically. $result = $dbh->pg_cancel(); =item B This method can be called as a database handle method or (for convenience) as a statement handle method. Both simply see if a previously issued asynchronous query has completed yet. It returns true if the statement has finished, in which case you should then call the L method. Calls to C should only be used when you have other things to do while the query is running. If you simply want to wait until the query is done, do not call pg_ready() over and over, but simply call the pg_result() method. my $time = 0; while (!$dbh->pg_ready) { print "Query is still running. Seconds: $time\n"; $time++; sleep 1; } $result = $dbh->pg_result; =item B This database handle method returns the results of a previously issued asynchronous query. If the query is still running, this method will wait until it has finished. The result returned is the number of rows: the same thing that would have been returned by the asynchronous L or L if it had been called without an asynchronous flag. $result = $dbh->pg_result; =item B Send a request to cancel a running asynchronous query to the server. Returns true if this succeeded, false otherwise. The actual outcome of the query still needs to be determined in the ordinary way. If a running query was actually cancelled, C will return zero and the C method will return 57014. =back =head3 Asynchronous Examples Here are some working examples of asynchronous queries. Note that we'll use the B function to emulate a long-running query. use strict; use warnings; use Time::HiRes 'sleep'; use DBD::Pg ':async'; my $dbh = DBI->connect('dbi:Pg:dbname=postgres', 'postgres', '', {AutoCommit=>0,RaiseError=>1}); ## Kick off a long running query on the first database: my $sth = $dbh->prepare("SELECT pg_sleep(?)", {pg_async => PG_ASYNC}); $sth->execute(5); ## While that is running, do some other things print "Your query is processing. Thanks for waiting\n"; check_on_the_kids(); ## Expensive sub, takes at least three seconds. while (!$dbh->pg_ready) { check_on_the_kids(); ## If the above function returns quickly for some reason, we add a small sleep sleep 0.1; } print "The query has finished. Gathering results\n"; my $result = $sth->pg_result; print "Result: $result\n"; my $info = $sth->fetchall_arrayref(); Without asynchronous queries, the above script would take about 8 seconds to run: five seconds waiting for the execute to finish, then three for the check_on_the_kids() function to return. With asynchronous queries, the script takes about 6 seconds to run, and gets in two iterations of check_on_the_kids in the process. Here's an example showing the ability to cancel a long-running query. Imagine two replica databases in different geographic locations over a slow network. You need information as quickly as possible, so you query both at once. When you get an answer, you tell the other one to stop working on your query, as you don't need it anymore. use strict; use warnings; use Time::HiRes 'sleep'; use DBD::Pg ':async'; my $dbhrep1 = DBI->connect('dbi:Pg:dbname=postgres;host=replica1', 'postgres', '', {AutoCommit=>0,RaiseError=>1}); my $dbhrep2 = DBI->connect('dbi:Pg:dbname=postgres;host=replica2', 'postgres', '', {AutoCommit=>0,RaiseError=>1}); $SQL = "SELECT count(*) FROM largetable WHERE flavor='blueberry'"; my $sth1 = $dbhrep1->prepare($SQL, {pg_async => PG_ASYNC}); my $sth2 = $dbhrep2->prepare($SQL, {pg_async => PG_ASYNC}); $sth1->execute(); $sth2->execute(); my $winner; while (!defined $winner) { if ($sth1->pg_ready) { $winner = 1; } elsif ($sth2->pg_ready) { $winner = 2; } Time::HiRes::sleep 0.05; } my $count; if ($winner == 1) { $sth2->pg_cancel(); $sth1->pg_result(); $count = $sth1->fetchall_arrayref()->[0][0]; } else { $sth1->pg_cancel(); $sth2->pg_result(); $count = $sth2->fetchall_arrayref()->[0][0]; } =head3 Asynchronous Connect Passing a true value for the attribute pg_async_connect to the DBI connect method, e.g. $dbh = DBI->connect('dbi:Pg:...', $username, $password, { pg_async_connect => 1 }); starts an asynchronous connect. The B method must be used afterwards to complete the connection establishment process. If the attribute is present but its value is false, an ordinary synchronous connect will be done instead. =head2 Array support DBD::Pg allows arrays (as arrayrefs) to be passed in to both the L and the L methods. In both cases, the array is flattened into a string representing a Postgres array. When fetching rows from a table that contains a column with an array type, the result will be passed back to your script as an arrayref. To turn off the automatic parsing of returned arrays into arrayrefs, you can set the attribute L, which is true by default. $dbh->{pg_expand_array} = 0; =head2 COPY support DBD::Pg allows for quick (bulk) reading and storing of data by using the B command. The basic process is to use C<< $dbh->do >> to issue a COPY command, and then to either add rows using L, or to read them by using L. The first step is to put the server into "COPY" mode. This is done by sending a complete COPY command to the server, by using the L method. For example: $dbh->do("COPY foobar FROM STDIN"); This would tell the server to enter a COPY IN mode (yes, that's confusing, but the I is COPY IN because of the I COPY FROM). It is now ready to receive information via the L method. The complete syntax of the COPY command is more complex and not documented here: the canonical PostgreSQL documentation for COPY can be found at: http://www.postgresql.org/docs/current/static/sql-copy.html Once a COPY command has been issued, no other SQL commands are allowed until L has been issued (for COPY FROM), or the final L has been called (for COPY TO). Note: All other COPY methods (pg_putline, pg_getline, etc.) are now heavily deprecated in favor of the pg_getcopydata, pg_putcopydata, and pg_putcopyend methods. =head3 B Used to retrieve data from a table after the server has been put into a COPY OUT mode by calling "COPY tablename TO STDOUT". Data is always returned one data row at a time. Note that the server will add a newline to each returned row. The first argument to pg_getcopydata is the variable into which the data will be stored (this variable should not be undefined, or it may throw a warning, although it may be a reference). The pg_getcopydata method returns a number greater than 1 indicating the new size of the variable, or a -1 when the COPY has finished. Once a -1 has been returned, no other action is necessary, as COPY mode will have already terminated. Example: $dbh->do("COPY mytable TO STDOUT"); my @data; my $x=0; 1 while $dbh->pg_getcopydata($data[$x++]) >= 0; There is also a variation of this method called B, which, as the name suggests, returns immediately. The only difference from the original method is that this version may return a 0, indicating that the row is not ready to be delivered yet. When this happens, the variable has not been changed, and you will need to call the method again until you get a non-zero result. (Data is still always returned one data row at a time.) =head3 B Used to put data into a table after the server has been put into COPY IN mode by calling "COPY tablename FROM STDIN". The only argument is the data you want inserted. Issue a pg_putcopyend() when you have added all your rows. The default delimiter is a tab character, but this can be changed in the COPY statement. Returns a 1 on successful input. Examples: ## Simple example: $dbh->do("COPY mytable FROM STDIN"); $dbh->pg_putcopydata("123\tPepperoni\t3\n"); $dbh->pg_putcopydata("314\tMushroom\t8\n"); $dbh->pg_putcopydata("6\tAnchovies\t100\n"); $dbh->pg_putcopyend(); ## This example uses explicit columns and a custom delimiter $dbh->do("COPY mytable(flavor, slices) FROM STDIN WITH DELIMITER '~'"); $dbh->pg_putcopydata("Pepperoni~123\n"); $dbh->pg_putcopydata("Mushroom~314\n"); $dbh->pg_putcopydata("Anchovies~6\n"); $dbh->pg_putcopyend(); =head3 B When you are finished with pg_putcopydata, call pg_putcopyend to let the server know that you are done, and it will return to a normal, non-COPY state. Returns a 1 on success. This method will fail if called when not in COPY IN mode. =head2 Postgres limits For convenience, DBD::Pg can export certain constants representing the limits of Postgres data types. To use them, just add C<:pg_limits> when DBD::Pg is used: use DBD::Pg qw/:pg_limits/; The constants and their values are: =pod PG_MIN_SMALLINT -32768 PG_MAX_SMALLINT 32767 PG_MIN_INTEGER -2147483648 PG_MAX_INTEGER 2147483647 PG_MIN_BIGINT -9223372036854775808 PG_MAX_BIGINT 9223372036854775807 PG_MIN_SMALLSERIAL 1 PG_MAX_SMALLSERIAL 32767 PG_MIN_SERIAL 1 PG_MAX_SERIAL 2147483647 PG_MIN_BIGSERIAL 1 PG_MAX_BIGSERIAL 9223372036854775807 =cut =head2 Large Objects DBD::Pg supports all largeobject functions provided by libpq via the C<< $dbh->pg_lo* >> methods. Please note that access to a large object, even read-only large objects, must be put into a transaction. If DBD::Pg is compiled against and connected to PostgreSQL 9.3 or newer, and your Perl has 64-bit integers, it will use the 64-bit variants of the seek, tell and truncate methods. =head2 Cursors Although PostgreSQL supports cursors, they have not been used in the current implementation. When DBD::Pg was created, cursors in PostgreSQL could only be used inside a transaction block. Because only one transaction block at a time is allowed, this would have implied the restriction not to use any nested C