DBD-Pg-3.7.0/0000755000175000017500000000000013162003552011105 5ustar greggregDBD-Pg-3.7.0/MANIFEST0000644000175000017500000000135313075773115012254 0ustar greggregChanges README SIGNATURE Pg.pm META.yml TODO Makefile.PL 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/02attribs.t t/03dbmethod.t t/03smethod.t t/04misc.t t/06bytea.t t/07copy.t t/08async.t t/09arrays.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.7.0/quote.c0000644000175000017500000010265613075772316012436 0ustar greggreg/* Copyright (c) 2003-2017 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 !=9 && *string != 32 && *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_ 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 = 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) snprintf((char *)result, 6, "\\\\%03o", (unsigned char)*string++); result += 5; } else { *result++ = *string++; } len--; } *result++ = '\''; *result = '\0'; return (char *)result - (*retlen); } char * quote_sql_binary(pTHX_ 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); strncpy(result,"TRUE\0",5); *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); strncpy(result,"FALSE\0",6); *retlen = 5; return result; } croak("Invalid boolean value"); } char * quote_int(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring) { char * result; New(0, result, len+1, char); strcpy(result,string); *retlen = len; while (len > 0 && *string != '\0') { len--; if (isdigit(*string) || ' ' == *string || '+' == *string || '-' == *string) { string++; continue; } croak("Invalid integer"); } return result; } char * quote_float(pTHX_ 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; /* 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_ const char *string, STRLEN *retlen, int estring) { /* TODO: chop_blanks if requested */ *retlen = strlen(string); } void dequote_string(pTHX_ const char *string, STRLEN *retlen, int estring) { *retlen = strlen(string); } static void _dequote_bytea_escape(char *string, STRLEN *retlen, int estring) { 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, int estring) { 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, int estring) { if (NULL != string) { if ('\\' == *string && 'x' == *(string+1)) _dequote_bytea_hex(string, retlen, estring); else _dequote_bytea_escape(string, retlen, estring); } } /* 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, int estring) { /* We are going to return a dequote_bytea(), just in case */ warn("Use of SQL_BINARY invalid in dequote()"); dequote_bytea(aTHX_ string, retlen, estring); /* Put dequote_sql_binary function here at some point */ } void dequote_bool(pTHX_ char *string, STRLEN *retlen, int estring) { 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_ const char *string, STRLEN *retlen, int estring) { *retlen = strlen(string); } bool is_keyword(const char *string) { int max_keyword_length = 17; int keyword_len; int i; char word[64]; 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 */ if (0==strcmp(word, "abort")) return DBDPG_TRUE; if (0==strcmp(word, "absolute")) return DBDPG_TRUE; if (0==strcmp(word, "access")) return DBDPG_TRUE; if (0==strcmp(word, "action")) return DBDPG_TRUE; if (0==strcmp(word, "add")) return DBDPG_TRUE; if (0==strcmp(word, "admin")) return DBDPG_TRUE; if (0==strcmp(word, "after")) return DBDPG_TRUE; if (0==strcmp(word, "aggregate")) return DBDPG_TRUE; if (0==strcmp(word, "all")) return DBDPG_TRUE; if (0==strcmp(word, "also")) return DBDPG_TRUE; if (0==strcmp(word, "alter")) return DBDPG_TRUE; if (0==strcmp(word, "always")) return DBDPG_TRUE; if (0==strcmp(word, "analyse")) return DBDPG_TRUE; if (0==strcmp(word, "analyze")) return DBDPG_TRUE; if (0==strcmp(word, "and")) return DBDPG_TRUE; if (0==strcmp(word, "any")) return DBDPG_TRUE; if (0==strcmp(word, "array")) return DBDPG_TRUE; if (0==strcmp(word, "as")) return DBDPG_TRUE; if (0==strcmp(word, "asc")) return DBDPG_TRUE; if (0==strcmp(word, "assertion")) return DBDPG_TRUE; if (0==strcmp(word, "assignment")) return DBDPG_TRUE; if (0==strcmp(word, "asymmetric")) return DBDPG_TRUE; if (0==strcmp(word, "at")) return DBDPG_TRUE; if (0==strcmp(word, "authorization")) return DBDPG_TRUE; if (0==strcmp(word, "backward")) return DBDPG_TRUE; if (0==strcmp(word, "before")) return DBDPG_TRUE; if (0==strcmp(word, "begin")) return DBDPG_TRUE; if (0==strcmp(word, "between")) return DBDPG_TRUE; if (0==strcmp(word, "bigint")) return DBDPG_TRUE; if (0==strcmp(word, "binary")) return DBDPG_TRUE; if (0==strcmp(word, "bit")) return DBDPG_TRUE; if (0==strcmp(word, "boolean")) return DBDPG_TRUE; if (0==strcmp(word, "both")) return DBDPG_TRUE; if (0==strcmp(word, "by")) return DBDPG_TRUE; if (0==strcmp(word, "cache")) return DBDPG_TRUE; if (0==strcmp(word, "called")) return DBDPG_TRUE; if (0==strcmp(word, "cascade")) return DBDPG_TRUE; if (0==strcmp(word, "cascaded")) return DBDPG_TRUE; if (0==strcmp(word, "case")) return DBDPG_TRUE; if (0==strcmp(word, "cast")) return DBDPG_TRUE; if (0==strcmp(word, "catalog")) return DBDPG_TRUE; if (0==strcmp(word, "chain")) return DBDPG_TRUE; if (0==strcmp(word, "char")) return DBDPG_TRUE; if (0==strcmp(word, "character")) return DBDPG_TRUE; if (0==strcmp(word, "characteristics")) return DBDPG_TRUE; if (0==strcmp(word, "check")) return DBDPG_TRUE; if (0==strcmp(word, "checkpoint")) return DBDPG_TRUE; if (0==strcmp(word, "class")) return DBDPG_TRUE; if (0==strcmp(word, "close")) return DBDPG_TRUE; if (0==strcmp(word, "cluster")) return DBDPG_TRUE; if (0==strcmp(word, "coalesce")) return DBDPG_TRUE; if (0==strcmp(word, "collate")) return DBDPG_TRUE; if (0==strcmp(word, "column")) return DBDPG_TRUE; if (0==strcmp(word, "comment")) return DBDPG_TRUE; if (0==strcmp(word, "commit")) return DBDPG_TRUE; if (0==strcmp(word, "committed")) return DBDPG_TRUE; if (0==strcmp(word, "concurrently")) return DBDPG_TRUE; if (0==strcmp(word, "configuration")) return DBDPG_TRUE; if (0==strcmp(word, "connection")) return DBDPG_TRUE; if (0==strcmp(word, "constraint")) return DBDPG_TRUE; if (0==strcmp(word, "constraints")) return DBDPG_TRUE; if (0==strcmp(word, "content")) return DBDPG_TRUE; if (0==strcmp(word, "continue")) return DBDPG_TRUE; if (0==strcmp(word, "conversion")) return DBDPG_TRUE; if (0==strcmp(word, "copy")) return DBDPG_TRUE; if (0==strcmp(word, "cost")) return DBDPG_TRUE; if (0==strcmp(word, "create")) return DBDPG_TRUE; if (0==strcmp(word, "createdb")) return DBDPG_TRUE; if (0==strcmp(word, "createrole")) return DBDPG_TRUE; if (0==strcmp(word, "createuser")) return DBDPG_TRUE; if (0==strcmp(word, "cross")) return DBDPG_TRUE; if (0==strcmp(word, "csv")) return DBDPG_TRUE; if (0==strcmp(word, "current")) return DBDPG_TRUE; if (0==strcmp(word, "current_catalog")) return DBDPG_TRUE; if (0==strcmp(word, "current_date")) return DBDPG_TRUE; if (0==strcmp(word, "current_role")) return DBDPG_TRUE; if (0==strcmp(word, "current_schema")) return DBDPG_TRUE; if (0==strcmp(word, "current_time")) return DBDPG_TRUE; if (0==strcmp(word, "current_timestamp")) return DBDPG_TRUE; if (0==strcmp(word, "current_user")) return DBDPG_TRUE; if (0==strcmp(word, "cursor")) return DBDPG_TRUE; if (0==strcmp(word, "cycle")) return DBDPG_TRUE; if (0==strcmp(word, "data")) return DBDPG_TRUE; if (0==strcmp(word, "database")) return DBDPG_TRUE; if (0==strcmp(word, "day")) return DBDPG_TRUE; if (0==strcmp(word, "deallocate")) return DBDPG_TRUE; if (0==strcmp(word, "dec")) return DBDPG_TRUE; if (0==strcmp(word, "decimal")) return DBDPG_TRUE; if (0==strcmp(word, "declare")) return DBDPG_TRUE; if (0==strcmp(word, "default")) return DBDPG_TRUE; if (0==strcmp(word, "defaults")) return DBDPG_TRUE; if (0==strcmp(word, "deferrable")) return DBDPG_TRUE; if (0==strcmp(word, "deferred")) return DBDPG_TRUE; if (0==strcmp(word, "definer")) return DBDPG_TRUE; if (0==strcmp(word, "delete")) return DBDPG_TRUE; if (0==strcmp(word, "delimiter")) return DBDPG_TRUE; if (0==strcmp(word, "delimiters")) return DBDPG_TRUE; if (0==strcmp(word, "desc")) return DBDPG_TRUE; if (0==strcmp(word, "dictionary")) return DBDPG_TRUE; if (0==strcmp(word, "disable")) return DBDPG_TRUE; if (0==strcmp(word, "discard")) return DBDPG_TRUE; if (0==strcmp(word, "distinct")) return DBDPG_TRUE; if (0==strcmp(word, "do")) return DBDPG_TRUE; if (0==strcmp(word, "document")) return DBDPG_TRUE; if (0==strcmp(word, "domain")) return DBDPG_TRUE; if (0==strcmp(word, "double")) return DBDPG_TRUE; if (0==strcmp(word, "drop")) return DBDPG_TRUE; if (0==strcmp(word, "each")) return DBDPG_TRUE; if (0==strcmp(word, "else")) return DBDPG_TRUE; if (0==strcmp(word, "enable")) return DBDPG_TRUE; if (0==strcmp(word, "encoding")) return DBDPG_TRUE; if (0==strcmp(word, "encrypted")) return DBDPG_TRUE; if (0==strcmp(word, "end")) return DBDPG_TRUE; if (0==strcmp(word, "enum")) return DBDPG_TRUE; if (0==strcmp(word, "escape")) return DBDPG_TRUE; if (0==strcmp(word, "except")) return DBDPG_TRUE; if (0==strcmp(word, "excluding")) return DBDPG_TRUE; if (0==strcmp(word, "exclusive")) return DBDPG_TRUE; if (0==strcmp(word, "execute")) return DBDPG_TRUE; if (0==strcmp(word, "exists")) return DBDPG_TRUE; if (0==strcmp(word, "explain")) return DBDPG_TRUE; if (0==strcmp(word, "external")) return DBDPG_TRUE; if (0==strcmp(word, "extract")) return DBDPG_TRUE; if (0==strcmp(word, "false")) return DBDPG_TRUE; if (0==strcmp(word, "family")) return DBDPG_TRUE; if (0==strcmp(word, "fetch")) return DBDPG_TRUE; if (0==strcmp(word, "first")) return DBDPG_TRUE; if (0==strcmp(word, "float")) return DBDPG_TRUE; if (0==strcmp(word, "following")) return DBDPG_TRUE; if (0==strcmp(word, "for")) return DBDPG_TRUE; if (0==strcmp(word, "force")) return DBDPG_TRUE; if (0==strcmp(word, "foreign")) return DBDPG_TRUE; if (0==strcmp(word, "forward")) return DBDPG_TRUE; if (0==strcmp(word, "freeze")) return DBDPG_TRUE; if (0==strcmp(word, "from")) return DBDPG_TRUE; if (0==strcmp(word, "full")) return DBDPG_TRUE; if (0==strcmp(word, "function")) return DBDPG_TRUE; if (0==strcmp(word, "global")) return DBDPG_TRUE; if (0==strcmp(word, "grant")) return DBDPG_TRUE; if (0==strcmp(word, "granted")) return DBDPG_TRUE; if (0==strcmp(word, "greatest")) return DBDPG_TRUE; if (0==strcmp(word, "group")) return DBDPG_TRUE; if (0==strcmp(word, "handler")) return DBDPG_TRUE; if (0==strcmp(word, "having")) return DBDPG_TRUE; if (0==strcmp(word, "header")) return DBDPG_TRUE; if (0==strcmp(word, "hold")) return DBDPG_TRUE; if (0==strcmp(word, "hour")) return DBDPG_TRUE; if (0==strcmp(word, "identity")) return DBDPG_TRUE; if (0==strcmp(word, "if")) return DBDPG_TRUE; if (0==strcmp(word, "ilike")) return DBDPG_TRUE; if (0==strcmp(word, "immediate")) return DBDPG_TRUE; if (0==strcmp(word, "immutable")) return DBDPG_TRUE; if (0==strcmp(word, "implicit")) return DBDPG_TRUE; if (0==strcmp(word, "in")) return DBDPG_TRUE; if (0==strcmp(word, "including")) return DBDPG_TRUE; if (0==strcmp(word, "increment")) return DBDPG_TRUE; if (0==strcmp(word, "index")) return DBDPG_TRUE; if (0==strcmp(word, "indexes")) return DBDPG_TRUE; if (0==strcmp(word, "inherit")) return DBDPG_TRUE; if (0==strcmp(word, "inherits")) return DBDPG_TRUE; if (0==strcmp(word, "initially")) return DBDPG_TRUE; if (0==strcmp(word, "inner")) return DBDPG_TRUE; if (0==strcmp(word, "inout")) return DBDPG_TRUE; if (0==strcmp(word, "input")) return DBDPG_TRUE; if (0==strcmp(word, "insensitive")) return DBDPG_TRUE; if (0==strcmp(word, "insert")) return DBDPG_TRUE; if (0==strcmp(word, "instead")) return DBDPG_TRUE; if (0==strcmp(word, "int")) return DBDPG_TRUE; if (0==strcmp(word, "integer")) return DBDPG_TRUE; if (0==strcmp(word, "intersect")) return DBDPG_TRUE; if (0==strcmp(word, "interval")) return DBDPG_TRUE; if (0==strcmp(word, "into")) return DBDPG_TRUE; if (0==strcmp(word, "invoker")) return DBDPG_TRUE; if (0==strcmp(word, "is")) return DBDPG_TRUE; if (0==strcmp(word, "isnull")) return DBDPG_TRUE; if (0==strcmp(word, "isolation")) return DBDPG_TRUE; if (0==strcmp(word, "join")) return DBDPG_TRUE; if (0==strcmp(word, "key")) return DBDPG_TRUE; if (0==strcmp(word, "lancompiler")) return DBDPG_TRUE; if (0==strcmp(word, "language")) return DBDPG_TRUE; if (0==strcmp(word, "large")) return DBDPG_TRUE; if (0==strcmp(word, "last")) return DBDPG_TRUE; if (0==strcmp(word, "lc_collate")) return DBDPG_TRUE; if (0==strcmp(word, "lc_ctype")) return DBDPG_TRUE; if (0==strcmp(word, "leading")) return DBDPG_TRUE; if (0==strcmp(word, "least")) return DBDPG_TRUE; if (0==strcmp(word, "left")) return DBDPG_TRUE; if (0==strcmp(word, "level")) return DBDPG_TRUE; if (0==strcmp(word, "like")) return DBDPG_TRUE; if (0==strcmp(word, "limit")) return DBDPG_TRUE; if (0==strcmp(word, "listen")) return DBDPG_TRUE; if (0==strcmp(word, "load")) return DBDPG_TRUE; if (0==strcmp(word, "local")) return DBDPG_TRUE; if (0==strcmp(word, "localtime")) return DBDPG_TRUE; if (0==strcmp(word, "localtimestamp")) return DBDPG_TRUE; if (0==strcmp(word, "location")) return DBDPG_TRUE; if (0==strcmp(word, "lock")) return DBDPG_TRUE; if (0==strcmp(word, "login")) return DBDPG_TRUE; if (0==strcmp(word, "mapping")) return DBDPG_TRUE; if (0==strcmp(word, "match")) return DBDPG_TRUE; if (0==strcmp(word, "maxvalue")) return DBDPG_TRUE; if (0==strcmp(word, "minute")) return DBDPG_TRUE; if (0==strcmp(word, "minvalue")) return DBDPG_TRUE; if (0==strcmp(word, "mode")) return DBDPG_TRUE; if (0==strcmp(word, "month")) return DBDPG_TRUE; if (0==strcmp(word, "move")) return DBDPG_TRUE; if (0==strcmp(word, "name")) return DBDPG_TRUE; if (0==strcmp(word, "names")) return DBDPG_TRUE; if (0==strcmp(word, "national")) return DBDPG_TRUE; if (0==strcmp(word, "natural")) return DBDPG_TRUE; if (0==strcmp(word, "nchar")) return DBDPG_TRUE; if (0==strcmp(word, "new")) return DBDPG_TRUE; if (0==strcmp(word, "next")) return DBDPG_TRUE; if (0==strcmp(word, "no")) return DBDPG_TRUE; if (0==strcmp(word, "nocreatedb")) return DBDPG_TRUE; if (0==strcmp(word, "nocreaterole")) return DBDPG_TRUE; if (0==strcmp(word, "nocreateuser")) return DBDPG_TRUE; if (0==strcmp(word, "noinherit")) return DBDPG_TRUE; if (0==strcmp(word, "nologin")) return DBDPG_TRUE; if (0==strcmp(word, "none")) return DBDPG_TRUE; if (0==strcmp(word, "nosuperuser")) return DBDPG_TRUE; if (0==strcmp(word, "not")) return DBDPG_TRUE; if (0==strcmp(word, "nothing")) return DBDPG_TRUE; if (0==strcmp(word, "notify")) return DBDPG_TRUE; if (0==strcmp(word, "notnull")) return DBDPG_TRUE; if (0==strcmp(word, "nowait")) return DBDPG_TRUE; if (0==strcmp(word, "null")) return DBDPG_TRUE; if (0==strcmp(word, "nullif")) return DBDPG_TRUE; if (0==strcmp(word, "nulls")) return DBDPG_TRUE; if (0==strcmp(word, "numeric")) return DBDPG_TRUE; if (0==strcmp(word, "object")) return DBDPG_TRUE; if (0==strcmp(word, "of")) return DBDPG_TRUE; if (0==strcmp(word, "off")) return DBDPG_TRUE; if (0==strcmp(word, "offset")) return DBDPG_TRUE; if (0==strcmp(word, "oids")) return DBDPG_TRUE; if (0==strcmp(word, "old")) return DBDPG_TRUE; if (0==strcmp(word, "on")) return DBDPG_TRUE; if (0==strcmp(word, "only")) return DBDPG_TRUE; if (0==strcmp(word, "operator")) return DBDPG_TRUE; if (0==strcmp(word, "option")) return DBDPG_TRUE; if (0==strcmp(word, "options")) return DBDPG_TRUE; if (0==strcmp(word, "or")) return DBDPG_TRUE; if (0==strcmp(word, "order")) return DBDPG_TRUE; if (0==strcmp(word, "out")) return DBDPG_TRUE; if (0==strcmp(word, "outer")) return DBDPG_TRUE; if (0==strcmp(word, "over")) return DBDPG_TRUE; if (0==strcmp(word, "overlaps")) return DBDPG_TRUE; if (0==strcmp(word, "overlay")) return DBDPG_TRUE; if (0==strcmp(word, "owned")) return DBDPG_TRUE; if (0==strcmp(word, "owner")) return DBDPG_TRUE; if (0==strcmp(word, "parser")) return DBDPG_TRUE; if (0==strcmp(word, "partial")) return DBDPG_TRUE; if (0==strcmp(word, "partition")) return DBDPG_TRUE; if (0==strcmp(word, "password")) return DBDPG_TRUE; if (0==strcmp(word, "placing")) return DBDPG_TRUE; if (0==strcmp(word, "plans")) return DBDPG_TRUE; if (0==strcmp(word, "position")) return DBDPG_TRUE; if (0==strcmp(word, "preceding")) return DBDPG_TRUE; if (0==strcmp(word, "precision")) return DBDPG_TRUE; if (0==strcmp(word, "prepare")) return DBDPG_TRUE; if (0==strcmp(word, "prepared")) return DBDPG_TRUE; if (0==strcmp(word, "preserve")) return DBDPG_TRUE; if (0==strcmp(word, "primary")) return DBDPG_TRUE; if (0==strcmp(word, "prior")) return DBDPG_TRUE; if (0==strcmp(word, "privileges")) return DBDPG_TRUE; if (0==strcmp(word, "procedural")) return DBDPG_TRUE; if (0==strcmp(word, "procedure")) return DBDPG_TRUE; if (0==strcmp(word, "quote")) return DBDPG_TRUE; if (0==strcmp(word, "range")) return DBDPG_TRUE; if (0==strcmp(word, "read")) return DBDPG_TRUE; if (0==strcmp(word, "real")) return DBDPG_TRUE; if (0==strcmp(word, "reassign")) return DBDPG_TRUE; if (0==strcmp(word, "recheck")) return DBDPG_TRUE; if (0==strcmp(word, "recursive")) return DBDPG_TRUE; if (0==strcmp(word, "references")) return DBDPG_TRUE; if (0==strcmp(word, "reindex")) return DBDPG_TRUE; if (0==strcmp(word, "relative")) return DBDPG_TRUE; if (0==strcmp(word, "release")) return DBDPG_TRUE; if (0==strcmp(word, "rename")) return DBDPG_TRUE; if (0==strcmp(word, "repeatable")) return DBDPG_TRUE; if (0==strcmp(word, "replace")) return DBDPG_TRUE; if (0==strcmp(word, "replica")) return DBDPG_TRUE; if (0==strcmp(word, "reset")) return DBDPG_TRUE; if (0==strcmp(word, "restart")) return DBDPG_TRUE; if (0==strcmp(word, "restrict")) return DBDPG_TRUE; if (0==strcmp(word, "returning")) return DBDPG_TRUE; if (0==strcmp(word, "returns")) return DBDPG_TRUE; if (0==strcmp(word, "revoke")) return DBDPG_TRUE; if (0==strcmp(word, "right")) return DBDPG_TRUE; if (0==strcmp(word, "role")) return DBDPG_TRUE; if (0==strcmp(word, "rollback")) return DBDPG_TRUE; if (0==strcmp(word, "row")) return DBDPG_TRUE; if (0==strcmp(word, "rows")) return DBDPG_TRUE; if (0==strcmp(word, "rule")) return DBDPG_TRUE; if (0==strcmp(word, "savepoint")) return DBDPG_TRUE; if (0==strcmp(word, "schema")) return DBDPG_TRUE; if (0==strcmp(word, "scroll")) return DBDPG_TRUE; if (0==strcmp(word, "search")) return DBDPG_TRUE; if (0==strcmp(word, "second")) return DBDPG_TRUE; if (0==strcmp(word, "security")) return DBDPG_TRUE; if (0==strcmp(word, "select")) return DBDPG_TRUE; if (0==strcmp(word, "sequence")) return DBDPG_TRUE; if (0==strcmp(word, "serializable")) return DBDPG_TRUE; if (0==strcmp(word, "server")) return DBDPG_TRUE; if (0==strcmp(word, "session")) return DBDPG_TRUE; if (0==strcmp(word, "session_user")) return DBDPG_TRUE; if (0==strcmp(word, "set")) return DBDPG_TRUE; if (0==strcmp(word, "setof")) return DBDPG_TRUE; if (0==strcmp(word, "share")) return DBDPG_TRUE; if (0==strcmp(word, "show")) return DBDPG_TRUE; if (0==strcmp(word, "similar")) return DBDPG_TRUE; if (0==strcmp(word, "simple")) return DBDPG_TRUE; if (0==strcmp(word, "smallint")) return DBDPG_TRUE; if (0==strcmp(word, "some")) return DBDPG_TRUE; if (0==strcmp(word, "stable")) return DBDPG_TRUE; if (0==strcmp(word, "standalone")) return DBDPG_TRUE; if (0==strcmp(word, "start")) return DBDPG_TRUE; if (0==strcmp(word, "statement")) return DBDPG_TRUE; if (0==strcmp(word, "statistics")) return DBDPG_TRUE; if (0==strcmp(word, "stdin")) return DBDPG_TRUE; if (0==strcmp(word, "stdout")) return DBDPG_TRUE; if (0==strcmp(word, "storage")) return DBDPG_TRUE; if (0==strcmp(word, "strict")) return DBDPG_TRUE; if (0==strcmp(word, "strip")) return DBDPG_TRUE; if (0==strcmp(word, "substring")) return DBDPG_TRUE; if (0==strcmp(word, "superuser")) return DBDPG_TRUE; if (0==strcmp(word, "symmetric")) return DBDPG_TRUE; if (0==strcmp(word, "sysid")) return DBDPG_TRUE; if (0==strcmp(word, "system")) return DBDPG_TRUE; if (0==strcmp(word, "table")) return DBDPG_TRUE; if (0==strcmp(word, "tablespace")) return DBDPG_TRUE; if (0==strcmp(word, "temp")) return DBDPG_TRUE; if (0==strcmp(word, "template")) return DBDPG_TRUE; if (0==strcmp(word, "temporary")) return DBDPG_TRUE; if (0==strcmp(word, "text")) return DBDPG_TRUE; if (0==strcmp(word, "then")) return DBDPG_TRUE; if (0==strcmp(word, "time")) return DBDPG_TRUE; if (0==strcmp(word, "timestamp")) return DBDPG_TRUE; if (0==strcmp(word, "to")) return DBDPG_TRUE; if (0==strcmp(word, "trailing")) return DBDPG_TRUE; if (0==strcmp(word, "transaction")) return DBDPG_TRUE; if (0==strcmp(word, "treat")) return DBDPG_TRUE; if (0==strcmp(word, "trigger")) return DBDPG_TRUE; if (0==strcmp(word, "trim")) return DBDPG_TRUE; if (0==strcmp(word, "true")) return DBDPG_TRUE; if (0==strcmp(word, "truncate")) return DBDPG_TRUE; if (0==strcmp(word, "trusted")) return DBDPG_TRUE; if (0==strcmp(word, "type")) return DBDPG_TRUE; if (0==strcmp(word, "unbounded")) return DBDPG_TRUE; if (0==strcmp(word, "uncommitted")) return DBDPG_TRUE; if (0==strcmp(word, "unencrypted")) return DBDPG_TRUE; if (0==strcmp(word, "union")) return DBDPG_TRUE; if (0==strcmp(word, "unique")) return DBDPG_TRUE; if (0==strcmp(word, "unknown")) return DBDPG_TRUE; if (0==strcmp(word, "unlisten")) return DBDPG_TRUE; if (0==strcmp(word, "until")) return DBDPG_TRUE; if (0==strcmp(word, "update")) return DBDPG_TRUE; if (0==strcmp(word, "user")) return DBDPG_TRUE; if (0==strcmp(word, "using")) return DBDPG_TRUE; if (0==strcmp(word, "vacuum")) return DBDPG_TRUE; if (0==strcmp(word, "valid")) return DBDPG_TRUE; if (0==strcmp(word, "validator")) return DBDPG_TRUE; if (0==strcmp(word, "value")) return DBDPG_TRUE; if (0==strcmp(word, "values")) return DBDPG_TRUE; if (0==strcmp(word, "varchar")) return DBDPG_TRUE; if (0==strcmp(word, "variadic")) return DBDPG_TRUE; if (0==strcmp(word, "varying")) return DBDPG_TRUE; if (0==strcmp(word, "verbose")) return DBDPG_TRUE; if (0==strcmp(word, "version")) return DBDPG_TRUE; if (0==strcmp(word, "view")) return DBDPG_TRUE; if (0==strcmp(word, "volatile")) return DBDPG_TRUE; if (0==strcmp(word, "when")) return DBDPG_TRUE; if (0==strcmp(word, "where")) return DBDPG_TRUE; if (0==strcmp(word, "whitespace")) return DBDPG_TRUE; if (0==strcmp(word, "window")) return DBDPG_TRUE; if (0==strcmp(word, "with")) return DBDPG_TRUE; if (0==strcmp(word, "without")) return DBDPG_TRUE; if (0==strcmp(word, "work")) return DBDPG_TRUE; if (0==strcmp(word, "wrapper")) return DBDPG_TRUE; if (0==strcmp(word, "write")) return DBDPG_TRUE; if (0==strcmp(word, "xml")) return DBDPG_TRUE; if (0==strcmp(word, "xmlattributes")) return DBDPG_TRUE; if (0==strcmp(word, "xmlconcat")) return DBDPG_TRUE; if (0==strcmp(word, "xmlelement")) return DBDPG_TRUE; if (0==strcmp(word, "xmlforest")) return DBDPG_TRUE; if (0==strcmp(word, "xmlparse")) return DBDPG_TRUE; if (0==strcmp(word, "xmlpi")) return DBDPG_TRUE; if (0==strcmp(word, "xmlroot")) return DBDPG_TRUE; if (0==strcmp(word, "xmlserialize")) return DBDPG_TRUE; if (0==strcmp(word, "year")) return DBDPG_TRUE; if (0==strcmp(word, "yes")) return DBDPG_TRUE; if (0==strcmp(word, "zone")) 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 $_; for my $word (@word) { print $fh2 qq{ if (0==strcmp(word, "$word")) return DBDPG_TRUE;\n}; } 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'; system("mv $tempfile $ofile"); print "Wrote $ofile\n"; exit; __END__ */ DBD-Pg-3.7.0/dbivport.h0000644000175000017500000000374013066550507013125 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.7.0/README.win320000644000175000017500000000460413066550507012744 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, or use the files here: http://pgfoundry.org/frs/?group_id=1000199 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.7.0/Makefile.PL0000644000175000017500000002565113162002742013070 0ustar greggreguse ExtUtils::MakeMaker; use Config; use strict; use warnings; use 5.008001; ## No version.pm for this one, as the prereqs are not loaded yet. my $VERSION = '3.7.0'; ## App::Info is stored inside t/lib ## Create a proper path so we can use it below my $lib; BEGIN { use vars qw/$sep/; my %sep = ( MacOS => ':', MSWin32 => '\\', os2 => '\\', VMS => '\\', NetWare => '\\', dos => '\\', ); $sep = $sep{$^O} || '/'; $lib = join $sep, 't', 'lib'; } use lib $lib; if ($VERSION =~ /_/) { print "WARNING! This is a test version ($VERSION) and should not be used in production!\n"; } if (grep { /help/ } @ARGV) { print qq{ Usage: perl $0 No other options are necessary, although you may need to set some evironment variables. See the README file for full details. In brief: By default Makefile.PL uses App::Info to find the location of the PostgreSQL library and include directories. However, if you want to control it yourself, define the environment variables POSTGRES_INCLUDE and POSTGRES_LIB, or define just POSTGRES_HOME. Note that if you have compiled PostgreSQL with SSL support, you must define the POSTGRES_LIB environment variable and add "-lssl" to it, like this: export POSTGRES_LIB="/usr/local/pgsql/lib -lssl" The usual steps to install DBD::Pg: 1. perl Makefile.PL 2. make 3. make test 4. make install Do steps 1 to 3 as a normal user, not as root! If all else fails, email dbd-pg\@perl.org for help. }; exit 1; } print "Configuring DBD::Pg $VERSION\n"; my $POSTGRES_INCLUDE; my $POSTGRES_LIB; # We need the version information to properly set compiler options later # Use App::Info to get the data we need. require App::Info::RDBMS::PostgreSQL; my $prompt; if ($ENV{PERL_MM_USE_DEFAULT} or $ENV{AUTOMATED_TESTING}) { require App::Info::Handler::Print; $prompt = App::Info::Handler::Print->new; } else { require App::Info::Handler::Prompt; $prompt = App::Info::Handler::Prompt->new; } my $pg = App::Info::RDBMS::PostgreSQL->new(on_unknown => $prompt); my ($major_ver, $minor_ver, $patch, $conf, $bindir) = map {$pg->$_} qw/major_version minor_version patch_version configure bin_dir/; my $initdb = ''; if (defined $bindir and -d $bindir) { my $testinitdb = "$bindir${sep}initdb"; if (-e $testinitdb) { $initdb = $testinitdb; } } my $serverversion = 0; my $defaultport = 0; if (defined $major_ver) { $serverversion = sprintf '%d%.02d%.02d', $major_ver, $minor_ver, $patch; $defaultport = $conf =~ /with-pgport=(\d+)/ ? $1 : 5432; } # We set POSTGRES_INCLUDE and POSTGRES_LIB from the first found of: # 1. environment variable # 2. App::Info::RDBMS::PostgreSQL information # 3. subdirectory of $ENV{POSTGRES_HOME} $POSTGRES_INCLUDE = $ENV{POSTGRES_INCLUDE} || $pg->inc_dir; if (! defined $POSTGRES_INCLUDE) { if (! defined $ENV{POSTGRES_HOME}) { warn "No POSTGRES_HOME defined, cannot find automatically\n"; exit 0; } $POSTGRES_INCLUDE = "$ENV{POSTGRES_HOME}/include"; } $POSTGRES_LIB = $ENV{POSTGRES_LIB} || $pg->lib_dir || "$ENV{POSTGRES_HOME}/lib"; my $os = $^O; print "PostgreSQL version: $serverversion (default port: $defaultport)\n"; my $showhome = $ENV{POSTGRES_HOME} || '(not set)'; print "POSTGRES_HOME: $showhome\n"; my $showinc = $POSTGRES_INCLUDE || '(not set)'; print "POSTGRES_INCLUDE: $showinc\n"; my $showlib = $POSTGRES_LIB || '(not set)'; print "POSTGRES_LIB: $showlib\n"; print "OS: $os\n"; my $baddir = 0; sub does_path_exist { my ($path_name, $path) = @_; return if ! defined $path or ! length $path or -d $path; printf "The value of %s points to a non-existent directory: %s\n", $path_name, $path; $baddir++; return; } does_path_exist('POSTGRES_HOME', $ENV{POSTGRES_HOME}); does_path_exist('POSTGRES_INCLUDE', $POSTGRES_INCLUDE); if ($baddir) { print "Cannot build unless the directories exist, exiting.\n"; exit 0; } if ($serverversion < 11) { print "Could not determine the PostgreSQL library version.\n". "Please ensure that a valid path is given to the 'pg_config' command,\n". "either manually or by setting the environment variables\n". "POSTGRES_DATA, POSTGRES_INCLUDE, and POSTGRES_LIB\n"; exit 0; } if ($os =~ /Win32/) { for ($POSTGRES_INCLUDE, $POSTGRES_LIB) { $_ = qq{"$_"} if index $_,'"'; } } ## Warn about older versions if ($serverversion < 70400) { print "\n****************\n"; print "WARNING! DBD::Pg no longer supports versions less than 7.4.\n"; print "You must upgrade PostgreSQL to a newer version.\n"; print "****************\n\n"; exit 1; } my $dbi_arch_dir; { eval { require DBI::DBD; }; if ($@) { print "Could not load DBI::DBD - is the DBI module installed?\n"; exit 0; } local *STDOUT; ## Prevent duplicate debug info as WriteMakefile also calls this $dbi_arch_dir = DBI::DBD::dbd_dbi_arch_dir(); } my $defines = " -DPGLIBVERSION=$serverversion -DPGDEFPORT=$defaultport"; my $comp_opts = $Config{q{ccflags}} . $defines; if ($ENV{DBDPG_GCCDEBUG}) { warn "Enabling many compiler options\n"; $comp_opts .= ' -Wchar-subscripts -Wcomment'; $comp_opts .= ' -Wformat=2'; ## does -Wformat,-Wformat-y2k,-Wformat-nonliteral,-Wformat-security $comp_opts .= ' -Wnonnull'; $comp_opts .= ' -Wuninitialized -Winit-self'; ## latter requires the former $comp_opts .= ' -Wimplicit'; ## does -Wimplicit-int and -Wimplicit-function-declaration $comp_opts .= ' -Wmain -Wmissing-braces -Wparentheses -Wsequence-point -Wreturn-type -Wswitch -Wswitch-enum -Wtrigraphs'; $comp_opts .= ' -Wunused'; ## contains -Wunused- function,label,parameter,variable,value $comp_opts .= ' -Wunknown-pragmas -Wstrict-aliasing'; $comp_opts .= ' -Wall'; ## all of above, but we enumerate anyway $comp_opts .= ' -Wextra -Wdeclaration-after-statement -Wendif-labels -Wpointer-arith'; $comp_opts .= ' -Wbad-function-cast -Wcast-qual -Wcast-align -Wsign-compare -Waggregate-return'; $comp_opts .= ' -Wmissing-prototypes -Wmissing-declarations -Wmissing-format-attribute -Wpacked -Winline -Winvalid-pch'; $comp_opts .= ' -Wdisabled-optimization'; $comp_opts .= ' -Wnested-externs'; $comp_opts .= " -Wstrict-prototypes"; ## Still hits a couple places in types.h $comp_opts .= " -Wswitch-default"; $comp_opts .= " -Wsystem-headers"; $comp_opts .= " -Wmissing-noreturn"; $comp_opts .= " -Wfloat-equal"; ## Does not like SvTRUE() calls $comp_opts .= " -Wpadded"; ## Use when adding/changing our structs } my %opts = ( NAME => 'DBD::Pg', VERSION_FROM => 'Pg.pm', INC => "-I$POSTGRES_INCLUDE -I$dbi_arch_dir", OBJECT => "Pg\$(OBJ_EXT) dbdimp\$(OBJ_EXT) quote\$(OBJ_EXT) types\$(OBJ_EXT)", LIBS => ["-L$POSTGRES_LIB -lpq -lm"], AUTHOR => 'Greg Sabino Mullane', ABSTRACT => 'PostgreSQL database driver for the DBI module', PREREQ_PM => { 'ExtUtils::MakeMaker' => '6.11', 'DBI' => '1.614', 'Test::More' => '0.88', 'Time::HiRes' => '0', 'version' => '0', }, CCFLAGS => $comp_opts, PERL_MALLOC_OK => 1, NEEDS_LINKING => 1, NO_META => 1, NORECURS => 1, PM => { 'Pg.pm' => '$(INST_LIBDIR)/Pg.pm', 'lib/Bundle/DBD/Pg.pm' => '$(INST_LIB)/Bundle/DBD/Pg.pm', }, clean => { FILES => 'trace Pg.xsi README.testdatabase' }, realclean => { FILES => 'dbdpg_test_database/' }, ); if ($os eq 'hpux') { my $osvers = $Config{osvers}; if ($osvers < 10) { print "Warning: Forced to build static not dynamic on $os $osvers.\a\n"; $opts{LINKTYPE} = 'static'; } } elsif ($os =~ /Win32/) { my $msdir = $POSTGRES_LIB; $msdir =~ s{"$}{/ms"}; $opts{LIBS}[0] .= " -L$msdir -lsecur32"; } if ($Config{dlsrc} =~ /dl_none/) { $opts{LINKTYPE} = 'static'; } { package MY; ## no critic sub MY::test { ## no critic my $string = shift->SUPER::test(@_); $string =~ s/(PERL_DL_NONLAZY=1)/PGINITDB="$initdb" $1/g; return $string; } } sub constants { my $self = shift; my $old_constants = $self->SUPER::constants(); my $new_constants = ''; for my $line (split /\n/ => $old_constants) { if ($line =~ /^INC = .*strawberry.*/ ) { print qq(Strawberry Perl found; adjusting the INC variable;\n); $line . ' -I ' . DBI::DBD::dbd_dbi_arch_dir(); print qq(INC is now $line\n); } $new_constants .= "$line\n"; } return $new_constants; } sub MY::postamble { ## no critic ProhibitQualifiedSubDeclarations no strict 'subs'; ## no critic ProhibitNoStrict my $string = DBI::DBD->dbd_postamble(); use strict 'subs'; ## Evil, evil stuff - but we really want to suppress the "duplicate function" message! $string =~ s/dependancy/dependency/g; ## why not, while we are here $string =~ s{(BASEEXT\)/g)}{$1; s/^do\\\(/dontdo\\\(/}; my $tags = <<'MAKE_FRAG'; .PHONY: tags tags: ctags -f tags --recurse --totals \ --exclude=blib \ --exclude=.git \ --exclude='*~' \ --languages=Perl,C --langmap=c:+.h,Perl:+.t \ MAKE_FRAG $string = "$string\n$tags\n"; $string .= <<'MAKE_SPLINT'; ## This must be version 3.2.1 or better: earlier versions have many ## problems parsing the DBI header files SPLINT = splint ## Temp directory, for use with +keep SPLINT_TMP = $(TMP)/splint_dbdpg SPLINTFLAGS = \ -message-stream-stdout \ -linelen 90 \ -boolops \ -tmpdir $(SPLINT_TMP) \ +posixstrictlib \ +ignoresigns \ +showdeephistory \ -predboolint \ -nullpass \ +charint \ +boolint \ +allglobals \ SPLINTFLAGS_TEST = SDEFINES = splint: $(H_FILES) $(C_FILES) $(MKPATH) $(SPLINT_TMP) $(SPLINT) $(SPLINTFLAGS) $(SPLINTFLAGS_TEST) $(SDEFINES) -I$(PERL_INC) $(INC) $(C_FILES) MAKE_SPLINT $string =~ s/SDEFINES = /SDEFINES =$defines/; return $string; } my $output = WriteMakefile(%opts); if (!exists $output->{EXTRALIBS} or ($output->{EXTRALIBS} !~ /\-lpq/ and $output->{EXTRALIBS} !~ /libpq/)) { my $makefile = exists $output->{MAKEFILE} ? "\nRemoving ($output->{MAKEFILE})\n" : ''; warn qq{ ========================================================== WARNING! No libpq libraries were detected! You need to install the postgresql-libs package for your system, or set the POSTGRES_LIB environment variable to the correct place. $makefile =========================================================== }; ## Do not let make proceed unlink $output->{MAKEFILE} if $makefile; exit 1; } exit 0; # end of Makefile.PL DBD-Pg-3.7.0/Pg.xs0000644000175000017500000004675313161341517012053 0ustar greggreg/* Copyright (c) 2000-2017 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_ABSTIME = 702 PG_ABSTIMEARRAY = 1023 PG_ACLITEM = 1033 PG_ACLITEMARRAY = 1034 PG_ANY = 2276 PG_ANYARRAY = 2277 PG_ANYELEMENT = 2283 PG_ANYENUM = 3500 PG_ANYNONARRAY = 2776 PG_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_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_INT4RANGE = 3904 PG_INT4RANGEARRAY = 3905 PG_INT8 = 20 PG_INT8ARRAY = 1016 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_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_NUMRANGE = 3906 PG_NUMRANGEARRAY = 3907 PG_OID = 26 PG_OIDARRAY = 1028 PG_OIDVECTOR = 30 PG_OIDVECTORARRAY = 1013 PG_OPAQUE = 2282 PG_PATH = 602 PG_PATHARRAY = 1019 PG_PG_ATTRIBUTE = 75 PG_PG_CLASS = 83 PG_PG_DDL_COMMAND = 32 PG_PG_DEPENDENCIES = 3402 PG_PG_LSN = 3220 PG_PG_LSNARRAY = 3221 PG_PG_NDISTINCT = 3361 PG_PG_NODE_TREE = 194 PG_PG_PROC = 81 PG_PG_TYPE = 71 PG_POINT = 600 PG_POINTARRAY = 1017 PG_POLYGON = 604 PG_POLYGONARRAY = 1027 PG_RECORD = 2249 PG_RECORDARRAY = 2287 PG_REFCURSOR = 1790 PG_REFCURSORARRAY = 2201 PG_REGCLASS = 2205 PG_REGCLASSARRAY = 2210 PG_REGCONFIG = 3734 PG_REGCONFIGARRAY = 3735 PG_REGDICTIONARY = 3769 PG_REGDICTIONARYARRAY = 3770 PG_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_RELTIME = 703 PG_RELTIMEARRAY = 1024 PG_SMGR = 210 PG_TEXT = 25 PG_TEXTARRAY = 1009 PG_TID = 27 PG_TIDARRAY = 1010 PG_TIME = 1083 PG_TIMEARRAY = 1183 PG_TIMESTAMP = 1114 PG_TIMESTAMPARRAY = 1115 PG_TIMESTAMPTZ = 1184 PG_TIMESTAMPTZARRAY = 1185 PG_TIMETZ = 1266 PG_TIMETZARRAY = 1270 PG_TINTERVAL = 704 PG_TINTERVALARRAY = 1025 PG_TRIGGER = 2279 PG_TSM_HANDLER = 3310 PG_TSQUERY = 3615 PG_TSQUERYARRAY = 3645 PG_TSRANGE = 3908 PG_TSRANGEARRAY = 3909 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_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_fetch((HV*)SvRV(type_sv),"pg_type", 7, 0)) != NULL) { type_info = pg_type_data(SvIV(*svp)); } else if ((svp = hv_fetch((HV*)SvRV(type_sv),"type", 4, 0)) != NULL) { type_info = sql_type_data(SvIV(*svp)); } else { type_info = NULL; } } if (!type_info) { 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; 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 # ------------------------------------------------------------ # 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, attr=Nullsv, ...) SV * dbh char * statement SV * attr PROTOTYPE: $$;$@ CODE: { long retval; int asyncflag = 0; if (statement[0] == '\0') { /* Corner case */ XST_mUNDEF(0); return; } if (attr && SvROK(attr) && SvTYPE(SvRV(attr)) == SVt_PVHV) { SV **svp; if ((svp = hv_fetch((HV*)SvRV(attr),"pg_async", 8, 0)) != NULL) { asyncflag = (int)SvIV(*svp); } } if (items < 4) { /* No bind arguments */ /* Quick run via PQexec */ retval = pg_quickexec(dbh, statement, asyncflag); } else { /* We've got bind arguments, so we do the whole prepare/execute route */ imp_sth_t *imp_sth; SV * const sth = dbixst_bounce_method("prepare", 3); if (!SvROK(sth)) XSRETURN_UNDEF; imp_sth = (imp_sth_t*)(DBIh_COM(sth)); if (!dbdxst_bind_params(sth, imp_sth, items-2, ax+2)) XSRETURN_UNDEF; imp_sth->onetime = 1; /* Tells dbdimp.c not to bother preparing this */ imp_sth->async_flag = asyncflag; retval = dbd_st_execute(sth, imp_sth); } if (retval == 0) XST_mPV(0, "0E0"); else if (retval < -1) XST_mUNDEF(0); else XST_mIV(0, retval); } void _ping(dbh) SV * dbh CODE: ST(0) = sv_2mortal(newSViv(dbd_db_ping(dbh))); void getfd(dbh) SV * dbh CODE: int ret; D_imp_dbh(dbh); ret = pg_db_getfd(imp_dbh); ST(0) = sv_2mortal( newSViv( ret ) ); void pg_endcopy(dbh) SV * dbh CODE: ST(0) = (pg_db_endcopy(dbh)!=0) ? &PL_sv_no : &PL_sv_yes; void pg_notifies(dbh) SV * dbh CODE: D_imp_dbh(dbh); ST(0) = pg_db_pg_notifies(dbh, imp_dbh); void pg_savepoint(dbh,name) SV * dbh char * name CODE: D_imp_dbh(dbh); if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh)) warn("savepoint ineffective with AutoCommit enabled"); ST(0) = (pg_db_savepoint(dbh, imp_dbh, name)!=0) ? &PL_sv_yes : &PL_sv_no; void pg_rollback_to(dbh,name) SV * dbh char * name CODE: D_imp_dbh(dbh); if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh)) warn("rollback_to ineffective with AutoCommit enabled"); ST(0) = (pg_db_rollback_to(dbh, imp_dbh, name)!=0) ? &PL_sv_yes : &PL_sv_no; void pg_release(dbh,name) SV * dbh char * name CODE: D_imp_dbh(dbh); if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh)) warn("release ineffective with AutoCommit enabled"); ST(0) = (pg_db_release(dbh, imp_dbh, name)!=0) ? &PL_sv_yes : &PL_sv_no; void pg_lo_creat(dbh, mode) SV * dbh int mode CODE: const unsigned int ret = pg_db_lo_creat(dbh, mode); ST(0) = (ret > 0) ? sv_2mortal(newSVuv(ret)) : &PL_sv_undef; void pg_lo_open(dbh, lobjId, mode) SV * dbh unsigned int lobjId int mode CODE: const int ret = pg_db_lo_open(dbh, lobjId, mode); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_write(dbh, fd, buf, len) SV * dbh int fd char * buf size_t len CODE: const int ret = pg_db_lo_write(dbh, fd, buf, len); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_read(dbh, fd, buf, len) SV * dbh int fd char * buf size_t len PREINIT: SV * const bufsv = SvROK(ST(2)) ? SvRV(ST(2)) : ST(2); int ret; CODE: sv_setpvn(bufsv,"",0); /* Make sure we can grow it safely */ buf = SvGROW(bufsv, len + 1); ret = pg_db_lo_read(dbh, fd, buf, len); if (ret > 0) { SvCUR_set(bufsv, ret); *SvEND(bufsv) = '\0'; sv_setpvn(ST(2), buf, (unsigned)ret); SvSETMAGIC(ST(2)); } ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_lseek(dbh, fd, offset, whence) SV * dbh int fd int offset int whence CODE: const int ret = pg_db_lo_lseek(dbh, fd, offset, whence); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_tell(dbh, fd) SV * dbh int fd CODE: const int ret = pg_db_lo_tell(dbh, fd); ST(0) = (ret >= 0) ? sv_2mortal(newSViv(ret)) : &PL_sv_undef; void pg_lo_truncate(dbh, fd, len) SV * dbh int fd size_t len CODE: const int 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 ) ); } #if PGLIBVERSION >= 80000 void pg_result(dbh) SV * dbh CODE: int ret; D_imp_dbh(dbh); ret = pg_db_result(dbh, imp_dbh); if (ret == 0) XST_mPV(0, "0E0"); else if (ret < -1) XST_mUNDEF(0); else XST_mIV(0, ret); void pg_ready(dbh) SV *dbh CODE: D_imp_dbh(dbh); ST(0) = sv_2mortal(newSViv(pg_db_ready(dbh, imp_dbh))); void pg_cancel(dbh) SV *dbh CODE: D_imp_dbh(dbh); ST(0) = pg_db_cancel(dbh, imp_dbh) ? &PL_sv_yes : &PL_sv_no; #endif # -- end of DBD::Pg::db # ------------------------------------------------------------ # statement level interface PG specific # ------------------------------------------------------------ MODULE = DBD::Pg PACKAGE = DBD::Pg::st void state(sth) SV *sth; CODE: D_imp_sth(sth); D_imp_dbh_from_sth; ST(0) = strEQ(imp_dbh->sqlstate,"00000") ? &PL_sv_no : 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; #if PGLIBVERSION >= 80000 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); #endif 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.7.0/types.h0000644000175000017500000001430413161341517012431 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_delimeter; char* arrayout; char* (*quote)(); void (*dequote)(); 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_ABSTIME 702 #define PG_ACLITEM 1033 #define PG_ANY 2276 #define PG_ANYELEMENT 2283 #define PG_ANYENUM 3500 #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_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_INT4RANGE 3904 #define PG_INT8 20 #define PG_INT8RANGE 3926 #define PG_INTERNAL 2281 #define PG_INTERVAL 1186 #define PG_JSON 114 #define PG_JSONB 3802 #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_NUMRANGE 3906 #define PG_OID 26 #define PG_OIDVECTOR 30 #define PG_OPAQUE 2282 #define PG_PATH 602 #define PG_PG_ATTRIBUTE 75 #define PG_PG_CLASS 83 #define PG_PG_DDL_COMMAND 32 #define PG_PG_DEPENDENCIES 3402 #define PG_PG_LSN 3220 #define PG_PG_NDISTINCT 3361 #define PG_PG_NODE_TREE 194 #define PG_PG_PROC 81 #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_REGCONFIG 3734 #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_RELTIME 703 #define PG_SMGR 210 #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_TINTERVAL 704 #define PG_TRIGGER 2279 #define PG_TSM_HANDLER 3310 #define PG_TSQUERY 3615 #define PG_TSRANGE 3908 #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_XML 142 #define PG_ABSTIMEARRAY 1023 #define PG_ACLITEMARRAY 1034 #define PG_ANYARRAY 2277 #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_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_INT4RANGEARRAY 3905 #define PG_INT8ARRAY 1016 #define PG_INT8RANGEARRAY 3927 #define PG_INTERVALARRAY 1187 #define PG_JSONARRAY 199 #define PG_JSONBARRAY 3807 #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_NUMRANGEARRAY 3907 #define PG_OIDARRAY 1028 #define PG_OIDVECTORARRAY 1013 #define PG_PATHARRAY 1019 #define PG_PG_LSNARRAY 3221 #define PG_POINTARRAY 1017 #define PG_POLYGONARRAY 1027 #define PG_RECORDARRAY 2287 #define PG_REFCURSORARRAY 2201 #define PG_REGCLASSARRAY 2210 #define PG_REGCONFIGARRAY 3735 #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_RELTIMEARRAY 1024 #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_TINTERVALARRAY 1025 #define PG_TSQUERYARRAY 3645 #define PG_TSRANGEARRAY 3909 #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_XIDARRAY 1011 #define PG_XMLARRAY 143 DBD-Pg-3.7.0/t/0000755000175000017500000000000013162003552011350 5ustar greggregDBD-Pg-3.7.0/t/dbdpg_test_setup.pl0000644000175000017500000006121213161037262015252 0ustar greggreg ## Helper file for the DBD::Pg tests use strict; use warnings; use Data::Dumper; use DBI; use Cwd; use 5.006; select(($|=1,select(STDERR),$|=1)[1]); my $superuser = 1; my $testfh; if (exists $ENV{TEST_OUTPUT}) { my $file = $ENV{TEST_OUTPUT}; open $testfh, '>>', $file or die qq{Could not append file "$file": $!\n}; Test::More->builder->failure_output($testfh); Test::More->builder->todo_output($testfh); } my @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'; use vars qw/$fh/; sub connect_database { ## Connect to the database (unless 'dbh' is passed in) ## Setup all the tables (unless 'nocreate' is passed in) ## Returns three values: ## 1. helpconnect for use by 01connect.t ## 2. Any error generated ## 3. The database handle, or undef my $arg = shift || {}; ref $arg and ref $arg eq 'HASH' or die qq{Need a hashref!\n}; my $dbh = $arg->{dbh} || ''; my $alias = qr{(database|db|dbname)}; my $info; my $olddir = getcwd; my $debug = $ENV{DBDPG_DEBUG} || 0; 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) { diag "Test settings: dsn: $testdsn user: $testuser helpconnect: $helpconnect su: $su uid: $uid testdir: $testdir pg_ctl: $pg_ctl initdb: $initdb error: $error version: $version "; } ## Did we fail last time? Fail this time too, but quicker! if ($testdsn =~ /FAIL!/) { $debug and diag 'Previous failure detected'; return $helpconnect, "Previous failure ($error)", undef; } ## We may want to force an initdb call if (!$helpconnect and $ENV{DBDPG_TESTINITDB}) { $debug and diag 'Jumping to INITDB'; goto INITDB; } ## Got a working DSN? Give it an attempt if ($testdsn and $testuser) { $debug and 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 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) { ## Bypass if the testdir has been removed if (! -e $testdir) { $arg->{nocreate} and return $helpconnect, '', undef; warn "Test directory $testdir has been removed, will create a new one\n"; } else { if (-e "$testdir/data/postmaster.pid") { ## Assume it's up, and move on } else { if ($arg->{norestart}) { return $helpconnect, '', undef; } warn "Restarting test database $testdsn at $testdir\n"; my $option = ''; if ($^O !~ /Win32/) { my $sockdir = "$testdir/data/socket"; if (! -e $sockdir) { mkdir $sockdir; if ($uid) { if (! chown $uid, -1, $sockdir) { warn "chown of $sockdir failed!\n"; } } } $option = q{-o '-k socket'}; if ($version <= 8.0) { $option = q{-o '-k dbdpg_test_database/data/socket'}; } } my $COM = qq{$pg_ctl $option -l $testdir/dbdpg_test.logfile -D $testdir/data start}; if ($su) { $COM = qq{su -m $su -c "$COM"}; chdir $testdir; } $info = ''; eval { $info = qx{$COM}; }; my $err = $@; $su and chdir $olddir; if ($err or $info !~ /\w/) { $err = "Could not startup new database ($err) ($info)"; return $helpconnect, $err, undef; } ## Wait for it to startup and verify the connection sleep 1; } my $loop = 1; STARTUP: { eval { $dbh = DBI->connect($testdsn, $testuser, '', {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; if ($@ =~ /starting up/ or $@ =~ /PGSQL\.\d+/) { if ($loop++ < 20) { sleep 1; redo STARTUP; } } } if ($@) { return $helpconnect, $@, $dbh; } ## We've got a good connection, so do final tweaks and return goto GOTDBH; } ## end testdir exists } ## end error and we created this database } ## end got testdsn and testuser ## No previous info (or failed attempt), so try to connect and possible create our own cluster $testdsn ||= $ENV{DBI_DSN}; $testuser ||= $ENV{DBI_USER}; if (! $testdsn) { $helpconnect = 1; $testdsn = $^O =~ /Win32/ ? 'dbi:Pg:host=localhost' : 'dbi:Pg:'; } if (! $testuser) { $testuser = 'postgres'; } ## From here on out, we don't return directly, but save it first GETHANDLE: { eval { $dbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; last GETHANDLE if ! $@; ## Made it! ## If the error was because of the user, try a few others if ($@ =~ /postgres/) { if ($helpconnect) { $testdsn .= ';dbname=postgres'; $helpconnect += 2; } $helpconnect += 4; $testuser = $^O =~ /openbsd/ ? '_postgresql' : $^O =~ /bsd/i ? 'pgsql' : 'postgres'; eval { $dbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; last GETHANDLE if ! $@; ## Made it! ## Final user tweak: set to postgres for Beastie if ($testuser ne 'postgres') { $helpconnect += 8; $testuser = 'postgres'; eval { $dbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; last GETHANDLE if ! $@; ## Made it! } } ## Cannot connect to an existing database, so we'll create our own if ($arg->{nocreate}) { return $helpconnect, '', undef; } INITDB: my $testport; $helpconnect = 16; ## Use the initdb found by App::Info if (! length $initdb or $initdb eq 'default') { $initdb = $ENV{DBDPG_INITDB} || $ENV{PGINITDB} || ''; } if (!$initdb or ! -e $initdb) { $initdb = 'initdb'; } ## Make sure initdb exists and is working properly $ENV{LANG} = 'C'; $info = ''; eval { $info = qx{$initdb --version 2>&1}; }; last GETHANDLE if $@; ## Fail - initdb bad $version = 0; if (!defined $info or ($info !~ /(Postgres)/i and $info !~ /run as root/)) { if (defined $info) { if ($info !~ /\w/) { $@ = 'initdb not found: cannot run full tests without a Postgres database'; } else { $@ = "Bad initdb output: $info"; } } else { my $msg = 'Failed to run initdb (executable probably not available)'; exists $ENV{DBDPG_INITDB} and $msg .= " ENV was: $ENV{DBDPG_INITDB}"; $msg .= " Final call was: $initdb"; $@ = $msg; } last GETHANDLE; ## Fail - initdb bad } elsif ($info =~ /(\d+\.\d+)/) { $version = $1; } elsif ($info =~ /(\d+)(?:devel|beta|rc|alpha)/) { ## Can be 10devel $version = $1; } else { die "No version from initdb?! ($info)\n"; } ## Make sure pg_ctl is available as well before we go further if (! -e $pg_ctl) { $pg_ctl = 'pg_ctl'; } $info = ''; eval { $info = qx{$pg_ctl --help 2>&1}; }; last GETHANDLE if $@; ## Fail - pg_ctl bad if (!defined $info or ($info !~ /\@postgresql\.org/ and $info !~ /run as root/)) { $@ = defined $initdb ? "Bad pg_ctl output: $info" : 'Bad pg_ctl output'; last GETHANDLE; ## Fail - pg_ctl bad } ## initdb and pg_ctl seems to be available, let's use them to fire up a cluster warn "Please wait, creating new database (version $version) for testing\n"; $info = ''; eval { my $com = "$initdb --locale=C -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 = ''; ## Figure out a valid directory - returns empty if nothing available $testdir = find_tempdir(); if (!$testdir) { return $helpconnect, 'Unable to create a temp directory', undef; } my $readme = "$testdir/README"; if (open $fh, '>', $readme) { print $fh "This is a test directory for DBD::Pg and may be removed\n"; print $fh "You may want to ensure the postmaster has been stopped first.\n"; print $fh "Check the data/postmaster.pid file\n"; close $fh or die qq{Could not close "$readme": $!\n}; } ## Likely candidates for running this my @userlist = (qw/postgres postgresql pgsql _postgres/); ## Start with whoever owns this file, unless it's us my $username = getpwuid ((stat($0))[4]); unshift @userlist, $username if defined $username and $username ne getpwent; my %doneuser; for (@userlist) { $testuser = $_; next if $doneuser{$testuser}++; $uid = (getpwnam $testuser)[2]; next if !defined $uid; next unless chown $uid, -1, $testdir; next unless chown $uid, -1, $readme; $su = $testuser; $founduser++; $info = ''; $olddir = getcwd; eval { chdir $testdir; $info = qx{su -m $testuser -c "$initdb --locale=C -E UTF8 -D $testdir/data 2>&1"}; }; my $err = $@; chdir $olddir; last if !$err; } if (!$founduser) { $@ = 'Unable to find a user to run initdb as'; last GETHANDLE; ## Fail - no user } if (! -e "$testdir/data") { $@ = 'Could not create a test database via initdb'; last GETHANDLE; ## Fail - no datadir created } ## At this point, both $su and $testuser are set } if ($info =~ /FATAL/) { $@ = "initdb gave a FATAL error: $info"; last GETHANDLE; ## Fail - FATAL } if ($info =~ /but is not empty/) { ## Assume this is already good to go } elsif ($info !~ /pg_ctl/) { $@ = "initdb did not give a pg_ctl string: $info"; last GETHANDLE; ## Fail - bad output } ## 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 { $info = qx{$resetxlog --help}; }; if (! $@ and $info =~ /XID/) { if (! -e "$testdir/data/postmaster.pid") { eval { $info = qx{ $resetxlog -o 2222333344 $testdir/data }; }; ## We don't really care if it worked or not! } } ## Which user do we connect as? if (!$su and $info =~ /owned by user "(.+?)"/) { $testuser = $1; } ## Now we need to find an open port to use $testport = 5442; ## If we've got netstat available, we'll trust that $info = ''; eval { $info = qx{netstat -na 2>&1}; }; if ($@) { warn "netstat call failed, trying port $testport\n"; } else { ## Start at 5440 and go up until we are free $testport = 5440; my $maxport = 5470; { last if $info !~ /PGSQL\.$testport$/m and $info !~ /\b127\.0\.0\.1:$testport\b/m; last if ++$testport >= $maxport; redo; } if ($testport >= $maxport) { $@ = "No free ports found for testing: tried 5440 to $maxport\n"; last GETHANDLE; ## Fail - no free ports } } $@ = ''; $debug and diag "Port to use: $testport"; my $conf = "$testdir/data/postgresql.conf"; my $cfh; ## If there is already a pid file, do not modify the config ## We assume a previous run put it there, so we extract the port if (-e "$testdir/data/postmaster.pid") { $debug and diag qq{File "$testdir/data/postmaster.pid" exists}; open my $cfh, '<', $conf or die qq{Could not open "$conf": $!\n}; while (<$cfh>) { if (/^\s*port\s*=\s*(\d+)/) { $testport = $1; $debug and diag qq{Found port $testport inside conf file\n}; } } close $cfh or die qq{Could not close "$conf": $!\n}; ## Assume it's up, and move on } else { ## Change to this new port and fire it up if (! open $cfh, '>>', $conf) { $@ = qq{Could not open "$conf": $!}; $debug and diag qq{Failed to open "$conf"}; last GETHANDLE; ## Fail - no conf file } $debug and diag qq{Writing to "$conf"}; print $cfh "\n\n## DBD::Pg testing parameters\n"; print $cfh "port=$testport\n"; print $cfh "max_connections=11\n"; if ($version >= 8.0) { print $cfh "log_statement = 'all'\n"; print $cfh "log_line_prefix = '%m [%p] '\n"; } else { print $cfh "silent_mode = true\n"; } if ($version == 8.1) { print {$cfh} "redirect_stderr = on\n"; } if ($version >= 8.3) { print {$cfh} "logging_collector = on\n"; } print $cfh "log_min_messages = 'DEBUG1'\n"; print $cfh "log_filename = 'postgres%Y-%m-%d.log'\n"; print $cfh "log_rotation_size = 0\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 $option = ''; if ($^O !~ /Win32/) { my $sockdir = "$testdir/data/socket"; if (! -e $sockdir) { mkdir $sockdir; if ($su) { if (! chown $uid, -1, $sockdir) { warn "chown of $sockdir failed!\n"; } } } $option = q{-o '-k socket'}; if ($version <= 8.0) { $option = q{-o '-k dbdpg_test_database/data/socket'}; } } my $COM = qq{$pg_ctl $option -l $testdir/dbdpg_test.logfile -D $testdir/data start}; $olddir = getcwd; if ($su) { chdir $testdir; $COM = qq{su -m $su -c "$COM"}; } $debug and diag qq{Running: $COM}; eval { $info = qx{$COM}; }; my $err = $@; $su and chdir $olddir; if ($err or $info !~ /\w/) { $@ = "Could not startup new database ($COM) ($err) ($info)"; last GETHANDLE; ## Fail - startup failed } sleep 1; } ## Attempt to connect to this server $testdsn = "dbi:Pg:dbname=postgres;port=$testport"; if ($^O =~ /Win32/) { $testdsn .= ';host=localhost'; } else { $testdsn .= ";host=$testdir/data/socket"; } $debug and diag qq{Test DSN: $testdsn}; my $loop = 1; STARTUP: { eval { $dbh = DBI->connect($testdsn, $testuser, '', {RaiseError => 1, PrintError => 0, AutoCommit => 1}); }; ## Regardless of the error, try again. ## We used to check the message, but LANG problems may complicate that. if ($@) { $debug and 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 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 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; } if ($arg->{quickreturn}) { $debug and 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 diag 'Attempting to cleanup database'; cleanup_database($dbh); eval { $dbh->do("CREATE SCHEMA $S"); }; $@ and $debug and 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"); $dbh->do('CREATE SEQUENCE dbd_pg_testsequence'); # If you add columns to this, please do not use reserved words! $SQL = q{ CREATE TABLE dbd_pg_test ( id integer not null primary key, lii integer unique not null default nextval('dbd_pg_testsequence'), pname varchar(20) default 'Testing Default' , val text, score float CHECK(score IN ('1','2','3')), Fixed character(5), pdate timestamp default now(), testarray text[][], testarray2 int[], testarray3 bool[], "CaseTest" boolean, expo numeric(6,2), bytetest bytea, bytearray bytea[] ) }; $dbh->{Warn} = 0; $dbh->do($SQL); $dbh->{Warn} = 1; $dbh->do(q{COMMENT ON COLUMN dbd_pg_test.id IS 'Bob is your uncle'}); } ## end setup $dbh->commit() unless $dbh->{AutoCommit}; if ($arg->{disconnect}) { $dbh->disconnect(); return $helpconnect, '', undef; } $dbh->{AutoCommit} = 0 unless $arg->{AutoCommit}; return $helpconnect, '', $dbh; } ## end of connect_database sub is_super { return $superuser; } sub find_tempdir { if (eval { require File::Temp; 1; }) { return File::Temp::tempdir('dbdpg_testdatabase_XXXXXX', TMPDIR => 1, CLEANUP => 0); } ## Who doesn't have File::Temp?! :) my $found = 0; for my $num (1..100) { my $tempdir = "/tmp/dbdpg_testdatabase_ABCDEF$num"; next if -e $tempdir; mkdir $tempdir or return ''; return $tempdir; } return ''; } ## end of find_tempdir sub get_test_settings { ## Returns test database information from the testfile if it exists ## Defaults to ENV variables or blank ## Find the best candidate for the pg_ctl program my $pg_ctl = 'pg_ctl'; 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) { open $fh, '<', $helpfile or die qq{Could not open "$helpfile": $!\n}; while (<$fh>) { if ($inerror) { $error .= "\n$_"; } /DSN: (.+)/ and $testdsn = $1; /User: (\S+)/ and $testuser = $1; /Helpconnect: (\d+)/ and $helpconnect = $1; /Testowner: (\w+)/ and $su = $1; /Testowneruid: (\d+)/ and $uid = $1; /Testdir: (.+)/ and $testdir = $1; /pg_ctl: (.+)/ and $pg_ctl = $1; /initdb: (.+)/ and $initdb = $1; /ERROR: (.+)/ and $error = $1 and $inerror = 1; /Version: (.+)/ and $version = $1; } close $fh or die qq{Could not close "$helpfile": $!\n}; } if (!$testdir) { my $dir = getcwd(); $testdir = "$dir/dbdpg_test_database"; } ## 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; my $type = shift || 0; return unless defined $dbh and ref $dbh and $dbh->ping(); ## For now, we always run and disregard the type $dbh->rollback() if ! $dbh->{AutoCommit}; for my $name (@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 (@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(); 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.7.0/t/01connect.t0000644000175000017500000001321113066550507013337 0ustar greggreg#!perl ## Make sure we can connect and disconnect cleanly ## All tests are stopped if we cannot make the first connect use 5.006; use strict; use warnings; use DBI; use DBD::Pg; use Test::More; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); ## Define this here in case we get to the END block before a connection is made. BEGIN { use vars qw/$t $pgversion $pglibversion $pgvstring $pgdefport $helpconnect $dbh $connerror %set/; ($pgversion,$pglibversion,$pgvstring,$pgdefport) = ('?','?','?','?'); } ($helpconnect,$connerror,$dbh) = connect_database(); if (! defined $dbh or $connerror) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 15; pass ('Established a connection to the database'); $pgversion = $dbh->{pg_server_version}; $pglibversion = $dbh->{pg_lib_version}; $pgdefport = $dbh->{pg_default_port}; $pgvstring = $dbh->selectall_arrayref('SELECT VERSION()')->[0][0]; ok ($dbh->disconnect(), 'Disconnect from the database'); # Connect two times. From this point onward, do a simpler connection check $t=q{Second database connection attempt worked}; (undef,$connerror,$dbh) = connect_database(); is ($connerror, '', $t); if ($connerror ne '') { BAIL_OUT 'Second connection to database failed, bailing out'; } ## Grab some important values used for debugging my @vals = qw/array_nulls backslash_quote server_encoding client_encoding standard_conforming_strings/; my $SQL = 'SELECT name,setting FROM pg_settings WHERE name IN (' . (join ',' => map { qq{'$_'} } @vals) . ')'; for (@{$dbh->selectall_arrayref($SQL)}) { $set{$_->[0]} = $_->[1]; } my $dbh2 = connect_database(); pass ('Connected with second database handle'); my $sth = $dbh->prepare('SELECT 123'); ok ($dbh->disconnect(), 'Disconnect with first database handle'); ok ($dbh2->disconnect(), 'Disconnect with second database handle'); ok ($dbh2->disconnect(), 'Disconnect again with second database handle'); eval { $sth->execute(); }; ok ($@, 'Execute fails on a disconnected statement'); # Try out various connection options $ENV{DBI_DSN} ||= ''; SKIP: { my $alias = qr{(database|db|dbname)}; if ($ENV{DBI_DSN} !~ /$alias\s*=\s*\S+/) { skip ('DBI_DSN contains no database option, so skipping connection tests', 7); } $t=q{Connect with invalid option fails}; my $err; (undef,$err,$dbh) = connect_database({ dbreplace => 'dbbarf', nocreate => 1 }); like ($err, qr{DBI connect.+failed:}, $t); for my $opt (qw/db dbname database/) { $t=qq{Connect using string '$opt' works}; $dbh and $dbh->disconnect(); (undef,$err,$dbh) = connect_database({dbreplace => $opt}); $err =~ s/(Previous failure).*/$1/; is ($err, '', $t); } $t=q{Connect with forced uppercase 'DBI:' works}; my ($testdsn,$testuser,$helpconnect,$su,$uid,$testdir,$pg_ctl,$initdb,$error,$version) = get_test_settings(); $testdsn =~ s/^dbi/DBI/i; my $ldbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 0}); ok (ref $ldbh, $t); $ldbh->disconnect(); $t=q{Connect with mixed case 'DbI:' works}; $testdsn =~ s/^dbi/DbI/i; $ldbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS}, {RaiseError => 1, PrintError => 0, AutoCommit => 0}); ok (ref $ldbh, $t); $ldbh->disconnect(); if ($ENV{DBI_DSN} =~ /$alias\s*=\s*\"/) { skip ('DBI_DSN already contains quoted database, no need for explicit test', 1); } $t=q{Connect using a quoted database argument}; eval { $dbh and $dbh->disconnect(); (undef,$err,$dbh) = connect_database({dbquotes => 1, nocreate => 1}); }; is ($@, q{}, $t); } END { my $pv = sprintf('%vd', $^V); my $schema = 'dbd_pg_testschema'; my $dsn = exists $ENV{DBI_DSN} ? $ENV{DBI_DSN} : '?'; ## Don't show current dir to the world via CPAN::Reporter results $dsn =~ s{host=/.*(dbdpg_test_database/data/socket)}{host=/$1}; my $ver = defined $DBD::Pg::VERSION ? $DBD::Pg::VERSION : '?'; my $user = exists $ENV{DBI_USER} ? $ENV{DBI_USER} : ''; my $offset = 27; my $extra = ''; for (sort qw/HOST HOSTADDR PORT DATABASE USER PASSWORD PASSFILE OPTIONS REALM REQUIRESSL KRBSRVNAME CONNECT_TIMEOUT SERVICE SSLMODE SYSCONFDIR CLIENTENCODING/) { my $name = "PG$_"; if (exists $ENV{$name} and defined $ENV{$name}) { $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name; } } for my $name (qw/DBI_DRIVER DBI_AUTOPROXY LANG/) { if (exists $ENV{$name} and defined $ENV{$name}) { $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name; } } ## More helpful stuff for (sort keys %set) { $extra .= sprintf "\n%-*s %s", $offset, $_, $set{$_}; } if ($helpconnect) { $extra .= sprintf "\n%-*s ", $offset, 'Adjusted:'; if ($helpconnect & 1) { $extra .= 'DBI_DSN '; } if ($helpconnect & 4) { $extra .= 'DBI_USER'; } if ($helpconnect & 8) { $extra .= 'DBI_USERx2'; } if ($helpconnect & 16) { $extra .= 'initdb'; } } if (defined $connerror and length $connerror) { $connerror =~ s/.+?failed: ([^\n]+).*/$1/s; $connerror =~ s{\n at t/dbdpg.*}{}m; if ($connerror =~ /create semaphores/) { $connerror =~ s/.*(FATAL.*?)HINT.*/$1/sm; } $extra .= "\nError was: $connerror"; } diag "\nDBI Version $DBI::VERSION\n". "DBD::Pg Version $ver\n". "Perl Version $pv\n". "OS $^O\n". "PostgreSQL (compiled) $pglibversion\n". "PostgreSQL (target) $pgversion\n". "PostgreSQL (reported) $pgvstring\n". "Default port $pgdefport\n". "DBI_DSN $dsn\n". "DBI_USER $user\n". "Test schema $schema$extra\n"; } DBD-Pg-3.7.0/t/06bytea.t0000644000175000017500000000555113066550507013027 0ustar greggreg#!perl ## Test bytea handling use 5.006; use strict; use warnings; use Test::More; use DBI ':sql_types'; use DBD::Pg ':pg_types'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 16; isnt ($dbh, undef, 'Connect to database for bytea testing'); my ($pglibversion,$pgversion) = ($dbh->{pg_lib_version},$dbh->{pg_server_version}); if ($pgversion >= 80100) { $dbh->do('SET escape_string_warning = false'); } my ($sth, $t); $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest,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); $t='bytea insert test with string containing a single quote'; ok ($sth->execute(401, '\''), $t); $t='bytea (second) insert test with string containing a single quote'; ok ($sth->execute(402, '\''), $t); my ($binary_in, $binary_out); $t='store binary data in BYTEA column'; for(my $i=0; $i<256; $i++) { $binary_out .= chr($i); } $sth->{pg_server_prepare} = 0; ok ($sth->execute(403, $binary_out), $t); $sth->{pg_server_prepare} = 1; ok ($sth->execute(404, $binary_out), $t); if ($pgversion < 90000) { test_outputs(undef); SKIP: { skip 'No BYTEA output format setting before 9.0', 5 } } else { test_outputs($_) for qw(hex escape); } $sth->finish(); cleanup_database($dbh,'test'); $dbh->disconnect(); sub test_outputs { my $output = shift; $dbh->do(qq{SET bytea_output = '$output'}) if $output; $t='Received correct text from BYTEA column with backslashes'; $t.=" ($output output)" if $output; $sth = $dbh->prepare(q{SELECT bytetest FROM dbd_pg_test WHERE id=?}); $sth->execute(400); my $byte = $sth->fetchall_arrayref()->[0][0]; is ($byte, 'aa\bb\cc\\\0dd\\', $t); $t='Received correct text from BYTEA column with quote'; $t.=" ($output output)" if $output; $sth->execute(402); $byte = $sth->fetchall_arrayref()->[0][0]; is ($byte, '\'', $t); $t='Ensure proper handling of high bit characters'; $t.=" ($output output)" if $output; $sth->execute(403); ($binary_in) = $sth->fetchrow_array(); cmp_ok ($binary_in, 'eq', $binary_out, $t); $sth->execute(404); ($binary_in) = $sth->fetchrow_array(); ok ($binary_in eq $binary_out, $t); $t='quote properly handles bytea strings'; $t.=" ($output output)" if $output; my $string = "abc\123\\def\0ghi"; my $result = $dbh->quote($string, { pg_type => PG_BYTEA }); my $E = $pgversion >= 80100 ? q{E} : q{}; my $expected = qq{${E}'abc\123\\\\\\\\def\\\\000ghi'}; is ($result, $expected, $t); return; } DBD-Pg-3.7.0/t/00basic.t0000644000175000017500000000157613066550507013001 0ustar greggreg#!perl ## Simply test that we can load the DBI and DBD::Pg modules, ## and that the latter gives a good version use 5.006; use strict; use warnings; use Test::More tests => 3; select(($|=1,select(STDERR),$|=1)[1]); BEGIN { use_ok ('DBI') or BAIL_OUT 'Cannot continue without DBI'; ## 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) { { local $/; $_ = <$fh>; } close $fh or die qq{Could not close file "$file" $!\n}; for my $keyword (qw/ CCFLAGS INC LIBS /) { if (/^#\s+$keyword => (.+)/m) { diag "$keyword: $1"; } } } BAIL_OUT 'Cannot continue without DBD::Pg'; } } use DBD::Pg; like ($DBD::Pg::VERSION, qr/^v?\d+\.\d+\.\d+(?:_\d+)?$/, qq{Found DBD::Pg::VERSION as "$DBD::Pg::VERSION"}); DBD-Pg-3.7.0/t/99cleanup.t0000644000175000017500000000141713066550507013363 0ustar greggreg#!perl ## Cleanup all database objects we may have created ## Shutdown the test database if we created one ## Remove the entire directory if it was created as a tempdir use 5.006; use strict; use warnings; use Test::More tests => 1; use lib 't','.'; 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.7.0/t/02attribs.t0000644000175000017500000014511213160557464013371 0ustar greggreg#!perl ## Test all handle attributes: database, statement, and generic ("any") use 5.006; use strict; use warnings; use Data::Dumper; use Test::More; use DBI ':sql_types'; use DBD::Pg qw/ :pg_types :async /; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my ($helpconnect,$connerror,$dbh) = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 271; isnt ($dbh, undef, 'Connect to database for handle attributes testing'); my ($pglibversion,$pgversion) = ($dbh->{pg_lib_version},$dbh->{pg_server_version}); my $attributes_tested = q{ d = database handle specific s = statement handle specific 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_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) }; my ($attrib,$SQL,$sth,$warning,$result,$expected,$t); # Get the DSN and user from the test file, if it exists my ($testdsn, $testuser) = get_test_settings(); # # Test of the database handle attribute "Statement" # $SQL = 'SELECT 123'; $sth = $dbh->prepare($SQL); $sth->finish(); $t='DB handle attribute "Statement" returns the last prepared query'; $attrib = $dbh->{Statement}; is ($attrib, $SQL, $t); # # Test of bogus database/statement handle attributes # ## DBI switched from error to warning in 1.43 $t='Error or warning when setting an invalid database handle attribute'; $warning=q{}; eval { local $SIG{__WARN__} = sub { $warning = shift; }; $dbh->{CrazyDiamond}=1; }; isnt ($warning, q{}, $t); $t='Setting a private attribute on a database handle does not throw an error'; eval { $dbh->{private_dbdpg_CrazyDiamond}=1; }; is ($@, q{}, $t); $sth = $dbh->prepare('SELECT 123'); $t='Error or warning when setting an invalid statement handle attribute'; $warning=q{}; eval { local $SIG{__WARN__} = sub { $warning = shift; }; $sth->{CrazyDiamond}=1; }; isnt ($warning, q{}, $t); $t='Setting a private attribute on a statement handle does not throw an error'; eval { $sth->{private_dbdpg_CrazyDiamond}=1; }; is ($@, q{}, $t); # # Test of the database handle attribute "AutoCommit" # $t='Commit after deleting all rows from dbd_pg_test'; $dbh->do('DELETE FROM dbd_pg_test'); ok ($dbh->commit(), $t); $t='Connect to database with second database handle, AutoCommit on'; my $dbh2 = connect_database({AutoCommit => 1}); isnt ($dbh2, undef, $t); $t='Insert a row into the database with first database handle'; ok ($dbh->do(q{INSERT INTO dbd_pg_test (id, pname, val) VALUES (1, 'Coconut', 'Mango')}), $t); $t='Second database handle cannot see insert from first'; my $rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 1}))[0]; is ($rows, 0, $t); $t='Insert a row into the database with second database handle'; ok ($dbh->do(q{INSERT INTO dbd_pg_test (id, pname, val) VALUES (2, 'Grapefruit', 'Pomegranate')}), $t); $t='First database handle can see insert from second'; $rows = ($dbh->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 2}))[0]; cmp_ok ($rows, '==', 1, $t); ok ($dbh->commit, 'Commit transaction with first database handle'); $t='Second database handle can see insert from first'; $rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM dbd_pg_test WHERE id = 1}))[0]; is ($rows, 1, $t); ok ($dbh2->disconnect(), 'Disconnect with second database handle'); # # Test of the database handle attribute "Driver" # $t='$dbh->{Driver}{Name} returns correct value of "Pg"'; $attrib = $dbh->{Driver}->{Name}; is ($attrib, 'Pg', $t); # # Test of the database handle attribute "Name" # SKIP: { $t='DB handle attribute "Name" returns same value as DBI_DSN'; if (! length $testdsn or $testdsn !~ /^dbi:Pg:(.+)/) { skip (q{Cannot test DB handle attribute "Name" invalid DBI_DSN}, 1); } $expected = $1 || $ENV{PGDATABASE}; defined $expected and length $expected or skip ('Cannot test unless database name known', 1); $attrib = $dbh->{Name}; $expected =~ s/(db|database)=/dbname=/; is ($attrib, $expected, $t); } # # Test of the database handle attribute "RowCacheSize" # $t='DB handle attribute "RowCacheSize" returns undef'; $attrib = $dbh->{RowCacheSize}; is ($attrib, undef, $t); $t='Setting DB handle attribute "RowCacheSize" has no effect'; $dbh->{RowCacheSize} = 42; $attrib = $dbh->{RowCacheSize}; is ($attrib, undef, $t); # # Test of the database handle attribute "Username" # $t='DB handle attribute "Username" returns the same value as DBI_USER'; $attrib = $dbh->{Username}; is ($attrib, $testuser, $t); # # Test of the "PrintWarn" database handle attribute # $t='DB handle attribute "PrintWarn" defaults to on'; my $value = $dbh->{PrintWarn}; is ($value, 1, $t); { local $SIG{__WARN__} = sub { $warning .= shift; }; $dbh->do(q{SET client_min_messages = '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/^\d+$/, $t); $t='Database handle attribute "pg_INV_READ" returns a number'; like ($dbh->{pg_INV_READ}, qr/^\d+$/, $t); # # Test of the database handle attribute "pg_protocol" # $t='Database handle attribute "pg_protocol" returns a number'; like ($dbh->{pg_protocol}, qr/^\d+$/, $t); # # Test of the database handle attribute "pg_errorlevel" # $t='Database handle attribute "pg_errorlevel" returns the default (1)'; is ($dbh->{pg_errorlevel}, 1, $t); $t='Database handle attribute "pg_errorlevel" defaults to 1 if invalid'; $dbh->{pg_errorlevel} = 3; is ($dbh->{pg_errorlevel}, 1, $t); # # Test of the database handle attribute "pg_bool_tf" # $t='DB handle method "pg_bool_tf" starts as 0'; $result = $dbh->{pg_bool_tf}=0; is ($result, 0, $t); $t=q{DB handle method "pg_bool_tf" returns '1' for true when on}; $sth = $dbh->prepare('SELECT ?::bool'); $sth->bind_param(1,1,SQL_BOOLEAN); $sth->execute(); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, '1', $t); $t=q{DB handle method "pg_bool_tf" returns '0' for false when on}; $sth->execute(0); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, '0', $t); $t=q{DB handle method "pg_bool_tf" returns 't' for true when on}; $dbh->{pg_bool_tf}=1; $sth->execute(1); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, 't', $t); $t=q{DB handle method "pg_bool_tf" returns 'f' for true when on}; $sth->execute(0); $result = $sth->fetchall_arrayref()->[0][0]; is ($result, 'f', $t); ## Test of all the informational pg_* database handle attributes $t='DB handle attribute "pg_db" returns at least one character'; $result = $dbh->{pg_protocol}; like ($result, qr/^\d+$/, $t); $t='DB handle attribute "pg_db" returns at least one character'; $result = $dbh->{pg_db}; ok (length $result, $t); $t='DB handle attribute "pg_user" returns a value'; $result = $dbh->{pg_user}; ok (defined $result, $t); $t='DB handle attribute "pg_pass" returns a value'; $result = $dbh->{pg_pass}; ok (defined $result, $t); $t='DB handle attribute "pg_port" returns a number'; $result = $dbh->{pg_port}; like ($result, qr/^\d+$/, $t); $t='DB handle attribute "pg_default_port" returns a number'; $result = $dbh->{pg_default_port}; like ($result, qr/^\d+$/, $t); $t='DB handle attribute "pg_options" returns a value'; $result = $dbh->{pg_options}; ok (defined $result, $t); $t='DB handle attribute "pg_socket" returns a value'; $result = $dbh->{pg_socket}; like ($result, qr/^\d+$/, $t); $t='DB handle attribute "pg_pid" returns a value'; $result = $dbh->{pg_pid}; like ($result, qr/^\d+$/, $t); SKIP: { if ($pgversion < 80200) { skip ('Cannot test standard_conforming_strings on pre 8.2 servers', 3); } $t='DB handle attribute "pg_standard_conforming_strings" returns a valid value'; my $oldscs = $dbh->{pg_standard_conforming_strings}; like ($oldscs, qr/^on|off$/, $t); $t='DB handle attribute "pg_standard_conforming_strings" returns correct value'; $dbh->do('SET standard_conforming_strings = on'); $result = $dbh->{pg_standard_conforming_strings}; is ($result, 'on', $t); $t='DB handle attribute "pg_standard_conforming_strings" returns correct value'; $dbh->do('SET standard_conforming_strings = off'); $result = $dbh->{pg_standard_conforming_strings}; $dbh->do("SET standard_conforming_strings = $oldscs"); is ($result, 'off', $t); } # Attempt to test whether or not we can get unicode out of the database SKIP: { eval { require Encode; }; skip ('Encode module is needed for unicode tests', 5) if $@; my $server_encoding = $dbh->selectall_arrayref('SHOW server_encoding')->[0][0]; skip ('Cannot reliably test unicode without a UTF8 database', 5) if $server_encoding ne 'UTF8'; $SQL = 'SELECT id, pname FROM dbd_pg_test WHERE id = ?'; $sth = $dbh->prepare($SQL); $sth->execute(1); local $dbh->{pg_enable_utf8} = 1; $t='Quote method returns correct utf-8 characters'; my $utf8_str = chr(0x100).'dam'; # LATIN CAPITAL LETTER A WITH MACRON is ($dbh->quote( $utf8_str ), "'$utf8_str'", $t); $t='Able to insert unicode character into the database'; $SQL = "INSERT INTO dbd_pg_test (id, pname, val) VALUES (40, '$utf8_str', 'Orange')"; is ($dbh->do($SQL), '1', $t); $t='Able to read unicode (utf8) data from the database'; $sth->execute(40); my ($id, $name) = $sth->fetchrow_array(); ok (Encode::is_utf8($name), $t); $t='Unicode (utf8) data returned from database is not corrupted'; is ($name, $utf8_str, $t); $t='ASCII text returned from database does have utf8 bit set'; $sth->finish(); $sth->execute(1); my ($id2, $name2) = $sth->fetchrow_array(); ok (Encode::is_utf8($name2), $t); $sth->finish(); } # # Use the handle attribute "Warn" to check inheritance # undef $sth; $t='Attribute "Warn" attribute set on by default'; ok ($dbh->{Warn}, $t); $t='Statement handle inherits the "Warn" attribute'; $SQL = 'SELECT 123'; $sth = $dbh->prepare($SQL); $sth->finish(); ok ($sth->{Warn}, $t); $t='Able to turn off the "Warn" attribute in the database handle'; $dbh->{Warn} = 0; ok (! $dbh->{Warn}, $t); # # Test of the the following statement handle attributes: # NUM_OF_PARAMS, NUM_OF_FIELDS # NAME, NAME_lc, NAME_uc, NAME_hash, NAME_lc_hash, NAME_uc_hash # TYPE, PRECISION, SCALE, NULLABLE # ## First, all pre-execute checks: $t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with no placeholders'; $sth = $dbh->prepare('SELECT 123'); is ($sth->{'NUM_OF_PARAMS'}, 0, $t); $t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with three placeholders'; $sth = $dbh->prepare('SELECT 123 FROM pg_class WHERE relname=? AND reltuples=? and relpages=?'); is ($sth->{'NUM_OF_PARAMS'}, 3, $t); $t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with one placeholder'; $sth = $dbh->prepare('SELECT 123 AS "Sheep", CAST(id AS float) FROM dbd_pg_test WHERE id=?'); is ($sth->{'NUM_OF_PARAMS'}, 1, $t); $t='Statement handle attribute "NUM_OF_FIELDS" returns undef before execute'; is ($sth->{'NUM_OF_FIELDS'}, undef, $t); $t='Statement handle attribute "NAME" returns undef before execute'; is ($sth->{'NAME'}, undef, $t); $t='Statement handle attribute "NAME_lc" returns undef before execute'; is ($sth->{'NAME_lc'}, undef, $t); $t='Statement handle attribute "NAME_uc" returns undef before execute'; is ($sth->{'NAME_uc'}, undef, $t); $t='Statement handle attribute "NAME_hash" returns undef before execute'; is ($sth->{'NAME_hash'}, undef, $t); $t='Statement handle attribute "NAME_lc_hash" returns undef before execute'; is ($sth->{'NAME_lc_hash'}, undef, $t); $t='Statement handle attribute "NAME_uc_hash" returns undef before execute'; is ($sth->{'NAME_uc_hash'}, undef, $t); $t='Statement handle attribute "TYPE" returns undef before execute'; is ($sth->{'TYPE'}, undef, $t); $t='Statement handle attribute "PRECISION" returns undef before execute'; is ($sth->{'PRECISION'}, undef, $t); $t='Statement handle attribute "SCALE" returns undef before execute'; is ($sth->{'SCALE'}, undef, $t); $t='Statement handle attribute "NULLABLE" returns undef before execute'; is ($sth->{'NULLABLE'}, undef, $t); ## Now, some post-execute checks: $t='Statement handle attribute "NUM_OF_PARAMS" works correctly after execute'; $sth->execute(12); is ($sth->{'NUM_OF_PARAMS'}, 1, $t); $t='Statement handle attribute "NUM_OF_FIELDS" works correctly for SELECT statements'; is ($sth->{'NUM_OF_FIELDS'}, 2, $t); $t='Statement handle attribute "NAME" works correctly for SELECT statements'; my $colnames = ['Sheep', 'id']; is_deeply ($sth->{'NAME'}, $colnames, $t); $t='Statement handle attribute "NAME_lc" works correctly for SELECT statements'; $colnames = ['sheep', 'id']; is_deeply ($sth->{'NAME_lc'}, $colnames, $t); $t='Statement handle attribute "NAME_uc" works correctly for SELECT statements'; $colnames = ['SHEEP', 'ID']; is_deeply ($sth->{'NAME_uc'}, $colnames, $t); $t='Statement handle attribute "NAME_hash" works correctly for SELECT statements'; $colnames = {'Sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_lc_hash" works correctly for SELECT statements'; $colnames = {'sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_lc_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_uc_hash" works correctly for SELECT statements'; $colnames = {'SHEEP' => 0, ID => 1}; is_deeply ($sth->{'NAME_uc_hash'}, $colnames, $t); $t='Statement handle attribute "TYPE" works correctly for SELECT statements'; $colnames = [4, 6]; is_deeply ($sth->{'TYPE'}, $colnames, $t); $t='Statement handle attribute "PRECISION" works correctly'; $colnames = [4, 8]; is_deeply ($sth->{'PRECISION'}, $colnames, $t); $t='Statement handle attribute "SCALE" works correctly'; $colnames = [undef,undef]; is_deeply ($sth->{'SCALE'}, $colnames, $t); $t='Statement handle attribute "NULLABLE" works correctly'; $colnames = [2,2]; is_deeply ($sth->{NULLABLE}, $colnames, $t); ## Post-finish tasks: $sth->finish(); $t='Statement handle attribute "NUM_OF_PARAMS" works correctly after finish'; is ($sth->{'NUM_OF_PARAMS'}, 1, $t); $t='Statement handle attribute "NUM_OF_FIELDS" works correctly after finish'; is ($sth->{'NUM_OF_FIELDS'}, 2, $t); $t='Statement handle attribute "NAME" returns undef after finish'; is_deeply ($sth->{'NAME'}, undef, $t); $t='Statement handle attribute "NAME_lc" returns values after finish'; $colnames = ['sheep', 'id']; is_deeply ($sth->{'NAME_lc'}, $colnames, $t); $t='Statement handle attribute "NAME_uc" returns values after finish'; $colnames = ['SHEEP', 'ID']; is_deeply ($sth->{'NAME_uc'}, $colnames, $t); $t='Statement handle attribute "NAME_hash" works correctly after finish'; $colnames = {'Sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_lc_hash" works correctly after finish'; $colnames = {'sheep' => 0, id => 1}; is_deeply ($sth->{'NAME_lc_hash'}, $colnames, $t); $t='Statement handle attribute "NAME_uc_hash" works correctly after finish'; $colnames = {'SHEEP' => 0, ID => 1}; is_deeply ($sth->{'NAME_uc_hash'}, $colnames, $t); $t='Statement handle attribute "TYPE" returns undef after finish'; is_deeply ($sth->{'TYPE'}, undef, $t); $t='Statement handle attribute "PRECISION" works correctly after finish'; is_deeply ($sth->{'PRECISION'}, undef, $t); $t='Statement handle attribute "SCALE" works correctly after finish'; is_deeply ($sth->{'SCALE'}, undef, $t); $t='Statement handle attribute "NULLABLE" works correctly after finish'; is_deeply ($sth->{NULLABLE}, undef, $t); ## Test UPDATE queries $t='Statement handle attribute "NUM_OF_FIELDS" returns undef for updates'; $sth = $dbh->prepare('UPDATE dbd_pg_test SET id = 99 WHERE id = ?'); $sth->execute(1); is_deeply ($sth->{'NUM_OF_FIELDS'}, undef, $t); $t='Statement handle attribute "NAME" returns empty arrayref for updates'; is_deeply ($sth->{'NAME'}, [], $t); ## These cause assertion errors, may be a DBI bug. ## Commenting out for now until we can examine closer ## Please see: http://www.nntp.perl.org/group/perl.cpan.testers/2008/08/msg2012293.html #$t='Statement handle attribute "NAME_lc" returns empty arrayref for updates'; #is_deeply ($sth->{'NAME_lc'}, [], $t); #$t='Statement handle attribute "NAME_uc" returns empty arrayref for updates'; #is_deeply ($sth->{'NAME_uc'}, [], $t); #$t='Statement handle attribute "NAME_hash" returns empty hashref for updates'; #is_deeply ($sth->{'NAME_hash'}, {}, $t); #$t='Statement handle attribute "NAME_uc_hash" returns empty hashref for updates'; #is_deeply ($sth->{'NAME_lc_hash'}, {}, $t); #$t='Statement handle attribute "NAME_uc_hash" returns empty hashref for updates'; #is_deeply ($sth->{'NAME_uc_hash'}, {}, $t); $t='Statement handle attribute "TYPE" returns empty arrayref for updates'; is_deeply ($sth->{'TYPE'}, [], $t); $t='Statement handle attribute "PRECISION" returns empty arrayref for updates'; is_deeply ($sth->{'PRECISION'}, [], $t); $t='Statement handle attribute "SCALE" returns empty arrayref for updates'; is_deeply ($sth->{'SCALE'}, [], $t); $t='Statement handle attribute "NULLABLE" returns empty arrayref for updates'; is_deeply ($sth->{'NULLABLE'}, [], $t); $dbh->do('UPDATE dbd_pg_test SET id = 1 WHERE id = 99'); ## Test UPDATE,INSERT, and DELETE with RETURNING SKIP: { if ($pgversion < 80200) { skip ('Cannot test RETURNING clause on pre 8.2 servers', 33); } $t='Statement handle attribute "NUM_OF_FIELDS" returns correct value for RETURNING updates'; $sth = $dbh->prepare('UPDATE dbd_pg_test SET id = 99 WHERE id = ? RETURNING id, expo, "CaseTest"'); $sth->execute(1); is_deeply ($sth->{'NUM_OF_FIELDS'}, 3, $t); $t='Statement handle attribute "NAME" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME'}, ['id','expo','CaseTest'], $t); $t='Statement handle attribute "NAME_lc" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_lc'}, ['id','expo','casetest'], $t); $t='Statement handle attribute "NAME_uc" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_uc'}, ['ID','EXPO','CASETEST'], $t); $t='Statement handle attribute "NAME_hash" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_hash'}, {id=>0, expo=>1, CaseTest=>2}, $t); $t='Statement handle attribute "NAME_lc_hash" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_lc_hash'}, {id=>0, expo=>1, casetest=>2}, $t); $t='Statement handle attribute "NAME_uc_hash" returns correct info for RETURNING updates'; is_deeply ($sth->{'NAME_uc_hash'}, {ID=>0, EXPO=>1, CASETEST=>2}, $t); $t='Statement handle attribute "TYPE" returns correct info for RETURNING updates'; is_deeply ($sth->{'TYPE'}, [4,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 "SCALE" returns correct info for RETURNING updates'; is_deeply ($sth->{'SCALE'}, [undef,2,undef], $t); $t='Statement handle attribute "NULLABLE" returns empty arrayref for updates'; is_deeply ($sth->{'NULLABLE'}, [0,1,1], $t); $dbh->do('UPDATE dbd_pg_test SET id = 1 WHERE id = 99'); $t='Statement handle attribute "NUM_OF_FIELDS" returns correct value for RETURNING inserts'; $sth = $dbh->prepare('INSERT INTO dbd_pg_test(id) VALUES(?) RETURNING id, lii, expo, "CaseTest"'); $sth->execute(88); is_deeply ($sth->{'NUM_OF_FIELDS'}, 4, $t); $t='Statement handle attribute "NAME" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME'}, ['id','lii','expo','CaseTest'], $t); $t='Statement handle attribute "NAME_lc" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_lc'}, ['id','lii','expo','casetest'], $t); $t='Statement handle attribute "NAME_uc" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_uc'}, ['ID','LII','EXPO','CASETEST'], $t); $t='Statement handle attribute "NAME_hash" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_hash'}, {id=>0, lii=>1, expo=>2, CaseTest=>3}, $t); $t='Statement handle attribute "NAME_lc_hash" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_lc_hash'}, {id=>0, lii=>1, expo=>2, casetest=>3}, $t); $t='Statement handle attribute "NAME_uc_hash" returns correct info for RETURNING inserts'; is_deeply ($sth->{'NAME_uc_hash'}, {ID=>0, LII=>1, EXPO=>2, CASETEST=>3}, $t); $t='Statement handle attribute "TYPE" returns correct info for RETURNING inserts'; is_deeply ($sth->{'TYPE'}, [4,4,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); # # Test of the statement handle attribute "ParamTypes" # $t='Statement handle attribute "ParamTypes" works before execute'; $sth = $dbh->prepare('SELECT id FROM dbd_pg_test WHERE id=? AND val=? AND lii=?'); $sth->bind_param(1, 1, SQL_INTEGER); $sth->bind_param(2, 'TMW', SQL_VARCHAR); $attrib = $sth->{ParamTypes}; $expected = {1 => {TYPE => SQL_INTEGER}, 2 => {TYPE => SQL_VARCHAR}, 3 => undef}; is_deeply ($attrib, $expected, $t); $t='Statement handle attributes "ParamValues" and "ParamTypes" can be pased back to bind_param'; eval { my $vals = $sth->{ParamValues}; my $types = $sth->{ParamTypes}; $sth->bind_param($_, $vals->{$_}, $types->{$_} ) for keys %$types; }; is( $@, q{}, $t); $t='Statement handle attribute "ParamTypes" works before execute with named placeholders'; $sth = $dbh->prepare('SELECT id FROM dbd_pg_test WHERE id=:foobar AND val=:foobar2 AND lii=:foobar3'); $sth->bind_param(':foobar', 1, {pg_type => PG_INT4}); $sth->bind_param(':foobar2', 'TMW', {pg_type => PG_TEXT}); $attrib = $sth->{ParamTypes}; $expected = {':foobar' => {TYPE => SQL_INTEGER}, ':foobar2' => {TYPE => SQL_LONGVARCHAR}, ':foobar3' => undef}; is_deeply ($attrib, $expected, $t); $t='Statement handle attributes "ParamValues" and "ParamTypes" can be passed back to bind_param'; eval { my $vals = $sth->{ParamValues}; my $types = $sth->{ParamTypes}; $sth->bind_param($_, $vals->{$_}, $types->{$_} ) for keys %$types; }; is( $@, q{}, $t); $t='Statement handle attribute "ParamTypes" works after execute'; $sth->bind_param(':foobar3', 3, {pg_type => PG_INT2}); $sth->execute(); $attrib = $sth->{ParamTypes}; $expected->{':foobar3'} = {TYPE => SQL_SMALLINT}; is_deeply ($attrib, $expected, $t); $t='Statement handle attribute "ParamTypes" returns correct values'; $sth->bind_param(':foobar2', 3, {pg_type => PG_CIRCLE}); $attrib = $sth->{ParamTypes}{':foobar2'}; $expected = {pg_type => PG_CIRCLE}; is_deeply ($attrib, $expected, $t); # # Test of the statement handle attribute "RowsInCache" # $t='Statement handle attribute "RowsInCache" returns undef'; $attrib = $sth->{RowsInCache}; is ($attrib, undef, $t); # # Test of the statement handle attribute "pg_size" # $t='Statement handle attribute "pg_size" works'; $SQL = q{SELECT id, pname, val, score, Fixed, pdate, "CaseTest" FROM dbd_pg_test}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->{pg_size}; $expected = [qw(4 -1 -1 8 -1 8 1)]; is_deeply ($result, $expected, $t); # # Test of the statement handle attribute "pg_type" # $t='Statement handle attribute "pg_type" works'; $sth->execute(); $result = $sth->{pg_type}; $expected = [qw(int4 varchar text float8 bpchar timestamp bool)]; is_deeply ($result, $expected, $t); $sth->finish(); # # Test of the statement handle attribute "pg_oid_status" # $t='Statement handle attribute "pg_oid_status" returned a numeric value after insert'; $SQL = q{INSERT INTO dbd_pg_test (id, val) VALUES (?, 'lemon')}; $sth = $dbh->prepare($SQL); $sth->bind_param('$1','',SQL_INTEGER); $sth->execute(500); $result = $sth->{pg_oid_status}; like ($result, qr/^\d+$/, $t); # # Test of the statement handle attribute "pg_cmd_status" # ## INSERT DELETE UPDATE SELECT for ( q{INSERT INTO dbd_pg_test (id,val) VALUES (400, 'lime')}, q{DELETE FROM dbd_pg_test WHERE id=1}, q{UPDATE dbd_pg_test SET id=2 WHERE id=2}, q{SELECT * FROM dbd_pg_test}, ) { $expected = substr($_,0,6); $t=qq{Statement handle attribute "pg_cmd_status" works for '$expected'}; $sth = $dbh->prepare($_); $sth->execute(); $result = $sth->{pg_cmd_status}; $sth->finish(); like ($result, qr/^$expected/, $t); } # # 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 -1 after a cancel}; $dbh->pg_cancel(); is ($sth->{pg_async_status}, -1, $t); $t=q{Database handle attribute "pg_async_status" returns a -1 after a cancel}; is ($dbh->{pg_async_status}, -1, $t); # # 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'; my $row = $sth->fetchrow_arrayref(); $attrib = $sth->{Active}; is ($attrib, 1, $t); $t='Statement handle attribute "Active" is false after finish called'; $sth->finish(); $attrib = $sth->{Active}; is ($attrib, '', $t); # # Test of the handle attribute "Executed" # my $dbh3 = connect_database({quickreturn => 1}); $dbh3->{AutoCommit} = 0; $t='Database handle attribute "Executed" begins false'; is ($dbh3->{Executed}, '', $t); $t='Database handle attribute "Executed" stays false after prepare()'; $sth = $dbh3->prepare('SELECT 12345'); is ($dbh3->{Executed}, '', $t); $t='Statement handle attribute "Executed" begins false'; is ($sth->{Executed}, '', $t); $t='Statement handle attribute "Executed" is true after execute()'; $sth->execute(); is ($sth->{Executed}, 1, $t); $t='Database handle attribute "Executed" is true after execute()'; is ($dbh3->{Executed}, 1, $t); $t='Statement handle attribute "Executed" is true after finish()'; $sth->finish(); is ($sth->{Executed}, 1, $t); $t='Database handle attribute "Executed" is true after finish()'; is ($dbh3->{Executed}, 1, $t); $t='Database handle attribute "Executed" is false after commit()'; $dbh3->commit(); is ($dbh3->{Executed}, '', $t); $t='Statement handle attribute "Executed" is true after commit()'; is ($sth->{Executed}, 1, $t); $t='Database handle attribute "Executed" is true after do()'; $dbh3->do('SELECT 1234'); is ($dbh3->{Executed}, 1, $t); $t='Database handle attribute "Executed" is false after rollback()'; $dbh3->commit(); is ($dbh3->{Executed}, '', $t); $t='Statement handle attribute "Executed" is true after rollback()'; is ($sth->{Executed}, 1, $t); # # 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 # We assume that older servers are okay my $client_level = ''; $sth = $dbh->prepare('SHOW client_min_messages'); $sth->execute(); $client_level = $sth->fetchall_arrayref()->[0][0]; $SQL = 'Testing the DBD::Pg modules error handling -?-'; if ($client_level eq 'error') { SKIP: { skip (q{Cannot test "PrintError" attribute because client_min_messages is set to 'error'}, 2); } SKIP: { skip (q{Cannot test "RaiseError" attribute because client_min_messages is set to 'error'}, 2); } SKIP: { skip (q{Cannot test "HandleError" attribute because client_min_messages is set to 'error'}, 2); } SKIP: { skip (q{Cannot test "HandleSetErr" attribute because client_min_messages is set to 'error'}, 3); } } else { { $warning = ''; local $SIG{__WARN__} = sub { $warning = shift; }; $dbh->{RaiseError} = 0; $t='Warning thrown when database handle attribute "PrintError" is on'; $dbh->{PrintError} = 1; $sth = $dbh->prepare($SQL); $sth->execute(); isnt ($warning, undef, $t); $t='No warning thrown when database handle attribute "PrintError" is off'; undef $warning; $dbh->{PrintError} = 0; $sth = $dbh->prepare($SQL); $sth->execute(); is ($warning, undef, $t); } } # # Test of the handle attribute RaiseError # if ($client_level ne 'error') { $t='No error produced when database handle attribute "RaiseError" is off'; $dbh->{RaiseError} = 0; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; is ($@, q{}, $t); $t='Error produced when database handle attribute "RaiseError" is off'; $dbh->{RaiseError} = 1; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; isnt ($@, q{}, $t); } # # Test of the handle attribute HandleError # $t='Database handle attribute "HandleError" is set properly'; $attrib = $dbh->{HandleError}; ok (!$attrib, $t); if ($client_level ne 'error') { $t='Database handle attribute "HandleError" works'; undef $warning; $dbh->{HandleError} = sub { $warning = shift; }; $sth = $dbh->prepare($SQL); $sth->execute(); ok ($warning, $t); $t='Database handle attribute "HandleError" modifies error messages'; undef $warning; $dbh->{HandleError} = sub { $_[0] = "Slonik $_[0]"; 0; }; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; like ($@, qr/^Slonik/, $t); $dbh->{HandleError}= undef; $dbh->rollback(); } # # Test of the handle attribute HandleSetErr # $t='Database handle attribute "HandleSetErr" is set properly'; $attrib = $dbh->{HandleSetErr}; ok (!$attrib, $t); if ($client_level ne 'error') { $t='Database handle attribute "HandleSetErr" works as expected'; undef $warning; $dbh->{HandleSetErr} = sub { my ($h,$err,$errstr,$state,$method) = @_; $_[1] = 42; $_[2] = 'ERRSTR'; $_[3] = '33133'; return; }; eval {$sth = $dbh->last_insert_id('cat', 'schema', 'table', 'col', ['notahashref']); }; ## Changing the state does not work yet. like ($@, qr{ERRSTR}, $t); is ($dbh->errstr, 'ERRSTR', $t); is ($dbh->err, '42', $t); $dbh->{HandleSetErr} = 0; $dbh->rollback(); } # # Test of the handle attribute "ErrCount" # $t='Database handle attribute "ErrCount" starts out at 0'; $dbh4 = connect_database({quickreturn => 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 "ShowErrorStatemnt" starts out false'; is ($dbh->{ShowErrorStatement}, '', $t); $SQL = 'Testing the ShowErrorStatement attribute'; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; $t='Database handle attribute "ShowErrorStatement" has no effect if not set'; unlike ($@, qr{for Statement "Testing}, $t); $dbh->{ShowErrorStatement} = 1; eval { $sth = $dbh->prepare($SQL); $sth->execute(); }; $t='Database handle attribute "ShowErrorStatement" adds statement to errors'; like ($@, qr{for Statement "Testing}, $t); $SQL = q{SELECT 'Another ShowErrorStatement Test' FROM pg_class WHERE relname = ? AND reltuples = ?}; eval { $sth = $dbh->prepare($SQL); $sth->execute(123); }; $t='Database handle attribute "ShowErrorStatement" adds statement and placeholders to errors'; like ($@, qr{with ParamValues}, $t); $SQL = q{SELECT 'Another ShowErrorStatement Test' FROM pg_class WHERE relname = ? AND reltuples = ?}; eval { $sth = $dbh->prepare($SQL); $sth->execute(123,456); }; $t='Database handle attribute "ShowErrorStatement" adds statement and placeholders to errors'; like ($@, qr{with ParamValues: 1='123', 2='456'}, $t); $dbh->commit(); # # Test of the handle attribute TraceLevel # $t='Database handle attribute "TraceLevel" returns a number'; $attrib = $dbh->{TraceLevel}; like ($attrib, qr/^\d$/, $t); # # Test of the handle attribute FetchHashKeyName # # The default is mixed case ("NAME"); $t='Database handle attribute "FetchHashKeyName" is set properly'; $attrib = $dbh->{FetchHashKeyName}; is ($attrib, 'NAME', $t); $t='Database handle attribute "FetchHashKeyName" works with the default value of NAME'; $SQL = q{SELECT "CaseTest" FROM dbd_pg_test}; $sth = $dbh->prepare($SQL); $sth->execute(); my ($colname) = keys %{$sth->fetchrow_hashref()}; $sth->finish(); is ($colname, 'CaseTest', $t); $t='Database handle attribute "FetchHashKeyName" can be changed'; $dbh->{FetchHashKeyName} = 'NAME_lc'; $attrib = $dbh->{FetchHashKeyName}; is ($attrib, 'NAME_lc', $t); $t='Database handle attribute "FetchHashKeyName" works with a value of NAME_lc'; $sth = $dbh->prepare($SQL); $sth->execute(); ($colname) = keys %{$sth->fetchrow_hashref()}; is ($colname, 'casetest', $t); $sth->finish(); $t='Database handle attribute "FetchHashKeyName" works with a value of NAME_uc'; $dbh->{FetchHashKeyName} = 'NAME_uc'; $sth = $dbh->prepare($SQL); $sth->execute(); ($colname) = keys %{$sth->fetchrow_hashref()}; $sth->finish(); $dbh->{FetchHashKeyName} = 'NAME'; is ($colname, 'CASETEST', $t); # # Test of the handle attribute ChopBlanks # $t='Database handle attribute "ChopBlanks" is set properly'; $attrib = $dbh->{ChopBlanks}; ok (!$attrib, $t); $dbh->do('DELETE FROM dbd_pg_test'); $dbh->do(q{INSERT INTO dbd_pg_test (id, fixed, val) VALUES (3, ' Fig', ' Raspberry ')}); $t='Database handle attribute "ChopBlanks" = 0 returns correct value for fixed-length column'; $dbh->{ChopBlanks} = 0; my ($val) = $dbh->selectall_arrayref(q{SELECT fixed FROM dbd_pg_test WHERE id = 3})->[0][0]; is ($val, ' Fig ', $t); $t='Database handle attribute "ChopBlanks" = 0 returns correct value for variable-length column'; ($val) = $dbh->selectrow_array(q{SELECT val FROM dbd_pg_test WHERE id = 3}); is ($val, ' Raspberry ', $t); $t='Database handle attribute "ChopBlanks" = 1 returns correct value for fixed-length column'; $dbh->{ChopBlanks}=1; ($val) = $dbh->selectall_arrayref(q{SELECT fixed FROM dbd_pg_test WHERE id = 3})->[0][0]; is ($val, ' Fig', $t); $t='Database handle attribute "ChopBlanks" = 1 returns correct value for variable-length column'; ($val) = $dbh->selectrow_array(q{SELECT val FROM dbd_pg_test WHERE id = 3}); $dbh->do('DELETE from dbd_pg_test'); is ($val, ' Raspberry ', $t); # # Test of the handle attribute LongReadLen # $t='Handle attribute "LongReadLen" has been set properly'; $attrib = $dbh->{LongReadLen}; ok ($attrib, $t); # # Test of the handle attribute LongTruncOk # $t='Handle attribute "LongTruncOk" has been set properly'; $attrib = $dbh->{LongTruncOk}; ok (!$attrib, $t); # # Test of the handle attribute TaintIn # $t='Handle attribute "TaintIn" has been set properly'; $attrib = $dbh->{TaintIn}; is ($attrib, '', $t); # # Test of the handle attribute TaintOut # $t='Handle attribute "TaintOut" has been set properly'; $attrib = $dbh->{TaintOut}; is ($attrib, '', $t); # # Test of the handle attribute Taint # $t='Handle attribute "Taint" has been set properly'; $attrib = $dbh->{Taint}; is ($attrib, '', $t); $t='The value of handle attribute "Taint" can be changed'; $dbh->{Taint}=1; $attrib = $dbh->{Taint}; is ($attrib, 1, $t); $t='Changing handle attribute "Taint" changes "TaintIn"'; $attrib = $dbh->{TaintIn}; is ($attrib, 1, $t); $t='Changing handle attribute "Taint" changes "TaintOut"'; $attrib = $dbh->{TaintOut}; is ($attrib, 1, $t); # # Not tested: handle attribute Profile # # # Test of the database handle attribute "ReadOnly" # SKIP: { if ($DBI::VERSION < 1.55) { skip ('DBI must be at least version 1.55 to test DB attribute "ReadOnly"', 8); } $t='Database handle attribute "ReadOnly" starts out undefined'; $dbh->commit(); ## This fails on some boxes, so we pull back all information to display why my ($helpconnect2, $connerror2); ($helpconnect2, $connerror2, $dbh4) = connect_database(); if (! defined $dbh4) { die "Database connection failed: helpconnect is $helpconnect2, error is $connerror2\n"; } $dbh4->trace(0); is ($dbh4->{ReadOnly}, undef, $t); $t='Database handle attribute "ReadOnly" allows SELECT queries to work when on'; $dbh4->{ReadOnly} = 1; $result = $dbh4->selectall_arrayref('SELECT 12345')->[0][0]; is ($result, 12345, $t); $t='Database handle attribute "ReadOnly" prevents INSERT queries from working when on'; $SQL = 'INSERT INTO dbd_pg_test (id) VALUES (50)'; eval { $dbh4->do($SQL); }; is($dbh4->state, '25006', $t); $dbh4->rollback(); $sth = $dbh4->prepare($SQL); eval { $sth->execute(); }; is($dbh4->state, '25006', $t); $dbh4->rollback(); $t='Database handle attribute "ReadOnly" allows INSERT queries when switched off'; $dbh4->{ReadOnly} = 0; eval { $dbh4->do($SQL); }; is ($@, q{}, $t); $dbh4->rollback(); $t='Database handle attribute "ReadOnly" allows INSERT queries when switched off'; $dbh4->{ReadOnly} = 0; eval { $dbh4->do($SQL); }; is ($@, q{}, $t); $dbh4->rollback(); $dbh4->{ReadOnly} = 1; $dbh4->{AutoCommit} = 1; $t='Database handle attribute "ReadOnly" has no effect if AutoCommit is on'; eval { $dbh4->do($SQL); }; is ($@, q{}, $t); my $delete = 'DELETE FROM dbd_pg_test WHERE id = 50'; $dbh4->do($delete); $sth = $dbh4->prepare($SQL); eval { $sth->execute(); }; is ($@, q{}, $t); $dbh4->disconnect(); } # # Test of the database handle attribute InactiveDestroy # This one must be the last test performed! # $t='Database handle attribute "InactiveDestroy" is set properly'; $attrib = $dbh->{InactiveDestroy}; ok (!$attrib, $t); # Disconnect in preparation for the fork tests ok ($dbh->disconnect(), 'Disconnect from database'); $t='Database handle attribute "Active" is false after disconnect'; $attrib = $dbh->{Active}; is ($attrib, '', $t); SKIP: { skip ('Cannot test database handle "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.7.0/t/03dbmethod.t0000644000175000017500000020104713111010135013457 0ustar greggreg#!perl ## Test of the database handle methods ## The following methods are *not* (explicitly) tested here: ## "take_imp_data" "pg_server_trace" "pg_server_untrace" "pg_type_info" ## "data_sources" (see 04misc.t) ## "disconnect" (see 01connect.t) ## "pg_savepoint" "pg_release" "pg_rollback_to" (see 20savepoints.t) ## "pg_getline" "pg_endcopy" "pg_getcopydata" "pg_getcopydata_async" (see 07copy.t) ## "pg_putline" "pg_putcopydata" "pg_putcopydata_async (see 07copy.t) ## "pg_cancel" "pg_ready" "pg_result" (see 08async.t) use 5.006; use strict; use warnings; use Data::Dumper; use Test::More; use DBI ':sql_types'; use DBD::Pg ':pg_types'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 562; isnt ($dbh, undef, 'Connect to database for database handle method testing'); my ($pglibversion,$pgversion) = ($dbh->{pg_lib_version},$dbh->{pg_server_version}); my ($schema,$schema2,$schema3) = ('dbd_pg_testschema', 'dbd_pg_testschema2', 'dbd_pg_testschema3'); my ($table1,$table2,$table3) = ('dbd_pg_test1','dbd_pg_test2','dbd_pg_test3'); my ($sequence2,$sequence3,$sequence4) = ('dbd_pg_testsequence2','dbd_pg_testsequence3','dbd_pg_testsequence4'); my ($SQL, $sth, $result, @result, $expected, $warning, $rows, $t, $info); # Quick simple "tests" $dbh->do(q{}); ## This used to break, so we keep it as a test... $SQL = q{SELECT '2529DF6AB8F79407E94445B4BC9B906714964AC8' FROM dbd_pg_test WHERE id=?}; $sth = $dbh->prepare($SQL); $sth->finish(); $sth = $dbh->prepare_cached($SQL); $sth->finish(); # Populate the testing table for later use $SQL = 'INSERT INTO dbd_pg_test(id,val) VALUES (?,?)'; $sth = $dbh->prepare($SQL); $sth->bind_param(1, 1, SQL_INTEGER); $sth->execute(10,'Roseapple'); $sth->execute(11,'Pineapple'); $sth->execute(12,'Kiwi'); # # Test of the "last_insert_id" database handle method # $t='DB handle method "last_insert_id" fails when no arguments are given'; $dbh->commit(); eval { $dbh->last_insert_id(undef,undef,undef,undef); }; like ($@, qr{last_insert_id.*least}, $t); $t='DB handle method "last_insert_id" fails when given a non-existent sequence'; eval { $dbh->last_insert_id(undef,undef,undef,undef,{sequence=>'dbd_pg_nonexistentsequence_test'}); }; is ($dbh->state, '42P01', $t); $t='DB handle method "last_insert_id" fails when given a non-existent table'; $dbh->rollback(); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef); }; like ($@, qr{not find}, $t); $t='DB handle method "last_insert_id" fails when given an arrayref as last argument'; $dbh->rollback(); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef,[]); }; like ($@, qr{last_insert_id.*hashref}, $t); $t='DB handle method "last_insert_id" works when given an empty sequence argument'; $dbh->rollback(); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef,{sequence=>''}); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" fails when given a table with no primary key'; $dbh->rollback(); $dbh->do('CREATE TEMP TABLE dbd_pg_test_temp(a int)'); eval { $dbh->last_insert_id(undef,undef,'dbd_pg_test_temp',undef); }; like ($@, qr{last_insert_id}, $t); $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] = 'asasa'; eval { $dbh->do('INSERT INTO foobar (p) VALUES (?)', undef, \@aa); }; is ($@, q{}, $t); $SQL = 'SELECT * FROM foobar'; $result = $dbh->selectall_arrayref($SQL)->[0]; is_deeply ($result, [undef,[undef,undef,'asasa']], $t); $t='DB handle method "last_insert_id" works when given a valid sequence and an invalid table'; $dbh->rollback(); eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef,{sequence=>'dbd_pg_testsequence'}); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" returns a numeric value'; like ($result, qr{^\d+$}, $t); $t='DB handle method "last_insert_id" works when given a valid sequence and an invalid table'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_nonexistenttable_test',undef, 'dbd_pg_testsequence'); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" returns a numeric value'; like ($result, qr{^\d+$}, $t); $t='DB handle method "last_insert_id" works when given a valid table'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" works when given an empty attrib'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef,''); }; is ($@, q{}, $t); $t='DB handle method "last_insert_id" works when called twice (cached) given a valid table'; eval { $result = $dbh->last_insert_id(undef,undef,'dbd_pg_test',undef); }; is ($@, q{}, $t); $dbh->do("CREATE SCHEMA $schema2"); $dbh->do("CREATE SEQUENCE $schema2.$sequence2"); $dbh->do("CREATE SEQUENCE $schema.$sequence4"); $dbh->{Warn} = 0; $dbh->do("CREATE TABLE $schema2.$table2(a INTEGER PRIMARY KEY NOT NULL DEFAULT nextval('$schema2.$sequence2'))"); $dbh->do("CREATE TABLE $schema.$table2(a INTEGER PRIMARY KEY NOT NULL DEFAULT nextval('$schema.$sequence4'))"); $dbh->{Warn} = 1; $dbh->do("INSERT INTO $schema2.$table2 DEFAULT VALUES"); $t='DB handle method "last_insert_id" works when called with a schema not in the search path'; eval { $result = $dbh->last_insert_id(undef,$schema2,$table2,undef); }; is ($@, q{}, $t); $t='search_path respected when using last_insert_id with no cache (first table)'; $dbh->commit(); $dbh->do("SELECT setval('$schema2.$sequence2',200)"); $dbh->do("SELECT setval('$schema.$sequence4',100)"); $dbh->do("SET search_path = $schema,$schema2"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef,{pg_cache=>0}); }; is ($@, q{}, $t); is ($result, 100, $t); $t='search_path respected when using last_insert_id with no cache (second table)'; $dbh->commit(); $dbh->do("SET search_path = $schema2,$schema"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef,{pg_cache=>0}); }; is ($@, q{}, $t); is ($result, 200, $t); $t='Setting cache on (explicit) returns last result, even if search_path changes'; $dbh->do("SET search_path = $schema,$schema2"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef,{pg_cache=>1}); }; is ($@, q{}, $t); is ($result, 200, $t); $t='Setting cache on (implicit) returns last result, even if search_path changes'; $dbh->do("SET search_path = $schema,$schema2"); eval { $result = $dbh->last_insert_id(undef,undef,$table2,undef); }; is ($@, q{}, $t); is ($result, 200, $t); $dbh->commit(); SKIP: { $t='DB handle method "last_insert_id" fails when the sequence name is changed and cache is used'; if ($pgversion < 80300) { $dbh->do("DROP TABLE $schema2.$table2"); $dbh->do("DROP SEQUENCE $schema2.$sequence2"); skip ('Cannot test sequence rename on pre-8.3 servers', 2); } $dbh->do("ALTER SEQUENCE $schema2.$sequence2 RENAME TO $sequence3"); $dbh->commit(); eval { $dbh->last_insert_id(undef,$schema2,$table2,undef); }; like ($@, qr{last_insert_id}, $t); $dbh->rollback(); $t='DB handle method "last_insert_id" works when the sequence name is changed and cache is turned off'; $dbh->commit(); eval { $dbh->last_insert_id(undef,$schema2,$table2,undef, {pg_cache=>0}); }; is ($@, q{}, $t); $dbh->do("DROP TABLE $schema2.$table2"); $dbh->do("DROP SEQUENCE $schema2.$sequence3"); } $dbh->do("DROP SCHEMA $schema2"); $dbh->do("DROP TABLE $table2"); $dbh->do("DROP SEQUENCE $sequence4"); # # Test of the "selectrow_array" database handle method # $t='DB handle method "selectrow_array" works'; $SQL = 'SELECT id FROM dbd_pg_test ORDER BY id'; @result = $dbh->selectrow_array($SQL); $expected = [10]; is_deeply (\@result, $expected, $t); # # Test of the "selectrow_arrayref" database handle method # $t='DB handle method "selectrow_arrayref" works'; $result = $dbh->selectrow_arrayref($SQL); is_deeply ($result, $expected, $t); $t='DB handle method "selectrow_arrayref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectrow_arrayref($sth); is_deeply ($result, $expected, $t); # # Test of the "selectrow_hashref" database handle method # $t='DB handle method "selectrow_hashref" works'; $result = $dbh->selectrow_hashref($SQL); $expected = {id => 10}; is_deeply ($result, $expected, $t); $t='DB handle method "selectrow_hashref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectrow_hashref($sth); is_deeply ($result, $expected, $t); # # Test of the "selectall_arrayref" database handle method # $t='DB handle method "selectall_arrayref" works'; $result = $dbh->selectall_arrayref($SQL); $expected = [[10],[11],[12]]; is_deeply ($result, $expected, $t); $t='DB handle method "selectall_arrayref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectall_arrayref($sth); is_deeply ($result, $expected, $t); $t='DB handle method "selectall_arrayref" works with the MaxRows attribute'; $result = $dbh->selectall_arrayref($SQL, {MaxRows => 2}); $expected = [[10],[11]]; is_deeply ($result, $expected, $t); $t='DB handle method "selectall_arrayref" works with the Slice attribute'; $SQL = 'SELECT id, val FROM dbd_pg_test ORDER BY id'; $result = $dbh->selectall_arrayref($SQL, {Slice => [1]}); $expected = [['Roseapple'],['Pineapple'],['Kiwi']]; is_deeply ($result, $expected, $t); # # Test of the "selectall_hashref" database handle method # $t='DB handle method "selectall_hashref" works'; $result = $dbh->selectall_hashref($SQL,'id'); $expected = {10=>{id =>10,val=>'Roseapple'},11=>{id=>11,val=>'Pineapple'},12=>{id=>12,val=>'Kiwi'}}; is_deeply ($result, $expected, $t); $t='DB handle method "selectall_hashref" works with a prepared statement handle'; $sth = $dbh->prepare($SQL); $result = $dbh->selectall_hashref($sth,'id'); is_deeply ($result, $expected, $t); # # Test of the "selectcol_arrayref" database handle method # $t='DB handle method "selectcol_arrayref" works'; $result = $dbh->selectcol_arrayref($SQL); $expected = [10,11,12]; is_deeply ($result, $expected, $t); $t='DB handle method "selectcol_arrayref" works with a prepared statement handle'; $result = $dbh->selectcol_arrayref($sth); is_deeply ($result, $expected, $t); $t='DB handle method "selectcol_arrayref" works with the Columns attribute'; $result = $dbh->selectcol_arrayref($SQL, {Columns=>[2,1]}); $expected = ['Roseapple',10,'Pineapple',11,'Kiwi',12]; is_deeply ($result, $expected, $t); $t='DB handle method "selectcol_arrayref" works with the MaxRows attribute'; $result = $dbh->selectcol_arrayref($SQL, {Columns=>[2], MaxRows => 1}); $expected = ['Roseapple']; is_deeply ($result, $expected, $t); # # Test of the "commit" and "rollback" database handle methods # { local $SIG{__WARN__} = sub { $warning = shift; }; $dbh->{AutoCommit}=0; $t='DB handle method "commit" gives no warning when AutoCommit is off'; $warning=q{}; $dbh->commit(); ok (! length $warning, $t); $t='DB handle method "rollback" gives no warning when AutoCommit is off'; $warning=q{}; $dbh->rollback(); ok (! length $warning, $t); $t='DB handle method "commit" returns true'; ok ($dbh->commit, $t); $t='DB handle method "rollback" returns true'; ok ($dbh->rollback, $t); $t='DB handle method "commit" gives a warning when AutoCommit is on'; $dbh->{AutoCommit}=1; $warning=q{}; $dbh->commit(); ok (length $warning, $t); $t='DB handle method "rollback" gives a warning when AutoCommit is on'; $warning=q{}; $dbh->rollback(); ok (length $warning, $t); } # # Test of the "begin_work" database handle method # $t='DB handle method "begin_work" gives a warning when AutoCommit is on'; $dbh->{AutoCommit}=0; eval { $dbh->begin_work(); }; isnt ($@, q{}, $t); $t='DB handle method "begin_work" gives no warning when AutoCommit is off'; $dbh->{AutoCommit}=1; eval { $dbh->begin_work(); }; is ($@, q{}, $t); ok (!$dbh->{AutoCommit}, 'DB handle method "begin_work" sets AutoCommit to off'); $t='DB handle method "commit" after "begin_work" sets AutoCommit to on'; $dbh->commit(); ok ($dbh->{AutoCommit}, $t); $t='DB handle method "begin_work" gives no warning when AutoCommit is off'; $dbh->{AutoCommit}=1; eval { $dbh->begin_work(); }; is ($@, q{}, $t); $t='DB handle method "begin_work" sets AutoCommit to off'; ok (!$dbh->{AutoCommit}, $t); $t='DB handle method "rollback" after "begin_work" sets AutoCommit to on'; $dbh->rollback(); ok ($dbh->{AutoCommit}, $t); $dbh->{AutoCommit}=0; # # Test of the "get_info" database handle method # $t='DB handle method "get_info" with no arguments gives an error'; eval { $dbh->get_info(); }; isnt ($@, q{}, $t); my %get_info = ( SQL_MAX_DRIVER_CONNECTIONS => 0, SQL_DRIVER_NAME => 6, SQL_DBMS_NAME => 17, SQL_DBMS_VERSION => 18, SQL_IDENTIFIER_QUOTE_CHAR => 29, SQL_CATALOG_NAME_SEPARATOR => 41, SQL_USER_NAME => 47, # 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]\d|\d[1-9])\.\d\d\.\d\d00$}, $t); # Testing max connections is good as this info is dynamic $t='DB handle method "get_info" returns a number for SQL_MAX_DRIVER_CONNECTIONS'; my $maxcon = $dbh->get_info('SQL_MAX_DRIVER_CONNECTIONS'); like ($maxcon, qr{^\d+$}, $t); $t='DB handle method "get_info" returns correct string for SQL_DATA_SOURCE_READ_ONLY when "on"'; $dbh->do(q{SET transaction_read_only = 'on'}); is ($dbh->get_info(25), 'Y', $t); $t='DB handle method "get_info" returns correct string for SQL_DATA_SOURCE_READ_ONLY when "off"'; ## Recent versions of Postgres are very fussy: must rollback $dbh->rollback(); $dbh->do(q{SET transaction_read_only = 'off'}); is ($dbh->get_info(25), 'N', $t); # # Test of the "table_info" database handle method # $t='DB handle method "table_info" works when called with empty arguments'; $sth = $dbh->table_info('', '', 'dbd_pg_test', ''); my $number = $sth->rows(); ok ($number, $t); $t='DB handle method "table_info" works when called with \'%\' arguments'; $sth = $dbh->table_info('%', '%', 'dbd_pg_test', '%'); $number = $sth->rows(); ok ($number, $t); $t=q{DB handle method "table_info" works when called with a 'TABLE' last argument}; $sth = $dbh->table_info( '', '', '', 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}, undef, 'DB handle method "table_info" returns proper TABLE_CAT'); is ($result->{TABLE_NAME}, 'dbd_pg_test', 'DB handle method "table_info" returns proper TABLE_NAME'); is ($result->{TABLE_TYPE}, 'TABLE', 'DB handle method "table_info" returns proper TABLE_TYPE'); $t=q{DB handle method "table_info" returns correct number of rows when given a 'TABLE,VIEW' type argument}; $sth = $dbh->table_info(undef,undef,undef,'TABLE,VIEW'); $number = $sth->rows(); cmp_ok ($number, '>', 1, $t); $t=q{DB handle method "table_info" returns correct number of 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'); $number = $sth->rows(); cmp_ok ($number, '>', 1, $t); $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 correct number of rows when given a 'VIEW' type argument}; $sth = $dbh->table_info(undef,undef,undef,'VIEW'); $rows = $sth->rows(); cmp_ok ($rows, '<', $number, $t); $t=q{DB handle method "table_info" returns correct number of rows when given a 'TABLE' type argument}; $sth = $dbh->table_info(undef,undef,undef,'TABLE'); $rows = $sth->rows(); cmp_ok ($rows, '<', $number, $t); $dbh->do('CREATE TEMP TABLE dbd_pg_local_temp (i INT)'); $t=q{DB handle method "table_info" returns correct number of rows when given a 'LOCAL TEMPORARY' type argument}; $sth = $dbh->table_info(undef,undef,undef,'LOCAL TEMPORARY'); $rows = $sth->rows(); cmp_ok ($rows, '<', $number, $t); cmp_ok ($rows, '>', 0, $t); $t=q{DB handle method "table_info" returns correct number of rows when given a 'MATERIALIZED VIEW' type argument}; $sth = $dbh->table_info(undef,undef,undef,'MATERIALIZED VIEW'); $rows = $sth->rows(); is ($rows, 0, $t); SKIP: { if ($pgversion < 90300) { skip 'Postgres version 9.3 or better required to create materialized views', 1; } $dbh->do('CREATE MATERIALIZED VIEW dbd_pg_matview (a) AS SELECT count(*) FROM pg_class'); $t=q{DB handle method "table_info" returns correct number of rows when given a 'MATERIALIZED VIEW' type argument}; $sth = $dbh->table_info(undef,undef,undef,'MATERIALIZED VIEW'); $rows = $sth->rows(); is ($rows, 1, $t); } # Test listing catalog names $t='DB handle method "table_info" works when called with a catalog of %'; $sth = $dbh->table_info('%', '', ''); ok ($sth, $t); # Test listing schema names $t='DB handle method "table_info" works when called with a schema of %'; $sth = $dbh->table_info('', '%', ''); ok ($sth, $t); { # Test listing table types my @expected = ('LOCAL TEMPORARY', 'SYSTEM TABLE', 'SYSTEM VIEW', 'MATERIALIZED VIEW', 'SYSTEM MATERIALIZED VIEW', '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 # # Test of the "column_info" database handle method # # Check required minimum fields $t='DB handle method "column_info" returns fields required by DBI'; $sth = $dbh->column_info('','','dbd_pg_test','score'); $result = $sth->fetchall_arrayref({}); @required = (qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE REMARKS COLUMN_DEF SQL_DATA_TYPE SQL_DATETIME_SUB CHAR_OCTET_LENGTH ORDINAL_POSITION IS_NULLABLE)); undef %missing; for my $r (@$result) { for (@required) { $missing{$_}++ if ! exists $r->{$_}; } } is_deeply (\%missing, {}, $t); # Check that pg_constraint was populated $t=q{DB handle method "column info" 'pg_constraint' returns a value for constrained columns}; $result = $result->[0]; like ($result->{pg_constraint}, qr/score/, $t); # Check that it is not populated for non-constrained columns $t=q{DB handle method "column info" 'pg_constraint' returns undef for non-constrained columns}; $sth = $dbh->column_info('','','dbd_pg_test','id'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{pg_constraint}, undef, $t); # Check the rest of the custom "pg" columns $t=q{DB handle method "column_info" returns good value for 'pg_type'}; is ($result->{pg_type}, 'integer', $t); ## Check some of the returned fields: my $r = $result; is ($r->{TABLE_CAT}, undef, 'DB handle method "column_info" returns proper TABLE_CAT'); is ($r->{TABLE_NAME}, 'dbd_pg_test', 'DB handle method "column_info returns proper TABLE_NAME'); is ($r->{COLUMN_NAME}, 'id', 'DB handle method "column_info" returns proper COLUMN_NAME'); is ($r->{DATA_TYPE}, 4, 'DB handle method "column_info" returns proper DATA_TYPE'); is ($r->{COLUMN_SIZE}, 4, 'DB handle method "column_info" returns proper COLUMN_SIZE'); is ($r->{NULLABLE}, '0', 'DB handle method "column_info" returns proper NULLABLE'); is ($r->{REMARKS}, 'Bob is your uncle', 'DB handle method "column_info" returns proper REMARKS'); is ($r->{COLUMN_DEF}, undef, 'DB handle method "column_info" returns proper COLUMN_DEF'); is ($r->{IS_NULLABLE}, 'NO', 'DB handle method "column_info" returns proper IS_NULLABLE'); is ($r->{pg_type}, 'integer', 'DB handle method "column_info" returns proper pg_type'); is ($r->{ORDINAL_POSITION}, 1, 'DB handle method "column_info" returns proper ORDINAL_POSITION'); # Make sure we handle CamelCase Column Correctly $t=q{DB handle method "column_info" works with non-lowercased columns}; $sth = $dbh->column_info('','','dbd_pg_test','CaseTest'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{COLUMN_NAME}, q{"CaseTest"}, $t); SKIP: { if ($pgversion < 80300) { skip ('DB handle method column_info attribute "pg_enum_values" requires at least Postgres 8.3', 2); } my @enumvalues = qw( foo bar baz buz ); { local $dbh->{Warn} = 0; $dbh->do( q{CREATE TYPE dbd_pg_enumerated AS ENUM ('foo', 'bar', 'baz', 'buz')} ); $dbh->do( q{CREATE TEMP TABLE dbd_pg_enum_test ( is_enum dbd_pg_enumerated NOT NULL )} ); if ($pgversion >= 90300) { $dbh->do( q{ALTER TYPE dbd_pg_enumerated ADD VALUE 'first' BEFORE 'foo'} ); unshift @enumvalues, 'first'; } } $t='DB handle method "column_info" returns proper pg_type'; $sth = $dbh->column_info('','','dbd_pg_enum_test','is_enum'); $result = $sth->fetchall_arrayref({})->[0]; is ($result->{pg_type}, 'dbd_pg_enumerated', $t); $t='DB handle method "column_info" returns proper pg_enum_values'; is_deeply ($result->{pg_enum_values}, \@enumvalues, $t); $dbh->do('DROP TABLE dbd_pg_enum_test'); $dbh->do('DROP TYPE dbd_pg_enumerated'); } # # Test of the "primary_key_info" database handle method # # Check required minimum fields $t='DB handle method "primary_key_info" returns required fields'; $sth = $dbh->primary_key_info('','','dbd_pg_test'); $result = $sth->fetchall_arrayref({}); @required = (qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME DATA_TYPE)); undef %missing; for my $r (@$result) { for (@required) { $missing{$_}++ if ! exists $r->{$_}; } } is_deeply (\%missing, {}, $t); ## Check some of the returned fields: $r = $result->[0]; is ($r->{TABLE_CAT}, undef, 'DB handle method "primary_key_info" returns proper TABLE_CAT'); is ($r->{TABLE_NAME}, 'dbd_pg_test', 'DB handle method "primary_key_info" returns proper TABLE_NAME'); is ($r->{COLUMN_NAME}, 'id', 'DB handle method "primary_key_info" returns proper COLUMN_NAME'); is ($r->{PK_NAME}, 'dbd_pg_test_pkey', 'DB handle method "primary_key_info" returns proper PK_NAME'); is ($r->{DATA_TYPE}, 'int4', 'DB handle method "primary_key_info" returns proper DATA_TYPE'); is ($r->{KEY_SEQ}, 1, 'DB handle method "primary_key_info" returns proper KEY_SEQ'); # # Test of the "primary_key" database handle method # $t='DB handle method "primary_key" works'; @result = $dbh->primary_key('', '', 'dbd_pg_test'); $expected = ['id']; is_deeply (\@result, $expected, $t); $t='DB handle method "primary_key" returns empty list for invalid table'; @result = $dbh->primary_key('', '', 'dbd_pg_test_do_not_create_this_table'); $expected = []; is_deeply (\@result, $expected, $t); # # Test of the "statistics_info" database handle method # SKIP: { $dbh->{private_dbdpg}{version} >= 80000 or skip ('Server must be version 8.0 or higher to test database handle method "statistics_info"', 10); $t='DB handle method "statistics_info" returns undef: no table'; $sth = $dbh->statistics_info(undef,undef,undef,undef,undef); is ($sth, undef, $t); ## Invalid table $t='DB handle method "statistics_info" returns undef: bad table'; $sth = $dbh->statistics_info(undef,undef,'dbd_pg_test9',undef,undef); is ($sth, undef, $t); ## Create some tables with various indexes { local $SIG{__WARN__} = sub {}; ## Drop the third schema $dbh->do("DROP SCHEMA IF EXISTS $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)"); $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(c,(a+b))"); $dbh->do("CREATE TABLE $table3 (a INT, b INT, c INT, PRIMARY KEY(a)) WITH OIDS"); $dbh->do("CREATE UNIQUE INDEX dbd_pg_test3_index_b ON $table3(b)"); $dbh->do("CREATE INDEX dbd_pg_test3_index_c ON $table3 USING hash(c)"); $dbh->do("CREATE INDEX dbd_pg_test3_oid ON $table3(oid)"); $dbh->do("CREATE UNIQUE INDEX dbd_pg_test3_pred ON $table3(c) WHERE c > 0 AND c < 45"); $dbh->commit(); } my $correct_stats = { one => [ [ undef, $schema, $table1, undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef, undef ], [ undef, $schema, $table1, '0', undef, 'dbd_pg_test1_index_c', 'btree', 1, 'c', 'A', '0', '1', undef, 'c' ], [ undef, $schema, $table1, '0', undef, 'dbd_pg_test1_pk', 'btree', 1, 'a', 'A', '0', '1', undef, 'a' ], [ undef, $schema, $table1, '0', undef, 'dbd_pg_test1_uc1', 'btree', 1, 'b', 'A', '0', '1', undef, 'b' ], ], two => [ [ undef, $schema, $table2, undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef, undef ], [ undef, $schema, $table2, '0', undef, 'dbd_pg_test2_b_key', 'btree', 1, 'b', 'A', '0', '1', undef, 'b' ], [ undef, $schema, $table2, '0', undef, 'dbd_pg_test2_b_key', 'btree', 2, 'c', 'A', '0', '1', undef, 'c' ], [ undef, $schema, $table2, '0', undef, 'dbd_pg_test2_pkey', 'btree', 1, 'a', 'A', '0', '1', undef, 'a' ], [ undef, $schema, $table2, '0', undef, 'dbd_pg_test2_pkey', 'btree', 2, 'b', 'A', '0', '1', undef, 'b' ], [ undef, $schema, $table2, '1', undef, 'dbd_pg_test2_expr', 'btree', 1, 'c', 'A', '0', '1', undef, 'c' ], [ undef, $schema, $table2, '1', undef, 'dbd_pg_test2_expr', 'btree', 2, undef, 'A', '0', '1', undef, '(a + b)' ], ], three => [ [ undef, $schema, $table3, undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef, undef ], [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_index_b', 'btree', 1, 'b', 'A', '0', '1', undef, 'b' ], [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_pkey', 'btree', 1, 'a', 'A', '0', '1', undef, 'a' ], [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_pred', 'btree', 1, 'c', 'A', '0', '1', '((c > 0) AND (c < 45))', 'c' ], [ undef, $schema, $table3, '1', undef, 'dbd_pg_test3_oid', 'btree', 1, 'oid', 'A', '0', '1', undef, 'oid' ], [ undef, $schema, $table3, '1', undef, 'dbd_pg_test3_index_c', 'hashed', 1, 'c', 'A', '0', '4', undef, 'c' ], ], three_uo => [ [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_index_b', 'btree', 1, 'b', 'A', '0', '1', undef, 'b' ], [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_pkey', 'btree', 1, 'a', 'A', '0', '1', undef, 'a' ], [ undef, $schema, $table3, '0', undef, 'dbd_pg_test3_pred', 'btree', 1, 'c', 'A', '0', '1', '((c > 0) AND (c < 45))', 'c' ], ], }; ## Make some per-version tweaks ## 8.5 changed the way foreign key names are generated if ($pgversion >= 80500) { $correct_stats->{two}[1][5] = $correct_stats->{two}[2][5] = 'dbd_pg_test2_b_c_key'; } my $stats; $t="Correct stats output for $table1"; $sth = $dbh->statistics_info(undef,$schema,$table1,undef,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{one}, $t); $t="Correct stats output for $table2"; $sth = $dbh->statistics_info(undef,$schema,$table2,undef,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{two}, $t); $t="Correct stats output for $table3"; $sth = $dbh->statistics_info(undef,$schema,$table3,undef,undef); $stats = $sth->fetchall_arrayref; ## Too many intra-version differences to try for an exact number here: $correct_stats->{three}[5][11] = $stats->[5][11] = 0; is_deeply ($stats, $correct_stats->{three}, $t); $t="Correct stats output for $table3 (unique only)"; $sth = $dbh->statistics_info(undef,$schema,$table3,1,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{three_uo}, $t); { $t="Correct stats output for $table1"; $sth = $dbh->statistics_info(undef,undef,$table1,undef,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{one}, $t); $t="Correct stats output for $table3"; $sth = $dbh->statistics_info(undef,undef,$table2,undef,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{two}, $t); $t="Correct stats output for $table3"; $sth = $dbh->statistics_info(undef,undef,$table3,undef,undef); $stats = $sth->fetchall_arrayref; $correct_stats->{three}[5][11] = $stats->[5][11] = 0; is_deeply ($stats, $correct_stats->{three}, $t); $t="Correct stats output for $table3 (unique only)"; $sth = $dbh->statistics_info(undef,undef,$table3,1,undef); $stats = $sth->fetchall_arrayref; is_deeply ($stats, $correct_stats->{three_uo}, $t); } # Clean everything up $dbh->do("DROP TABLE $table3"); $dbh->do("DROP TABLE $table2"); $dbh->do("DROP TABLE $table1"); } ## end of statistics_info tests # # Test of the "foreign_key_info" database handle method # ## Neither pktable nor fktable specified $t='DB handle method "foreign_key_info" returns undef: no pk / no fk'; $sth = $dbh->foreign_key_info(undef,undef,undef,undef,undef,undef); is ($sth, undef, $t); # Drop any tables that may exist my $fktables = join ',' => map { "'dbd_pg_test$_'" } (1..3); $SQL = "SELECT 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 undef: bad pk / no fk'; $sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,undef); is ($sth, undef, $t); ## Invalid foreign table $t='DB handle method "foreign_key_info" returns undef: no pk / bad fk'; $sth = $dbh->foreign_key_info(undef,undef,undef,undef,undef,'dbd_pg_test9'); is ($sth, undef, $t); ## Both primary and foreign are invalid $t='DB handle method "foreign_key_info" returns undef: bad fk / bad fk'; $sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,'dbd_pg_test9'); is ($sth, undef, $t); ## Create a pk table # 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 undef: good pk (but unreferenced)'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); is ($sth, undef, $t); ## Create a simple foreign key table 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 undef: bad pk / good fk'; $sth = $dbh->foreign_key_info(undef,undef,'dbd_pg_test9',undef,undef,$table2); is ($sth, undef, $t); ## Good primary, good foreign, bad schemas $t='DB handle method "foreign_key_info" returns undef: good pk / good fk / bad pk schema'; my $testschema = 'dbd_pg_test_badschema11'; $sth = $dbh->foreign_key_info(undef,$testschema,$table1,undef,undef,$table2); is ($sth, undef, $t); $t='DB handle method "foreign_key_info" returns undef: good pk / good fk / bad fk schema'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,$testschema,$table2); is ($sth, undef, $t); ## Good primary $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,undef); $result = $sth->fetchall_arrayref({}); # Check required minimum fields $t='DB handle method "foreign_key_info" returns fields required by DBI'; $result = $sth->fetchall_arrayref({}); @required = (qw(UK_TABLE_CAT UK_TABLE_SCHEM UK_TABLE_NAME PK_COLUMN_NAME FK_TABLE_CAT FK_TABLE_SCHEM FK_TABLE_NAME FK_COLUMN_NAME ORDINAL_POSITION UPDATE_RULE DELETE_RULE FK_NAME UK_NAME DEFERABILITY UNIQUE_OR_PRIMARY UK_DATA_TYPE FK_DATA_TYPE)); undef %missing; for my $r (@$result) { for (@required) { $missing{$_}++ if ! exists $r->{$_}; } } is_deeply (\%missing, {}, $t); $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 = [ undef, ## Catalog $schema2, ## Schema $table1, ## Table 'a', ## Column undef, ## 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 = [ undef, $schema2, $table1, 'b', undef, $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 = [ undef, $schema2, $table1, 'c', undef, $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 fks'; 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 = [ undef, $schema2, $table1, 'a', undef, $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 = [ undef, $schema2, $table1, 'c', undef, $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 $fk6 = \@fk6; $fk6->[3] = 'a'; $fk6->[7] = 'f3'; $fk6->[8] = 2; my @fk7 = @$fk5; my $fk7 = \@fk7; $fk7->[3] = 'b'; $fk7->[7] = 'f2'; $fk7->[8] = 3; $expected = [$fk3,$fk1,$fk2,$fk5,$fk6,$fk7]; is_deeply ($result, $expected, $t); $t='DB handle method "foreign_key_info" works with FetchHashKeyName NAME_lc'; $dbh->{FetchHashKeyName} = 'NAME_lc'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $sth->execute(); $result = $sth->fetchrow_hashref(); $sth->finish(); ok (exists $result->{'fk_table_name'}, $t); $t='DB handle method "foreign_key_info" works with FetchHashKeyName NAME_uc'; $dbh->{FetchHashKeyName} = 'NAME_uc'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $sth->execute(); $result = $sth->fetchrow_hashref(); ok (exists $result->{'FK_TABLE_NAME'}, $t); $t='DB handle method "foreign_key_info" works with FetchHashKeyName NAME'; $dbh->{FetchHashKeyName} = 'NAME'; $sth = $dbh->foreign_key_info(undef,undef,$table1,undef,undef,$table2); $sth->execute(); $result = $sth->fetchrow_hashref(); ok (exists $result->{'FK_TABLE_NAME'}, $t); # Clean everything up for my $s ($schema3, $schema2) { $dbh->do("DROP TABLE $s.dbd_pg_test3"); $dbh->do("DROP TABLE $s.dbd_pg_test2"); $dbh->do("DROP TABLE $s.dbd_pg_test1"); } $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" works'; @result = $dbh->tables('', '', 'dbd_pg_test', ''); like ($result[0], qr/dbd_pg_test/, $t); $t='DB handle method "tables" works with a "pg_noprefix" attribute'; @result = $dbh->tables('', '', 'dbd_pg_test', '', {pg_noprefix => 1}); is ($result[0], 'dbd_pg_test', $t); $t='DB handle method "tables" works with type=\'%\''; @result = $dbh->tables('', '', 'dbd_pg_test', '%'); like ($result[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 $badresult=q{}; if (ref $result eq 'ARRAY') { my $index = $result->[0]; if (ref $index ne 'HASH') { $badresult = 'First element in array not a hash ref'; } else { for (qw(TYPE_NAME DATA_TYPE CASE_SENSITIVE)) { $badresult = "Field $_ missing" if !exists $index->{$_}; } } } else { $badresult = 'Array reference not returned'; } diag "type_info_all problem: $badresult" if $badresult; ok (!$badresult, $t); # # Test of the "type_info" database handle method # # Check required minimum fields $t='DB handle method "type_info" returns fields required by DBI'; $result = $dbh->type_info(4); @required = (qw(TYPE_NAME DATA_TYPE COLUMN_SIZE LITERAL_PREFIX LITERAL_SUFFIX CREATE_PARAMS NULLABLE CASE_SENSITIVE SEARCHABLE UNSIGNED_ATTRIBUTE FIXED_PREC_SCALE AUTO_UNIQUE_VALUE LOCAL_TYPE_NAME MINIMUM_SCALE MAXIMUM_SCALE SQL_DATA_TYPE SQL_DATETIME_SUB NUM_PREC_RADIX INTERVAL_PRECISION)); undef %missing; for (@required) { $missing{$_}++ if ! exists $result->{$_}; } is_deeply (\%missing, {}, $t); # # Test of the "quote" database handle method # my %quotetests = ( q{0} => q{'0'}, q{Ain't misbehaving } => q{'Ain''t misbehaving '}, NULL => q{'NULL'}, "" => q{''}, ## no critic ); for (keys %quotetests) { $t=qq{DB handle method "quote" works with a value of "$_"}; $result = $dbh->quote($_); is ($result, $quotetests{$_}, $t); } ## Test timestamp - should quote as a string $t='DB handle method "quote" work on timestamp'; my $tstype = 93; my $testtime = '2006-01-28 11:12:13'; is ($dbh->quote( $testtime, $tstype ), qq{'$testtime'}, $t); $t='DB handle method "quote" works with an undefined value'; my $foo; { no warnings;## Perl does not like undef args is ($dbh->quote($foo), q{NULL}, $t); } $t='DB handle method "quote" works with a supplied data type argument'; is ($dbh->quote(1, 4), 1, $t); ## Test bytea quoting my $scs = $dbh->{pg_standard_conforming_strings}; for my $byteval (1 .. 255) { my $byte = chr($byteval); $result = $dbh->quote($byte, { pg_type => PG_BYTEA }); if ($byteval < 32 or $byteval >= 127) { $expected = $scs ? sprintf q{E'\\\\%03o'}, $byteval : sprintf q{'\\\\%03o'}, $byteval; } else { $expected = $scs ? sprintf q{E'%s'}, $byte : sprintf q{'%s'}, $byte; } if ($byte eq '\\') { $expected =~ s{\\}{\\\\\\\\}; } elsif ($byte eq q{'}) { $expected = $scs ? q{E''''} : q{''''}; } $t = qq{Byte value $byteval quotes to $expected}; is ($result, $expected, $t); } ## Various backslash tests $t='DB handle method "quote" works properly with backslashes'; my $E = $pgversion >= 80100 ? q{E} : q{}; is ($dbh->quote('foo\\bar'), qq{${E}'foo\\\\bar'}, $t); $t='DB handle method "quote" works properly without backslashes'; is ($dbh->quote('foobar'), q{'foobar'}, $t); # # Test various quote types # ## 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 $RW = $R|$W; my $object; $t='DB handle method "pg_lo_creat" works with old-school dbh->func() method'; $object = $dbh->func($W, 'pg_lo_creat'); like ($object, qr/^\d+$/o, $t); isnt ($object, 0, $t); $t='DB handle method "pg_lo_creat" works with deprecated dbh->func(...lo_creat) method'; $object = $dbh->func($W, 'lo_creat'); like ($object, qr/^\d+$/o, $t); isnt ($object, 0, $t); $t='DB handle method "pg_lo_creat" returns a valid descriptor for writing'; $object = $dbh->pg_lo_creat($W); like ($object, qr/^\d+$/o, $t); isnt ($object, 0, $t); $t='DB handle method "pg_lo_open" returns a valid descriptor for writing'; my $handle = $dbh->pg_lo_open($object, $W); like ($handle, qr/^\d+$/o, $t); isnt ($object, -1, $t); $t='DB handle method "pg_lo_lseek" works when writing'; $result = $dbh->pg_lo_lseek($handle, 0, 0); is ($result, 0, $t); isnt ($object, -1, $t); $t='DB handle method "pg_lo_write" works'; my $buf = 'tangelo mulberry passionfruit raspberry plantain' x 500; $result = $dbh->pg_lo_write($handle, $buf, length($buf)); is ($result, length($buf), $t); cmp_ok ($object, '>', 0, $t); $t='DB handle method "pg_lo_close" works after write'; $result = $dbh->pg_lo_close($handle); ok ($result, $t); # Reopen for reading $t='DB handle method "pg_lo_open" returns a valid descriptor for reading'; $handle = $dbh->pg_lo_open($object, $R); like ($handle, qr/^\d+$/o, $t); cmp_ok ($handle, 'eq', 0, $t); $t='DB handle method "pg_lo_lseek" works when reading'; $result = $dbh->pg_lo_lseek($handle, 11, 0); is ($result, 11, $t); $t='DB handle method "pg_lo_tell" works'; $result = $dbh->pg_lo_tell($handle); is ($result, 11, $t); $t='DB handle method "pg_lo_read" reads back the same data that was written'; $dbh->pg_lo_lseek($handle, 0, 0); my ($buf2,$data) = ('',''); while ($dbh->pg_lo_read($handle, $data, 513)) { $buf2 .= $data; } is (length($buf), length($buf2), $t); SKIP: { #$pgversion < 80300 and skip ('Server version 8.3 or greater needed for pg_lo_truncate tests', 2); skip ('pg_lo_truncate is not working yet', 2); $t='DB handle method "pg_lo_truncate" works'; $result = $dbh->pg_lo_truncate($handle, 4); is ($result, 0, $t); $dbh->pg_lo_lseek($handle, 0, 0); ($buf2,$data) = ('',''); while ($dbh->pg_lo_read($handle, $data, 100)) { $buf2 .= $data; } is (length($buf2), 4, $t); } $t='DB handle method "pg_lo_close" works after read'; $result = $dbh->pg_lo_close($handle); ok ($result, $t); $t='DB handle method "pg_lo_unlink" works'; $result = $dbh->pg_lo_unlink($object); is ($result, 1, $t); $t='DB handle method "pg_lo_unlink" fails when called second time'; $result = $dbh->pg_lo_unlink($object); ok (!$result, $t); $dbh->rollback(); SKIP: { my $super = is_super(); $super or skip ('Cannot run largeobject tests unless run as Postgres superuser', 38); SKIP: { eval { require File::Temp; }; $@ and skip ('Must have File::Temp to test pg_lo_import* and pg_lo_export', 8); $t='DB handle method "pg_lo_import" works'; my ($fh,$filename) = File::Temp::tmpnam(); print {$fh} "abc\ndef"; close $fh or warn 'Failed to close temporary file'; $handle = $dbh->pg_lo_import($filename); my $objid = $handle; ok ($handle, $t); $t='DB handle method "pg_lo_import" inserts correct data'; $SQL = "SELECT data FROM pg_largeobject where loid = $handle"; $info = $dbh->selectall_arrayref($SQL)->[0][0]; is_deeply ($info, "abc\ndef", $t); $dbh->commit(); SKIP: { if ($pglibversion < 80400) { skip ('Cannot test pg_lo_import_with_oid unless compiled against 8.4 or better server', 5); } if ($pgversion < 80100) { skip ('Cannot test pg_lo_import_with_oid against old versions of Postgres', 5); } $t='DB handle method "pg_lo_import_with_oid" works with high number'; my $highnumber = 345167; $dbh->pg_lo_unlink($highnumber); $dbh->commit(); my $thandle; SKIP: { skip ('Known bug: pg_log_import_with_oid throws an error. See RT #90448', 3); $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/^\d+$/o, $t); $t='DB handle method "pg_lo_read" returns correct data after "pg_lo_import"'; $data = ''; $result = $dbh->pg_lo_read($handle, $data, 100); is ($result, 7, $t); is ($data, "abc\ndef", $t); $t='DB handle method "pg_lo_export" works'; ($fh,$filename) = File::Temp::tmpnam(); $result = $dbh->pg_lo_export($objid, $filename); ok (-e $filename, $t); seek($fh,0,1); seek($fh,0,0); $result = read $fh, $data, 10; is ($result, 7, $t); is ($data, "abc\ndef", $t); close $fh or warn 'Could not close tempfile'; unlink $filename; $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, 0); }; like ($@, qr{pg_lo_lseek when AutoCommit is on}, $t); $t='DB handle method "pg_lo_write" fails with AutoCommit on'; $buf = 'tangelo mulberry passionfruit raspberry plantain' x 500; eval { $dbh->pg_lo_write($handle, $buf, length($buf)); }; like ($@, qr{pg_lo_write when AutoCommit is on}, $t); $t='DB handle method "pg_lo_close" fails with AutoCommit on'; eval { $dbh->pg_lo_close($handle); }; like ($@, qr{pg_lo_close when AutoCommit is on}, $t); $t='DB handle method "pg_lo_tell" fails with AutoCommit on'; eval { $dbh->pg_lo_tell($handle); }; like ($@, qr{pg_lo_tell when AutoCommit is on}, $t); $t='DB handle method "pg_lo_unlink" fails with AutoCommit on'; eval { $dbh->pg_lo_unlink($object); }; like ($@, qr{pg_lo_unlink when AutoCommit is on}, $t); SKIP: { eval { require File::Temp; }; $@ and skip ('Must have File::Temp to test pg_lo_import and pg_lo_export', 5); $t='DB handle method "pg_lo_import" works (AutoCommit on)'; my ($fh,$filename) = File::Temp::tmpnam(); print {$fh} "abc\ndef"; close $fh or warn 'Failed to close temporary file'; $handle = $dbh->pg_lo_import($filename); ok ($handle, $t); $t='DB handle method "pg_lo_import" inserts correct data (AutoCommit on, begin_work not called)'; $SQL = 'SELECT data FROM pg_largeobject where loid = ?'; $sth = $dbh->prepare($SQL); $sth->execute($handle); $info = $sth->fetchall_arrayref()->[0][0]; is_deeply ($info, "abc\ndef", $t); # 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); # # Test of the "getfd" database handle method # $t='DB handle method "getfd" returns a number'; $result = $dbh->func('getfd'); like ($result, qr/^\d+$/, $t); # # Test of the "state" database handle method # $t='DB handle method "state" returns an empty string on success'; $result = $dbh->state(); is ($result, q{}, $t); $t='DB handle method "state" returns a five-character code on error'; eval { $dbh->do('SELECT dbdpg_throws_an_error'); }; $result = $dbh->state(); like ($result, qr/^[A-Z0-9]{5}$/, $t); $dbh->rollback(); # # Test of the "private_attribute_info" database handle method # SKIP: { if ($DBI::VERSION < 1.54) { skip ('DBI must be at least version 1.54 to test private_attribute_info', 2); } $t='DB handle method "private_attribute_info" returns at least one record'; my $private = $dbh->private_attribute_info(); my ($valid,$invalid) = (0,0); for my $name (keys %$private) { $name =~ /^pg_\w+/ ? $valid++ : $invalid++; } ok ($valid >= 1, $t); $t='DB handle method "private_attribute_info" returns only internal names'; is ($invalid, 0, $t); } # # Test of the "clone" database handle method # $t='Database handle method "clone" does not throw an error'; my $dbh2; eval { $dbh2 = $dbh->clone(); }; is ($@, q{}, $t); $t='Database handle method "clone" returns a valid database handle'; eval { $dbh2->do('SELECT 123'); }; is ($@, q{}, $t); $dbh2->disconnect(); # # Test of the "ping" and "pg_ping" database handle methods # my $mtvar; ## This is an implicit test of getcopydata: please leave this var undefined 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); $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); $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}); } 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.7.0/t/lib/0000755000175000017500000000000013162003552012116 5ustar greggregDBD-Pg-3.7.0/t/lib/App/0000755000175000017500000000000013162003552012636 5ustar greggregDBD-Pg-3.7.0/t/lib/App/Info.pm0000644000175000017500000013524613066550507014114 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; use vars qw($VERSION); $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.7.0/t/lib/App/Info/0000755000175000017500000000000013162003552013531 5ustar greggregDBD-Pg-3.7.0/t/lib/App/Info/Handler.pm0000644000175000017500000002515313066550507015464 0ustar greggregpackage App::Info::Handler; =head1 NAME App::Info::Handler - App::Info event handler base class =head1 SYNOPSIS use App::Info::Category::FooApp; use App::Info::Handler; my $app = App::Info::Category::FooApp->new( on_info => ['default'] ); =head1 DESCRIPTION This class defines the interface for subclasses that wish to handle events triggered by App::Info concrete subclasses. The different types of events triggered by App::Info can all be handled by App::Info::Handler (indeed, by default they're all handled by a single App::Info::Handler object), and App::Info::Handler subclasses may be designed to handle whatever events they wish. If you're interested in I an App::Info event handler, this is probably not the class you should look at, since all it does is define a simple handler that does nothing with an event. Look to the L included in this distribution to do more interesting things with App::Info events. If, on the other hand, you're interested in implementing your own event handlers, read on! =cut use strict; use vars qw($VERSION); $VERSION = '0.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; use vars qw(@ISA); @ISA = qw(App::Info::Handler); foreach my $c (qw(foo bar)) { App::Info::Handler->register_handler ( $c => sub { __PACKAGE__->new( mode => $c) } ); } The strings "foo" and "bar" can then be used by clients as shortcuts to have App::Info objects automatically create and use handlers for certain events. For example, if a client wanted to use a "bar" event handler for its info events, it might do this: use App::Info::Category::FooApp; use FooHandler; my $app = App::Info::Category::FooApp->new(on_info => ['bar']); Take a look at App::Info::Handler::Print and App::Info::Handler::Carp to see concrete examples of C usage. The final step in creating a new App::Info event handler is to implement the C method itself. This method takes a single argument, an App::Info::Request object, and is expected to return true if it handled the request, and false if it did not. The App::Info::Request object contains all the 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.7.0/t/lib/App/Info/Request.pm0000644000175000017500000002026613066550507015537 0ustar greggregpackage App::Info::Request; =head1 NAME App::Info::Request - App::Info event handler request object =head1 SYNOPSIS # In an App::Info::Handler subclass: sub handler { my ($self, $req) = @_; print "Event Type: ", $req->type; print "Message: ", $req->message; print "Error: ", $req->error; print "Value: ", $req->value; } =head1 DESCRIPTION Objects of this class are passed to the C method of App::Info event handlers. Generally, this class will be of most interest to App::Info::Handler subclass implementers. The L in App::Info each construct a new App::Info::Request object and initialize it with their arguments. The App::Info::Request object is then the sole argument passed to the C method of any and all App::Info::Handler objects in the event handling chain. Thus, if you'd like to create your own App::Info event handler, this is the object you need to be familiar with. Consult the L documentation for details on creating custom event handlers. Each of the App::Info event triggering methods constructs an App::Info::Request object with different attribute values. Be sure to consult the documentation for the L in App::Info, where the values assigned to the App::Info::Request object are documented. Then, in your event handler subclass, check the value returned by the C method to determine what type of event request you're handling to handle the request appropriately. =cut use strict; use vars qw($VERSION); use Carp; $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.7.0/t/lib/App/Info/RDBMS/0000755000175000017500000000000013162003552014400 5ustar greggregDBD-Pg-3.7.0/t/lib/App/Info/RDBMS/PostgreSQL.pm0000644000175000017500000006172413160273074016761 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; use vars qw(@ISA $VERSION); @ISA = qw(App::Info::RDBMS); $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) { # Beta/devel/release candidates are treated as patch level "0" @{$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)/) { @{$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.7.0/t/lib/App/Info/RDBMS.pm0000644000175000017500000000250513066550507014752 0ustar greggregpackage App::Info::RDBMS; use strict; use App::Info; use vars qw(@ISA $VERSION); @ISA = qw(App::Info); $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.7.0/t/lib/App/Info/Handler/0000755000175000017500000000000013162003552015106 5ustar greggregDBD-Pg-3.7.0/t/lib/App/Info/Handler/Print.pm0000644000175000017500000001142713066550507016557 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; use vars qw($VERSION @ISA); $VERSION = '0.57'; @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.7.0/t/lib/App/Info/Handler/Prompt.pm0000644000175000017500000001145113066550507016741 0ustar greggregpackage App::Info::Handler::Prompt; =head1 NAME App::Info::Handler::Prompt - Prompting App::Info event handler =head1 SYNOPSIS use App::Info::Category::FooApp; use App::Info::Handler::Print; my $prompter = App::Info::Handler::Print->new; my $app = App::Info::Category::FooApp->new( on_unknown => $prompter ); # Or... my $app = App::Info::Category::FooApp->new( on_confirm => 'prompt' ); =head1 DESCRIPTION App::Info::Handler::Prompt objects handle App::Info events by printing their messages to C and then accepting a new value from C. The new value is validated by any callback supplied by the App::Info concrete subclass that triggered the event. If the value is valid, App::Info::Handler::Prompt assigns the new value to the event request. If it isn't it prints the error message associated with the event request, and then prompts for the data again. Although designed with unknown and confirm events in mind, App::Info::Handler::Prompt handles info and error events as well. It will simply print info event messages to C and print error event messages to C. For more interesting info and error event handling, see L and L. Upon loading, App::Info::Handler::Print registers itself with App::Info::Handler, setting up a single string, "prompt", that can be passed to an App::Info concrete subclass constructor. This string is a shortcut that tells App::Info how to create an App::Info::Handler::Print object for handling events. =cut use strict; use App::Info::Handler; use vars qw($VERSION @ISA); $VERSION = '0.57'; @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.7.0/t/lib/App/Info/Util.pm0000644000175000017500000004012213066550507015015 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; use vars qw(@ISA $VERSION); @ISA = qw(File::Spec); $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.7.0/t/08async.t0000644000175000017500000002261513160554660013041 0ustar greggreg#!perl ## Test asynchronous queries use 5.006; use strict; use warnings; use Test::More; use Time::HiRes qw/sleep/; use DBD::Pg ':async'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } my $pglibversion = $dbh->{pg_lib_version}; if ($pglibversion < 80000) { cleanup_database($dbh,'test'); $dbh->disconnect; plan skip_all => 'Cannot run asynchronous queries with pre-8.0 libraries.'; } plan tests => 67; isnt ($dbh, undef, 'Connect to database for async testing'); my ($t,$sth,$res); my $pgversion = $dbh->{pg_server_version}; ## First, test out do() in all its variants $t=q{Method do() works as expected with no args }; eval { $res = $dbh->do('SELECT 123'); }; is ($@, q{}, $t); is ($res, 1, $t); $t=q{Method do() works as expected with an unused attribute }; eval { $res = $dbh->do('SELECT 123', {pg_nosuch => 'arg'}); }; is ($@, q{}, $t); is ($res, 1, $t); $t=q{Method do() works as expected with an unused attribute and a non-prepared param }; eval { $res = $dbh->do('SET random_page_cost TO ?', undef, '2.2'); }; is ($@, q{}, $t); is ($res, '0E0', $t); $t=q{Method do() works as expected with an unused attribute and multiple real bind params }; eval { $res = $dbh->do('SELECT count(*) FROM pg_class WHERE reltuples IN (?,?,?)', undef, 1,2,3); }; is ($@, q{}, $t); is ($res, 1, $t); $t=q{Cancelling a non-async do() query gives an error }; eval { $res = $dbh->pg_cancel(); }; like ($@, qr{No asynchronous query is running}, $t); $t=q{Method do() works as expected with an asychronous flag }; eval { $res = $dbh->do('SELECT 123', {pg_async => PG_ASYNC}); }; is ($@, q{}, $t); is ($res, '0E0', $t); $t=q{Database attribute "async_status" returns 1 after async query}; $res = $dbh->{pg_async_status}; is ($res, +1, $t); sleep 1; $t=q{Cancelling an async do() query works }; eval { $res = $dbh->pg_cancel(); }; is ($@, q{}, $t); $t=q{Database method pg_cancel returns a false value when cancellation works but finished}; is ($res, q{}, $t); $t=q{Database attribute "async_status" returns -1 after pg_cancel}; $res = $dbh->{pg_async_status}; is ($res, -1, $t); $t=q{Running do() after a cancelled query works}; eval { $res = $dbh->do('SELECT 123'); }; is ($@, q{}, $t); $t=q{Database attribute "async_status" returns 0 after normal query run}; $res = $dbh->{pg_async_status}; is ($res, 0, $t); $t=q{Method pg_ready() fails after a non-async query}; eval { $dbh->pg_ready(); }; like ($@, qr{No async}, $t); $res = $dbh->do('SELECT 123', {pg_async => PG_ASYNC}); $t=q{Method pg_ready() works after a non-async query}; ## Sleep a sub-second to make sure the server has caught up sleep 0.2; eval { $res = $dbh->pg_ready(); }; is ($@, q{}, $t); $t=q{Database method pg_ready() returns 1 after a completed async do()}; is ($res, 1, $t); $res = $dbh->pg_ready(); $t=q{Database method pg_ready() returns true when called a second time}; is ($res, 1, $t); $t=q{Database method pg_ready() returns 1 after a completed async do()}; is ($res, 1, $t); $t=q{Cancelling an async do() query works }; eval { $res = $dbh->pg_cancel(); }; is ($@, q{}, $t); $t=q{Database method pg_cancel() returns expected false value for completed value}; is ($res, q{}, $t); $t=q{Method do() runs after pg_cancel has cleared the async query}; eval { $dbh->do('SELECT 456'); }; is ($@, q{}, $t); $dbh->do(q{SELECT 'async2'}, {pg_async => PG_ASYNC}); $t=q{Method do() fails when async query has not been cleared}; eval { $dbh->do(q{SELECT 'async_blocks'}); }; like ($@, qr{previous async}, $t); $t=q{Database method pg_result works as expected}; eval { $res = $dbh->pg_result(); }; is ($@, q{}, $t); $t=q{Database method pg_result() returns correct value}; is ($res, 1, $t); $t=q{Database method pg_result() fails when called twice}; eval { $dbh->pg_result(); }; like ($@, qr{No async}, $t); $t=q{Database method pg_cancel() fails when called after pg_result()}; eval { $dbh->pg_cancel(); }; like ($@, qr{No async}, $t); $t=q{Database method pg_ready() fails when called after pg_result()}; eval { $dbh->pg_ready(); }; like ($@, qr{No async}, $t); $t=q{Database method do() works after pg_result()}; eval { $dbh->do('SELECT 123'); }; is ($@, q{}, $t); SKIP: { if ($pgversion < 80200) { skip ('Need pg_sleep() to perform rest of async tests: your Postgres is too old', 14); } eval { $dbh->do('SELECT pg_sleep(0)'); }; is ($@, q{}, 'Calling pg_sleep works as expected'); my $time = time(); eval { $res = $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); }; $time = time()-$time; $t = q{Database method do() returns right away when in async mode}; cmp_ok ($time, '<=', 1, $t); $t=q{Method pg_ready() returns false when query is still running}; $res = $dbh->pg_ready(); is ($res, 0, $t); pass ('Sleeping to allow query to finish'); sleep(3); $t=q{Method pg_ready() returns true when query is finished}; $res = $dbh->pg_ready(); ok ($res, $t); $t=q{Method do() will not work if async query not yet cleared}; eval { $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); }; like ($@, qr{previous async}, $t); $t=q{Database method pg_cancel() works while async query is running}; eval { $res = $dbh->pg_cancel(); }; is ($@, q{}, $t); $t=q{Database method pg_cancel returns false when query has already finished}; ok (!$res, $t); $t=q{Database method pg_result() fails after async query has been cancelled}; eval { $res = $dbh->pg_result(); }; like ($@, qr{No async}, $t); $t=q{Database method do() cancels the previous async when requested}; eval { $res = $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC + PG_OLDQUERY_CANCEL}); }; is ($@, q{}, $t); $t=q{Database method pg_result works when async query is still running}; eval { $res = $dbh->pg_result(); }; is ($@, q{}, $t); ## Now throw in some execute after the do() $sth = $dbh->prepare('SELECT 567'); $t = q{Running execute after async do() gives an error}; $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); eval { $res = $sth->execute(); }; like ($@, qr{previous async}, $t); $t = q{Running execute after async do() works when told to cancel}; $sth = $dbh->prepare('SELECT 678', {pg_async => PG_OLDQUERY_CANCEL}); eval { $sth->execute(); }; is ($@, q{}, $t); $t = q{Running execute after async do() works when told to wait}; $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC}); $sth = $dbh->prepare('SELECT 678', {pg_async => PG_OLDQUERY_WAIT}); eval { $sth->execute(); }; is ($@, q{}, $t); $sth->finish(); } ## end of pg_sleep skip $t=q{Method execute() works when prepare has PG_ASYNC flag}; $sth = $dbh->prepare('SELECT 123', {pg_async => PG_ASYNC}); eval { $sth->execute(); }; is ($@, q{}, $t); $t=q{Database attribute "async_status" returns 1 after prepare async}; $res = $dbh->{pg_async_status}; is ($res, 1, $t); $t=q{Method do() fails when previous async prepare has been executed}; eval { $dbh->do('SELECT 123'); }; like ($@, qr{previous async}, $t); $t=q{Method execute() fails when previous async prepare has been executed}; eval { $sth->execute(); }; like ($@, qr{previous async}, $t); $t=q{Database method pg_cancel works if async query has already finished}; sleep 0.5; eval { $res = $sth->pg_cancel(); }; is ($@, q{}, $t); $t=q{Statement method pg_cancel() returns a false value when cancellation works but finished}; is ($res, q{}, $t); $t=q{Method do() fails when previous execute async has not been cleared}; $sth->execute(); $sth->finish(); ## Ideally, this would clear out the async, but it cannot at the moment eval { $dbh->do('SELECT 345'); }; like ($@, qr{previous async}, $t); $dbh->pg_cancel; $t=q{Directly after pg_cancel(), pg_async_status is -1}; is ($dbh->{pg_async_status}, -1, $t); $t=q{Method execute() works when prepare has PG_ASYNC flag}; $sth->execute(); $t=q{After async execute, pg_async_status is 1}; is ($dbh->{pg_async_status}, 1, $t); $t=q{Method pg_result works after a prepare/execute call}; eval { $res = $dbh->pg_result; }; is ($@, q{}, $t); $t=q{Method pg_result() returns expected result after prepare/execute select}; is ($res, 1, $t); $t=q{Method fetchall_arrayref works after pg_result}; eval { $res = $sth->fetchall_arrayref(); }; is ($@, q{}, $t); $t=q{Method fetchall_arrayref returns correct result after pg_result}; is_deeply ($res, [[123]], $t); $dbh->do('CREATE TABLE dbd_pg_test5(id INT, t TEXT)'); $dbh->commit(); $sth->execute(); $t=q{Method prepare() works when passed in PG_OLDQUERY_CANCEL}; my $sth2; my $SQL = 'INSERT INTO dbd_pg_test5(id) SELECT 123 UNION SELECT 456'; eval { $sth2 = $dbh->prepare($SQL, {pg_async => PG_ASYNC + PG_OLDQUERY_CANCEL}); }; is ($@, q{}, $t); $t=q{Fetch on cancelled statement handle fails}; eval { $sth->fetch(); }; like ($@, qr{no statement executing}, $t); $t=q{Method execute works after async + cancel prepare}; eval { $sth2->execute(); }; is ($@, q{}, $t); $t=q{Statement method pg_result works on async statement handle}; eval { $res = $sth2->pg_result(); }; is ($@, q{}, $t); $t=q{Statement method pg_result returns correct result after execute}; is ($res, 2, $t); $sth2->execute(); $t=q{Database method pg_result works on async statement handle}; eval { $res = $sth2->pg_result(); }; is ($@, q{}, $t); $t=q{Database method pg_result returns correct result after execute}; is ($res, 2, $t); $dbh->do('DROP TABLE dbd_pg_test5'); ## TODO: More pg_sleep tests with execute cleanup_database($dbh,'test'); $dbh->disconnect; DBD-Pg-3.7.0/t/30unicode.t0000644000175000017500000001571413074205650013343 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.006; use strict; use warnings; use utf8; use charnames ':full'; use Encode qw(encode_utf8); use Data::Dumper; use Test::More; use lib 't','.'; 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/, ); 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", }, # 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 => 'interpolated length', sql => "SELECT 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 $desc = "$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'), "$desc 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'), "$desc 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 { my $result = $sth->fetchall_arrayref->[0][0]; is_deeply ($result, $want, "$desc 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, "$desc returns string with correct UTF-8 flag") for (ref $result ? @{$result} : $result); } } } } } 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 $desc = sprintf "chr(?) for U+%04X $name, \$enable_utf8=$enable_utf8", $ord; skip "Pg < 8.3 has broken $desc", 1 if $ord > 127 && $dbh->{pg_server_version} < 80300; skip "Cannot do $desc 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 $desc") or next; } is (length $result, 1, "Got 1 character for $desc"); is (ord $result, $ord, "Got correct character for $desc"); } } cleanup_database($dbh,'test'); $dbh->disconnect(); done_testing(); DBD-Pg-3.7.0/t/04misc.t0000644000175000017500000003141413074202331012635 0ustar greggreg#!perl ## Various stuff that does not go elsewhere use 5.006; use strict; use warnings; use Test::More; use Data::Dumper; use DBI; use DBD::Pg; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 77; isnt ($dbh, undef, 'Connect to database for miscellaneous tests'); my $t = q{Method 'server_trace_flag' is available without a database handle}; my $num; eval { $num = DBD::Pg->parse_trace_flag('NONE'); }; is ($@, q{}, $t); $t='Method "server_trace_flag" returns undef on bogus argument'; is ($num, undef, $t); $t=q{Method "server_trace_flag" returns 0x00000100 for DBI value 'SQL'}; $num = DBD::Pg->parse_trace_flag('SQL'); is ($num, 0x00000100, $t); $t=q{Method "server_trace_flag" returns 0x01000000 for DBD::Pg flag 'pglibpq'}; $num = DBD::Pg->parse_trace_flag('pglibpq'); is ($num, 0x01000000, $t); $t=q{Database handle method "server_trace_flag" returns undef on bogus argument}; $num = $dbh->parse_trace_flag('NONE'); is ($num, undef, $t); $t=q{Database handle method "server_trace_flag" returns 0x00000100 for DBI value 'SQL'}; $num = $dbh->parse_trace_flag('SQL'); is ($num, 0x00000100, $t); $t=q{Database handle method 'server_trace_flags' returns 0x01000100 for 'SQL|pglibpq'}; $num = $dbh->parse_trace_flags('SQL|pglibpq'); is ($num, 0x01000100, $t); $t=q{Database handle method 'server_trace_flags' returns 0x03000100 for 'SQL|pglibpq|pgstart'}; $num = $dbh->parse_trace_flags('SQL|pglibpq|pgstart'); is ($num, 0x03000100, $t); my $flagexp = 24; my $sth = $dbh->prepare('SELECT 1'); for my $flag (qw/pglibpq pgstart pgend pgprefix pglogin pgquote/) { my $hex = 2**$flagexp++; $t = qq{Database handle method "server_trace_flag" returns $hex for flag $flag}; $num = $dbh->parse_trace_flag($flag); is ($num, $hex, $t); $t = qq{Database handle method 'server_trace_flags' returns $hex for flag $flag}; $num = $dbh->parse_trace_flags($flag); is ($num, $hex, $t); $t = qq{Statement handle method "server_trace_flag" returns $hex for flag $flag}; $num = $sth->parse_trace_flag($flag); is ($num, $hex, $t); $t = qq{Statement handle method 'server_trace_flags' returns $hex for flag $flag}; $num = $sth->parse_trace_flag($flag); is ($num, $hex, $t); } SKIP: { 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 = 'FATAL'}); 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(); } SKIP: { eval { require File::Temp; }; $@ and skip ('Must have File::Temp to complete trace flag testing', 9); my ($fh,$filename) = File::Temp::tempfile('dbdpg_test_XXXXXX', SUFFIX => 'tst', UNLINK => 1); my ($flag, $info, $expected, $SQL); $t=q{Trace flag 'SQL' works as expected}; $flag = $dbh->parse_trace_flags('SQL'); $dbh->trace($flag, $filename); $SQL = q{SELECT 'dbdpg_flag_testing'}; $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = qq{begin;\n\n$SQL;\n\ncommit;\n\n}; is ($info, $expected, $t); $t=q{Trace flag 'pglibpq' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flag('pglibpq'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{PQexec PQresultStatus PQresultErrorField PQclear PQexec PQresultStatus PQresultErrorField PQntuples PQclear PQtransactionStatus PQtransactionStatus PQexec PQresultStatus PQresultErrorField PQclear }; is ($info, $expected, $t); $t=q{Trace flag 'pgstart' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pgstart'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Begin pg_quickexec (query: SELECT 'dbdpg_flag_testing' async: 0 async_status: 0) Begin _result (sql: begin) Begin _sqlstate Begin _sqlstate Begin dbd_db_commit Begin pg_db_rollback_commit (action: commit AutoCommit: 0 BegunWork: 0) Begin PGTransactionStatusType Begin _result (sql: commit) Begin _sqlstate }; is ($info, $expected, $t); $t=q{Trace flag 'pgprefix' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pgstart|pgprefix'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{dbdpg: Begin pg_quickexec (query: SELECT 'dbdpg_flag_testing' async: 0 async_status: 0) dbdpg: Begin _result (sql: begin) dbdpg: Begin _sqlstate dbdpg: Begin _sqlstate dbdpg: Begin dbd_db_commit dbdpg: Begin pg_db_rollback_commit (action: commit AutoCommit: 0 BegunWork: 0) dbdpg: Begin PGTransactionStatusType dbdpg: Begin _result (sql: commit) dbdpg: Begin _sqlstate }; is ($info, $expected, $t); $t=q{Trace flag 'pgend' works as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pgend'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{End _sqlstate (imp_dbh->sqlstate: 00000) End _sqlstate (status: 1) End _result End _sqlstate (imp_dbh->sqlstate: 00000) End _sqlstate (status: 2) End pg_quickexec (rows: 1, txn_status: 2) End _sqlstate (imp_dbh->sqlstate: 00000) End _sqlstate (status: 1) End _result End pg_db_rollback_commit (result: 1) }; is ($info, $expected, $t); $t=q{Trace flag 'pglogin' returns undef if no activity}; seek $fh, 0, 0; truncate $fh, tell($fh); $dbh->trace($dbh->parse_trace_flags('pglogin'), $filename); $dbh->do($SQL); $dbh->commit(); $dbh->trace(0); seek $fh,0,0; { local $/; $info = <$fh>; } $expected = undef; is ($info, $expected, $t); $t=q{Trace flag 'pglogin' works as expected with DBD::Pg->parse_trace_flag()}; $dbh->disconnect(); my $flagval = DBD::Pg->parse_trace_flag('pglogin'); seek $fh, 0, 0; truncate $fh, tell($fh); DBI->trace($flagval, $filename); $dbh = connect_database({nosetup => 1}); $dbh->do($SQL); $dbh->disconnect(); $dbh = connect_database({nosetup => 1}); $dbh->disconnect(); DBI->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Login connection string: Connection complete Disconnection complete }; $info =~ s/(Login connection string: ).+/$1/g; is ($info, "$expected$expected", $t); $t=q{Trace flag 'pglogin' works as expected with DBD::Pg->parse_trace_flag()}; seek $fh, 0, 0; truncate $fh, tell($fh); DBI->trace($flagval, $filename); $dbh = connect_database({nosetup => 1}); $dbh->disconnect(); DBI->trace(0); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Login connection string: Connection complete Disconnection complete }; $info =~ s/(Login connection string: ).+/$1/g; is ($info, "$expected", $t); $t=q{Trace flag 'pgprefix' and 'pgstart' appended to 'pglogin' work as expected}; seek $fh, 0, 0; truncate $fh, tell($fh); DBI->trace($flagval, $filename); $dbh = connect_database({nosetup => 1}); $dbh->do($SQL); $flagval += $dbh->parse_trace_flags('pgprefix|pgstart'); $dbh->trace($flagval); $dbh->do($SQL); $dbh->trace(0); $dbh->rollback(); seek $fh,0,0; { local $/; ($info = <$fh>) =~ s/\r//go; } $expected = q{Login connection string: Connection complete dbdpg: Begin pg_quickexec (query: SELECT 'dbdpg_flag_testing' async: 0 async_status: 0) dbdpg: Begin _sqlstate }; $info =~ s/(Login connection string: ).+/$1/g; is ($info, "$expected", $t); } ## end trace flag testing using File::Temp # # Test of the "data_sources" method # $t='The "data_sources" method did not throw an exception'; my @result; eval { @result = DBI->data_sources('Pg'); }; is ($@, q{}, $t); $t='The "data_sources" method returns a template1 listing'; if (! defined $result[0]) { fail ('The data_sources() method returned an empty list'); } else { is (grep (/^dbi:Pg:dbname=template1$/, @result), '1', $t); } $t='The "data_sources" method returns undef when fed a bogus second argument'; @result = DBI->data_sources('Pg','foobar'); is (scalar @result, 0, $t); $t='The "data_sources" method returns information when fed a valid port as the second arg'; my $port = $dbh->{pg_port}; @result = DBI->data_sources('Pg',"port=$port"); isnt ($result[0], undef, $t); SKIP: { $t=q{The "data_sources" method returns information when 'dbi:Pg' is uppercased}; if (! exists $ENV{DBI_DSN} or $ENV{DBI_DSN} !~ /pg/i) { skip 'Cannot test data_sources() DBI_DSN munging unless DBI_DSN is set', 2; } my $orig = $ENV{DBI_DSN}; $ENV{DBI_DSN} =~ s/DBI:PG/DBI:PG/i; @result = DBI->data_sources('Pg'); like ((join '' => @result), qr{template0}, $t); $t=q{The "data_sources" method returns information when 'DBI:' is mixed case}; $ENV{DBI_DSN} =~ s/DBI:PG/dBi:pg/i; @result = DBI->data_sources('Pg'); like ((join '' => @result), qr{template0}, $t); $ENV{DBI_DSN} = $orig; } # # Test the use of $DBDPG_DEFAULT # ## 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'); } ## 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'; my $result = $dbh->selectall_arrayref($SQL)->[0][0]; $t = q{Using bind_param with type 1 yields a correct bpchar value}; is( $result, '0301', $t); cleanup_database($dbh,'test'); $dbh->disconnect(); DBD-Pg-3.7.0/t/12placeholders.t0000644000175000017500000005465513075771472014404 0ustar greggreg#!perl ## Test of placeholders use 5.006; use strict; use warnings; use Test::More; use lib 't','.'; use DBI qw/:sql_types/; use DBD::Pg qw/:pg_types/; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 257; my $t='Connect to database for placeholder testing'; isnt ($dbh, undef, $t); my ($pglibversion,$pgversion) = ($dbh->{pg_lib_version},$dbh->{pg_server_version}); if ($pgversion >= 80100) { $dbh->do('SET escape_string_warning = false'); } my ($result, $SQL, $qresult); # Make sure that quoting works properly. $t='Quoting works properly'; my $E = $pgversion >= 80100 ? q{E} : q{}; my $quo = $dbh->quote('\\\'?:'); is ($quo, qq{${E}'\\\\''?:'}, $t); $t='Quoting works with a function call'; # Make sure that quoting works with a function call. # It has to be in this function, otherwise it doesn't fail the # way described in https://rt.cpan.org/Ticket/Display.html?id=4996. sub checkquote { my $str = shift; return is ($dbh->quote(substr($str, 0, 10)), "'$str'", $t); } checkquote('one'); checkquote('two'); checkquote('three'); checkquote('four'); $t='Fetch returns the correct quoted value'; my $sth = $dbh->prepare(qq{INSERT INTO dbd_pg_test (id,pname) VALUES (?, $quo)}); $sth->execute(100); my $sql = "SELECT pname FROM dbd_pg_test WHERE pname = $quo"; $sth = $dbh->prepare($sql); $sth->execute(); my ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with one bind param where none expected fails'; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with ? placeholder works'; $sql = 'SELECT pname FROM dbd_pg_test WHERE pname = ?'; $sth = $dbh->prepare($sql); $sth->execute('\\\'?:'); ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with :1 placeholder works'; $sql = 'SELECT pname FROM dbd_pg_test WHERE pname = :1'; $sth = $dbh->prepare($sql); $sth->bind_param(':1', '\\\'?:'); $sth->execute(); ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with $1 placeholder works'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = $1 AND pname <> 'foo'}; $sth = $dbh->prepare($sql); $sth->execute('\\\'?:'); ($retr) = $sth->fetchrow_array(); is ($retr, '\\\'?:', $t); $t='Execute with quoted ? fails with a placeholder'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = '?'}; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with quoted :1 fails with a placeholder'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = ':1'}; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with quoted ? fails with a placeholder'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = '\\\\' AND pname = '?'}; eval { $sth = $dbh->prepare($sql); $sth->execute('foo'); }; like ($@, qr{when 0 are needed}, $t); $t='Execute with named placeholders works'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar2 AND pname = :foobar AND pname = :foobar2}; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->bind_param(':foobar2', 456); $sth->execute(); }; is ($@, q{}, $t); ## Same, but fiddle with whitespace $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar2 AND pname = :foobar2}; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->bind_param(':foobar2', 456); $sth->execute(); }; is ($@, q{}, $t); $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar AND pname = :foobar2 }; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->bind_param(':foobar2', 456); $sth->execute(); }; is ($@, q{}, $t); $t='Execute with repeated named placeholders works'; $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar }; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->execute(); }; is ($@, q{}, $t); ## Same thing, different whitespace $sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar}; eval { $sth = $dbh->prepare($sql); $sth->bind_param(':foobar', 123); $sth->execute(); }; is ($@, q{}, $t); $t='Prepare with large number of parameters works'; ## Test large number of placeholders $sql = 'SELECT 1 FROM dbd_pg_test WHERE id IN (' . '?,' x 300 . '?)'; my @args = map { $_ } (1..301); $sth = $dbh->prepare($sql); my $count = $sth->execute(@args); $sth->finish(); is ($count, 1, $t); $sth->finish(); $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 invalid format (12,34) '(12,34)' ERROR: any circle datatype integers <(12,34),5> '<(12,34),5>' <(12,34),5> circle datatype floating point and exponential numbers <(-1.2,2E2),3e3> '<(-1.2,2E2),3e3>' <(-1.2,200),3000> circle datatype fails with brackets [(1,2),(3,4)] ERROR: Invalid input for circle type ERROR: any }; $testdata =~ s/^\s+//; my $curtype = ''; for my $line (split /\n\n+/ => $testdata) { my ($text,$input,$quoted,$rows) = split /\n/ => $line; next if ! $text; $t = "Geometric type test: $text"; (my $type) = ($text =~ m{(\w+)}); last if $type eq 'LAST'; if ($curtype ne $type) { $curtype = $type; eval { $dbh->do('DEALLOCATE geotest'); }; $dbh->commit(); $dbh->do(qq{PREPARE geotest($type) AS INSERT INTO dbd_pg_test_geom(x$type) VALUES (\$1)}); $sth = $dbh->prepare(qq{INSERT INTO dbd_pg_test_geom(x$type) VALUES (?)}); $sth->bind_param(1, '', {pg_type => $typemap{$type} }); } $dbh->do('DELETE FROM dbd_pg_test_geom'); eval { $qresult = $dbh->quote($input, {pg_type => $typemap{$type}}); }; if ($@) { if ($quoted !~ /ERROR: (.+)/) { ## 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); SKIP: { if ($pglibversion < 80000) { skip ('Skipping specific placeholder test on 7.4-compiled servers', 1); } $t='Calling do() with invalid crowded placeholders fails cleanly'; $dbh->commit(); eval { $dbh->do(q{SELECT ??}, undef, 'public', 'error'); }; is ($dbh->state, '42601', $t); } $t='Prepare/execute with non-DML placeholder works'; $dbh->commit(); eval { $sth = $dbh->prepare(q{SET search_path TO ?}); $sth->execute('pg_catalog'); }; is ($@, q{}, $t); $dbh->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); SKIP: { skip 'Cannot run some quote tests on very old versions of Postgres', 14 if $pgversion < 80000; $t='Prepare works with placeholders after double slashes'; eval { $dbh->do(q{CREATE OPERATOR // ( PROCEDURE=bit, LEFTARG=int, RIGHTARG=int )}); $sth = $dbh->prepare(q{SELECT ? // ?}); $sth->execute(1,2); $sth->finish(); }; is ($@, q{}, $t); $t='Dollar quotes starting with a number are not treated as valid identifiers'; eval { $sth = $dbh->prepare(q{SELECT $123$ $123$}); $sth->execute(1); $sth->finish(); }; like ($@, qr{Invalid placeholders}, $t); $t='Dollar quotes with invalid characters are not parsed as identifiers'; for my $char (qw!+ / : @ [ `!) { ## six characters eval { $sth = $dbh->prepare(qq{SELECT \$abc${char}\$ 123 \$abc${char}\$}); $sth->execute(); $sth->finish(); }; like ($@, qr{syntax error}, "$t: 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', 2 if $pgversion < 80200; $t='Backslash quoting inside single quotes is parsed correctly with standard_conforming_strings off'; eval { $dbh->do(q{SET standard_conforming_strings = 'off'}); local $dbh->{Warn} = ''; $sth = $dbh->prepare(q{SELECT '\', ?}); $sth->execute(); $sth->finish(); }; like ($@, qr{unterminated quoted string}, $t); $dbh->rollback(); $t='Backslash quoting inside single quotes is parsed correctly with standard_conforming_strings on'; eval { $dbh->do(q{SET standard_conforming_strings = 'on'}); $sth = $dbh->prepare(q{SELECT '\', ?::int}); $sth->execute(1); $sth->finish(); }; is ($@, q{}, $t); } $t='Valid integer works when quoting with SQL_INTEGER'; my $val; $val = $dbh->quote('123', SQL_INTEGER); is ($val, 123, $t); $t='Invalid integer fails to pass through when quoting with SQL_INTEGER'; $val = -1; eval { $val = $dbh->quote('123abc', SQL_INTEGER); }; like ($@, qr{Invalid integer}, $t); is ($val, -1, $t); my $prefix = 'Valid float value works when quoting with SQL_FLOAT'; for my $float ('123','0.00','0.234','23.31562', '1.23e04','6.54e+02','4e-3','NaN','Infinity','-infinity') { $t = "$prefix (value=$float)"; $val = -1; eval { $val = $dbh->quote($float, SQL_FLOAT); }; is ($@, q{}, $t); is ($val, $float, $t); next unless $float =~ /\w/; my $lcfloat = lc $float; $t = "$prefix (value=$lcfloat)"; $val = -1; eval { $val = $dbh->quote($lcfloat, SQL_FLOAT); }; is ($@, q{}, $t); is ($val, $lcfloat, $t); my $ucfloat = uc $float; $t = "$prefix (value=$ucfloat)"; $val = -1; eval { $val = $dbh->quote($ucfloat, SQL_FLOAT); }; is ($@, q{}, $t); is ($val, $ucfloat, $t); } $prefix = 'Invalid float value fails when quoting with SQL_FLOAT'; for my $float ('3abc','123abc','','NaNum','-infinitee') { $t = "$prefix (value=$float)"; $val = -1; eval { $val = $dbh->quote($float, SQL_FLOAT); }; like ($@, qr{Invalid float}, $t); is ($val, -1, $t); } $dbh->rollback(); ## Test placeholders plus binding $t='Bound placeholders enforce data types when not using server side prepares'; $dbh->trace(0); $dbh->{pg_server_prepare} = 0; $sth = $dbh->prepare('SELECT (1+?+?)::integer'); $sth->bind_param(1, 1, SQL_INTEGER); eval { $sth->execute('10foo',20); }; like ($@, qr{Invalid integer}, 'Invalid integer test 2'); ## Test quoting of the "name" type $prefix = q{The 'name' data type does correct quoting}; for my $word (qw/User user USER trigger Trigger 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) undef => 'NULL', 't' => 'TRUE', 'T' => 'TRUE', 'true' => 'TRUE', 'TRUE' => 'TRUE', 1 => 'TRUE', 01 => 'TRUE', '1' => 'TRUE', '0E0' => 'TRUE', '0e0' => 'TRUE', '0 but true' => 'TRUE', '0 BUT TRUE' => 'TRUE', 'f' => 'FALSE', 'F' => 'FALSE', 0 => 'FALSE', 00 => 'FALSE', '0' => 'FALSE', 'false' => 'FALSE', 'FALSE' => 'FALSE', 12 => 'ERROR', '01' => 'ERROR', '00' => 'ERROR', ' false' => 'ERROR', ' TRUE' => 'ERROR', 'FALSEY' => 'ERROR', 'trueish' => 'ERROR', '0E0E0' => 'ERROR', ## Jungle love... '0 but truez' => 'ERROR', ); while (my ($name,$res) = each %booltest) { $name = undef if $name eq 'undef'; $t = sprintf 'Boolean quoting of %s', defined $name ? qq{"$name"} : 'undef'; eval { $result = $dbh->quote($name, {pg_type => PG_BOOL}); }; if ($@) { if ($res eq 'ERROR' and $@ =~ /Invalid boolean/) { pass ($t); } else { fail ("Failure at $t: $@"); } $dbh->rollback(); } else { is ($result, $res, $t); } } ## 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.7.0/t/01constants.t0000644000175000017500000003137513161341517013730 0ustar greggreg#!perl use 5.006; use strict; ## We cannot 'use warnings' here as PG_TSQUERY and others trip it up ## no critic (RequireUseWarnings) use Test::More; select(($|=1,select(STDERR),$|=1)[1]); use DBD::Pg qw(:pg_types :async); ## Should match the list in Pg.xs ## This is auto-generated by types.c, so do not edit manually please is (PG_ABSTIME , 702, 'PG_ABSTIME returns correct value'); is (PG_ABSTIMEARRAY , 1023, 'PG_ABSTIMEARRAY returns correct value'); is (PG_ACLITEM , 1033, 'PG_ACLITEM returns correct value'); is (PG_ACLITEMARRAY , 1034, 'PG_ACLITEMARRAY returns correct value'); is (PG_ANY , 2276, 'PG_ANY returns correct value'); is (PG_ANYARRAY , 2277, 'PG_ANYARRAY returns correct value'); is (PG_ANYELEMENT , 2283, 'PG_ANYELEMENT returns correct value'); is (PG_ANYENUM , 3500, 'PG_ANYENUM returns correct value'); is (PG_ANYNONARRAY , 2776, 'PG_ANYNONARRAY returns correct value'); is (PG_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_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_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_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_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_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_OIDARRAY , 1028, 'PG_OIDARRAY returns correct value'); is (PG_OIDVECTOR , 30, 'PG_OIDVECTOR returns correct value'); is (PG_OIDVECTORARRAY , 1013, 'PG_OIDVECTORARRAY returns correct value'); is (PG_OPAQUE , 2282, 'PG_OPAQUE returns correct value'); is (PG_PATH , 602, 'PG_PATH returns correct value'); is (PG_PATHARRAY , 1019, 'PG_PATHARRAY returns correct value'); is (PG_PG_ATTRIBUTE , 75, 'PG_PG_ATTRIBUTE returns correct value'); is (PG_PG_CLASS , 83, 'PG_PG_CLASS returns correct value'); is (PG_PG_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_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_TYPE , 71, 'PG_PG_TYPE returns correct value'); is (PG_POINT , 600, 'PG_POINT returns correct value'); is (PG_POINTARRAY , 1017, 'PG_POINTARRAY returns correct value'); is (PG_POLYGON , 604, 'PG_POLYGON returns correct value'); is (PG_POLYGONARRAY , 1027, 'PG_POLYGONARRAY returns correct value'); is (PG_RECORD , 2249, 'PG_RECORD returns correct value'); is (PG_RECORDARRAY , 2287, 'PG_RECORDARRAY returns correct value'); is (PG_REFCURSOR , 1790, 'PG_REFCURSOR returns correct value'); is (PG_REFCURSORARRAY , 2201, 'PG_REFCURSORARRAY returns correct value'); is (PG_REGCLASS , 2205, 'PG_REGCLASS returns correct value'); is (PG_REGCLASSARRAY , 2210, 'PG_REGCLASSARRAY returns correct value'); is (PG_REGCONFIG , 3734, 'PG_REGCONFIG returns correct value'); is (PG_REGCONFIGARRAY , 3735, 'PG_REGCONFIGARRAY returns correct value'); is (PG_REGDICTIONARY , 3769, 'PG_REGDICTIONARY returns correct value'); is (PG_REGDICTIONARYARRAY , 3770, 'PG_REGDICTIONARYARRAY returns correct value'); is (PG_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_RELTIME , 703, 'PG_RELTIME returns correct value'); is (PG_RELTIMEARRAY , 1024, 'PG_RELTIMEARRAY returns correct value'); is (PG_SMGR , 210, 'PG_SMGR returns correct value'); is (PG_TEXT , 25, 'PG_TEXT returns correct value'); is (PG_TEXTARRAY , 1009, 'PG_TEXTARRAY returns correct value'); is (PG_TID , 27, 'PG_TID returns correct value'); is (PG_TIDARRAY , 1010, 'PG_TIDARRAY returns correct value'); is (PG_TIME , 1083, 'PG_TIME returns correct value'); is (PG_TIMEARRAY , 1183, 'PG_TIMEARRAY returns correct value'); is (PG_TIMESTAMP , 1114, 'PG_TIMESTAMP returns correct value'); is (PG_TIMESTAMPARRAY , 1115, 'PG_TIMESTAMPARRAY returns correct value'); is (PG_TIMESTAMPTZ , 1184, 'PG_TIMESTAMPTZ returns correct value'); is (PG_TIMESTAMPTZARRAY , 1185, 'PG_TIMESTAMPTZARRAY returns correct value'); is (PG_TIMETZ , 1266, 'PG_TIMETZ returns correct value'); is (PG_TIMETZARRAY , 1270, 'PG_TIMETZARRAY returns correct value'); is (PG_TINTERVAL , 704, 'PG_TINTERVAL returns correct value'); is (PG_TINTERVALARRAY , 1025, 'PG_TINTERVALARRAY returns correct value'); is (PG_TRIGGER , 2279, 'PG_TRIGGER returns correct value'); is (PG_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_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_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.7.0/t/00_signature.t0000644000175000017500000000140413066550507014046 0ustar greggreg#!perl ## Test that our SIGNATURE file is valid - requires TEST_SIGNATURE env use 5.006; use strict; use warnings; use Test::More; select(($|=1,select(STDERR),$|=1)[1]); if (!$ENV{TEST_SIGNATURE}) { plan skip_all => 'Set the environment variable TEST_SIGNATURE to enable this test'; } plan tests => 1; SKIP: { if (!eval { require Module::Signature; 1 }) { skip ('Must have Module::Signature to test SIGNATURE file', 1); } elsif ( !-e 'SIGNATURE' ) { fail ('SIGNATURE file was not found'); } elsif ( ! -s 'SIGNATURE') { fail ('SIGNATURE file was empty'); } else { my $ret = Module::Signature::verify(skip=>1); if ($ret eq Module::Signature::SIGNATURE_OK()) { pass ('Valid SIGNATURE file'); } else { fail ('Invalid SIGNATURE file'); } } } DBD-Pg-3.7.0/t/09arrays.t0000644000175000017500000003242313066550507013225 0ustar greggreg#!perl ## Test arrays use 5.006; use strict; use warnings; use Test::More; use Data::Dumper; use DBI ':sql_types'; use DBD::Pg ':pg_types'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 200; isnt ($dbh, undef, 'Connect to database for array testing'); my ($sth,$result,$t); my $pgversion = $dbh->{pg_server_version}; my $SQL = q{DELETE FROM dbd_pg_test WHERE pname = 'Array Testing'}; my $cleararray = $dbh->prepare($SQL); $SQL = q{INSERT INTO dbd_pg_test(id,pname,testarray) VALUES (99,'Array Testing',?)}; my $addarray = $dbh->prepare($SQL); $SQL = q{INSERT INTO dbd_pg_test(id,pname,testarray2) VALUES (99,'Array Testing',?)}; my $addarray_int = $dbh->prepare($SQL); $SQL = q{INSERT INTO dbd_pg_test(id,pname,testarray3) VALUES (99,'Array Testing',?)}; my $addarray_bool = $dbh->prepare($SQL); $SQL = q{SELECT testarray FROM dbd_pg_test WHERE pname= 'Array Testing'}; my $getarray = $dbh->prepare($SQL); $SQL = q{SELECT testarray2 FROM dbd_pg_test WHERE pname= 'Array Testing'}; my $getarray_int = $dbh->prepare($SQL); $SQL = q{SELECT testarray3 FROM dbd_pg_test WHERE pname= 'Array Testing'}; my $getarray_bool = $dbh->prepare($SQL); $t='Array quoting allows direct insertion into statements'; $SQL = q{INSERT INTO dbd_pg_test (id,testarray) VALUES }; my $quoteid = $dbh->quote(123); my $quotearr = $dbh->quote([q{Quote's Test}]); $SQL .= qq{($quoteid, $quotearr)}; eval { $dbh->do($SQL); }; is ($@, q{}, $t); $dbh->rollback(); ## Input (eval-able Perl) ## Expected (ERROR or raw PostgreSQL output) ## Name of test my $array_tests = q![''] {""} Empty array [['']] {{""}} Empty array with two levels [[['']]] {{{""}}} Empty array with three levels [[''],['']] {{""},{""}} Two empty arrays [[[''],[''],['']]] {{{""},{""},{""}}} Three empty arrays at second level [[],[[]]] ERROR: must be of equal size Unbalanced empty arrays {} ERROR: Cannot bind a reference Bare hashref [{}] ERROR: only scalars and other arrays Hashref at top level [1,2,{3,4},5] ERROR: only scalars and other arrays Hidden hashref [[1,2],[3]] ERROR: must be of equal size Unbalanced array [[1,2],[3,4,5]] ERROR: must be of equal size Unbalanced array [[1,2],[]] ERROR: must be of equal size Unbalanced array [[],[3]] ERROR: must be of equal size Unbalanced array [123] {123} Simple 1-D numeric array ['abc'] {abc} Simple 1-D text array ['a','b,c'] {a,"b,c"} Text array with commas and quotes ['a','b,}'] {a,"b,}"} Text array with commas, escaped closing brace ['a','b,]'] {a,"b,]"} Text array with commas, escaped closing bracket [1,2] {1,2} Simple 1-D numeric array [[1]] {{1}} Simple 2-D numeric array [[1,2]] {{1,2}} Simple 2-D numeric array [[[1]]] {{{1}}} Simple 3-D numeric array [[["alpha",2],[23,"pop"]]] {{{alpha,2},{23,pop}}} 3-D mixed array [[[1,2,3],[4,5,"6"],["seven","8","9"]]] {{{1,2,3},{4,5,6},{seven,8,9}}} 3-D mixed array [q{O'RLY?}] {O'RLY?} Simple single quote [q{O"RLY?}] {"O\"RLY?"} Simple double quote [[q{O"RLY?}],[q|'Ya' - "really"|],[123]] {{"O\"RLY?"},{"'Ya' - \"really\""},{123}} Many quotes ["Single\\\\Backslash"] {"Single\\\\Backslash"} Single backslash testing ["Double\\\\\\\\Backslash"] {"Double\\\\\\\\Backslash"} Double backslash testing [["Test\\\nRun","Quite \"so\""],["back\\\\\\\\slashes are a \"pa\\\\in\"",123] ] {{"Test\\\nRun","Quite \"so\""},{"back\\\\\\\\slashes are a \"pa\\\\in\"",123}} Escape party - backslash+newline, two + one [undef] {NULL} NEED 80200: Simple undef test [[undef]] {{NULL}} NEED 80200: Simple undef test [[1,2],[undef,3],["four",undef],[undef,undef]] {{1,2},{NULL,3},{four,NULL},{NULL,NULL}} NEED 80200: Multiple undef test !; ## Note: We silently allow things like this: [[[]],[]] sub safe_getarray { my $ret = eval { $getarray->execute(); $getarray->fetchall_arrayref()->[0][0]; }; return $@ || $ret; } for my $test (split /\n\n/ => $array_tests) { next unless $test =~ /\w/; my ($input,$expected,$msg) = split /\n/ => $test; my $perl_input = eval $input; if ($msg =~ s/NEED (\d+):\s*//) { my $ver = $1; if ($pgversion < $ver) { SKIP: { skip ('Cannot test NULL arrays unless version 8.2 or better', 6); } next; } } # INSERT via bind values $dbh->rollback; eval { $addarray->execute($perl_input); }; if ($expected =~ /error:\s+(.+)/i) { like ($@, qr{$1}, "[bind] Array insert error : $msg : $input"); } else { is ($@, q{}, "[bind] Array insert success : $msg : $input"); $t="[bind][!expand] Correct array inserted: $msg : $input"; $dbh->{pg_expand_array} = 0; is (safe_getarray, $expected, $t); $t="[bind][expand] Correct array inserted: $msg : $input"; $dbh->{pg_expand_array} = 1; is_deeply (safe_getarray, $perl_input, $t); } # INSERT via `quote' and dynamic SQL $dbh->rollback; eval { $quotearr = $dbh->quote($perl_input); $SQL = qq{INSERT INTO dbd_pg_test(id,pname,testarray) VALUES (99,'Array Testing',$quotearr)}; $dbh->do($SQL); }; if ($expected =~ /error:\s+(.+)/i) { my $errmsg = $1; $errmsg =~ s/bind/quote/; like ($@, qr{$errmsg}, "[quote] Array insert error : $msg : $input"); } else { is ($@, q{}, "[quote] Array insert success : $msg : $input"); # No need to recheck !expand case. $t="[quote][expand] Correct array inserted: $msg : $input"; is_deeply (safe_getarray, $perl_input, $t); } if ($msg =~ /STOP/) { warn "Exiting for DEBUGGING. Result is:\n"; warn Dumper $result; cleanup_database($dbh,'test'); $dbh->disconnect; exit; } } ## Test of no-item and empty string arrays $t=q{String array with no items returns empty array}; $cleararray->execute(); $addarray->execute('{}'); $getarray->execute(); $result = $getarray->fetchall_arrayref(); is_deeply ($result, [[[]]], $t); $t=q{String array with empty string returns empty string}; $cleararray->execute(); $addarray->execute('{""}'); $getarray->execute(); $result = $getarray->fetchall_arrayref(); is_deeply ($result, [[['']]], $t); ## Test non-string array variants $t=q{Integer array with no items returns empty array}; $cleararray->execute(); $addarray_int->execute('{}'); $getarray_int->execute(); $result = $getarray_int->fetchall_arrayref(); is_deeply ($result, [[[]]], $t); $t=q{Boolean array with no items returns empty array}; $cleararray->execute(); $addarray_bool->execute('{}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[]]], $t); $t=q{Boolean array gets created and returned correctly}; $cleararray->execute(); $addarray_bool->execute('{1}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[1]]], $t); $cleararray->execute(); $addarray_bool->execute('{0}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[0]]], $t); $cleararray->execute(); $addarray_bool->execute('{t}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[1]]], $t); $cleararray->execute(); $addarray_bool->execute('{f}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[0]]], $t); $cleararray->execute(); $addarray_bool->execute('{f,t,f,0,1,1}'); $getarray_bool->execute(); $result = $getarray_bool->fetchall_arrayref(); is_deeply ($result, [[[0,1,0,0,1,1]]], $t); ## Pure string to array conversion testing my $array_tests_out = q!1 [1] Simple test of single array element 1,2 [1,2] Simple test of multiple array elements 1,2,3 [1,2,3] Simple test of multiple array elements 'a','b' ['a','b'] Array with text items 0.1,2.4 [0.1,2.4] Array with numeric items 'My"lrd','b','c' ['My"lrd','b','c'] Array with escaped items [1] [[1]] Multi-level integer array [[1,2]] [[[1,2]]] Multi-level integer array [[1],[2]] [[[1],[2]]] Multi-level integer array [[1],[2],[3]] [[[1],[2],[3]]] Multi-level integer array [[[1]],[[2]],[[3]]] [[[[1]],[[2]],[[3]]]] Multi-level integer array 'abc',NULL ['abc',undef] NEED 80200: Array with a null ['abc','NULL',NULL,NULL,123::text] [['abc','NULL',undef,undef,'123']] NEED 80200: Array with many nulls and a quoted int ['abc',''] [['abc','']] Final item is empty 1,NULL [1,undef] NEED 80200: Last item is NULL NULL [undef] NEED 80200: Only item is NULL NULL,NULL [undef,undef] NEED 80200: Two NULL items only NULL,NULL,NULL [undef,undef,undef] NEED 80200: Three NULL items only [123,NULL,456] [[123,undef,456]] NEED 80200: Middle item is NULL NULL,'abc' [undef,'abc'] NEED 80200: First item is NULL 'a','NULL' ['a',"NULL"] Fake NULL is text [[[[[1,2,3]]]]] [[[[[[1,2,3]]]]]] Deep nesting [[[[[1],[2],[3]]]]] [[[[[[1],[2],[3]]]]]] Deep nesting [[[[[1]]],[[[2]]],[[[3]]]]] [[[[[[1]]],[[[2]]],[[[3]]]]]] Deep nesting [[[[[1]],[[2]],[[3]]]]] [[[[[[1]],[[2]],[[3]]]]]] Deep nesting 1::bool [1] Test of boolean type 1::bool,0::bool,'true'::boolean [1,0,1] Test of boolean types 1::oid [1] Test of oid type - should not quote 1::text ['1'] Text number should quote 1,2,3 [1,2,3] Unspecified int should not quote 1::int [1] Integer number should quote '(1,2),(4,5)'::box,'(5,3),(4,5)' ['(4,5),(1,2)','(5,5),(4,3)'] Type 'box' works !; $Data::Dumper::Indent = 0; for my $test (split /\n\n/ => $array_tests_out) { next unless $test =~ /\w/; my ($input,$expected,$msg) = split /\n/ => $test; my $qexpected = $expected; if ($expected =~ s/\s*quote:\s*(.+)//) { $qexpected = $1; } if ($msg =~ s/NEED (\d+):\s*//) { my $ver = $1; if ($pgversion < $ver) { SKIP: { skip ('Cannot test NULL arrays unless version 8.2 or better', 1); } next; } } if ($pgversion < 80200) { if ($input =~ /SKIP/ or $test =~ /Fake NULL|boolean/) { SKIP: { skip ('Cannot test some array items on pre-8.2 servers', 1); } next; } } $t="Array test $msg : $input"; $SQL = qq{SELECT ARRAY[$input]}; $result = ''; eval { $result = $dbh->selectall_arrayref($SQL)->[0][0]; }; if ($result =~ /error:\s+(.+)/i) { like ($@, qr{$1}, "Array failed : $msg : $input"); } else { $expected = eval $expected; ## is_deeply does not handle type differences is ( (Dumper $result), (Dumper $expected), $t); } } ## Check utf-8 in and out of the database SKIP: { eval { require Encode; }; skip ('Encode module is needed for unicode tests', 14) if $@; my $server_encoding = $dbh->selectall_arrayref('SHOW server_encoding')->[0][0]; skip ('Cannot reliably test unicode without a UTF8 database', 14) if $server_encoding ne 'UTF8'; $t='String should be UTF-8'; local $dbh->{pg_enable_utf8} = 1; my $utf8_str = chr(0x100).'dam'; # LATIN CAPITAL LETTER A WITH MACRON ok (Encode::is_utf8( $utf8_str ), $t); $t='quote() handles utf8'; my $quoted = $dbh->quote($utf8_str); is ($quoted, qq{'$utf8_str'}, $t); $t='Quoted string should be UTF-8'; ok (Encode::is_utf8( $quoted ), $t); $t='quote() handles utf8 inside array'; $quoted = $dbh->quote([$utf8_str, $utf8_str]); is ($quoted, qq!'{"$utf8_str","$utf8_str"}'!, $t); $t='Quoted array of strings should be UTF-8'; ok (Encode::is_utf8( $quoted ), $t); $t='Inserting utf-8 into an array via quoted do() works'; $dbh->do('DELETE FROM dbd_pg_test'); $SQL = qq{INSERT INTO dbd_pg_test (id, testarray, val) VALUES (1, $quoted, 'one')}; eval { $dbh->do($SQL); }; is ($@, q{}, $t); $t='Retreiving an array containing utf-8 works'; $SQL = q{SELECT id, testarray, val FROM dbd_pg_test WHERE id = 1}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->fetchall_arrayref()->[0]; my $expected = [1,[$utf8_str,$utf8_str],'one']; is_deeply ($result, $expected, $t); $t='Selected string should be UTF-8'; ok (Encode::is_utf8( $result->[1][0] ), $t); $t='Selected string should be UTF-8'; ok (Encode::is_utf8( $result->[1][1] ), $t); $t='Inserting utf-8 into an array via prepare and arrayref works'; $dbh->do('DELETE FROM dbd_pg_test'); $SQL = q{INSERT INTO dbd_pg_test (id, testarray, val) VALUES (?, ?, 'one')}; $sth = $dbh->prepare($SQL); eval { $sth->execute(1,['Bob',$utf8_str]); }; is ($@, q{}, $t); local $dbh->{pg_enable_utf8} = 1; $t='Retreiving an array containing utf-8 works'; $SQL = q{SELECT id, testarray, val FROM dbd_pg_test WHERE id = 1}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->fetchall_arrayref()->[0]; $expected = [1,['Bob',$utf8_str],'one']; is_deeply ($result, $expected, $t); $t='Selected ASCII string should be UTF-8'; ok (Encode::is_utf8( $result->[1][0] ), $t); $t='Selected string should be UTF-8'; ok (Encode::is_utf8( $result->[1][1] ), $t); $t='Non utf-8 inside an array is not return as utf-8'; $dbh->do('DELETE FROM dbd_pg_test'); $SQL = q{INSERT INTO dbd_pg_test (id, testarray, val) VALUES (1, '{"noutfhere"}', 'one')}; $dbh->do($SQL); $SQL = q{SELECT testarray FROM dbd_pg_test WHERE id = 1}; $sth = $dbh->prepare($SQL); $sth->execute(); $result = $sth->fetchall_arrayref()->[0][0]; ok (!Encode::is_utf8($result), $t); $sth->finish(); } ## Quick test of empty arrays my $expected = $pgversion >= 80300 ? [[[]]] : [[undef]]; $t=q{Empty int array is returned properly}; $result = $dbh->selectall_arrayref(q{SELECT array(SELECT 12345::int WHERE 1=0)::int[]}); is_deeply ($result, $expected, $t); $t=q{Empty text array is returned properly}; $result = $dbh->selectall_arrayref(q{SELECT array(SELECT 'empty'::text WHERE 1=0)::text[]}); is_deeply ($result, $expected, $t); cleanup_database($dbh,'test'); $dbh->disconnect; DBD-Pg-3.7.0/t/07copy.t0000644000175000017500000002456713075771651012713 0ustar greggreg#!perl ## Test the COPY functionality use 5.006; use strict; use warnings; use Data::Dumper; use DBD::Pg ':async'; use Test::More; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if ($dbh) { plan tests => 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,$badret,$badval) = ('',0,0); $result = $dbh->pg_getline($data[0], 100); is ($result, 1, $t); ## Commands are not allowed while in a COPY OUT state $t='do() fails while in a COPY OUT state'; eval { $dbh->do(q{SELECT 'dbdpg_copytest'}); }; ok ($@, $t); ## pg_putline is not allowed as we are in a COPY OUT state $t='pg_putline fails while in a COPY OUT state'; eval { $dbh->pg_putline("99\tBogusberry"); }; ok ($@, $t); $t='pg_getline returned a 1'; $data[1]=$data[2]=$data[3]=''; $result = $dbh->pg_getline($data[1], 100); is ($result, 1, $t); $t='pg_getline returned a 1'; $result = $dbh->pg_getline($data[2], 100); is ($result, 1, $t); $t='pg_getline returns empty on final call'; $result = $dbh->pg_getline($data[3], 100); is ($result, '', $t); $t='getline returned all rows successfuly'; $result = \@data; $expected = ["12\tMulberry\n","13\tStrawberry\n","14\tBlueberry\n",'']; is_deeply ($result, $expected, $t); ## Make sure we can issue normal commands again $dbh->do(q{SELECT 'dbdpg_copytest'}); ## Make sure we are out of the COPY OUT state and pg_getline no longer works $t='pg_getline fails when issued after pg_endcopy called'; eval { $data[5]=''; $dbh->pg_getline($data[5], 100); }; ok ($@, $t); ## pg_endcopy should fail because we are no longer in a COPY state $t='pg_endcopy fails when called twice after COPY OUT'; eval { $dbh->pg_endcopy; }; ok ($@, $t); ## ## Test the new COPY methods ## $dbh->do("DELETE FROM $table"); $t='pg_putcopydata fails if not after a COPY FROM statement'; eval { $dbh->pg_putcopydata("pizza\tpie"); }; like ($@, qr{COPY FROM command}, $t); $t='pg_getcopydata fails if not after a COPY TO statement'; eval { $dbh->pg_getcopydata($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='pg_getcopydata_async fails if not after a COPY TO statement'; eval { $dbh->pg_getcopydata_async($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='pg_putcopyend warns but does not die if not after a COPY statement'; eval { require Test::Warn; }; if ($@) { pass ('Skipping Test::Warn test'); } else { Test::Warn::warning_like (sub { $dbh->pg_putcopyend(); }, qr/until a COPY/, $t); } $t='pg_getcopydata does not work if we are using COPY .. TO'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); eval { $dbh->pg_getcopydata($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='pg_putcopydata does not work if we are using COPY .. FROM'; $dbh->rollback(); $dbh->do("COPY $table TO STDOUT"); eval { $dbh->pg_putcopydata("pizza\tpie"); }; like ($@, qr{COPY FROM command}, $t); $t='pg_putcopydata works and returns a 1 on success'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); $result = $dbh->pg_putcopydata("15\tBlueberry"); is ($result, 1, $t); $t='pg_putcopydata works on second call'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); $result = $dbh->pg_putcopydata("16\tMoreBlueberries"); is ($result, 1, $t); $t='pg_putcopydata fails with invalid data'; $dbh->rollback(); $dbh->do("COPY $table FROM STDIN"); eval { $dbh->pg_putcopydata(); }; ok ($@, $t); $t='Calling pg_getcopydata gives an error when in the middle of COPY .. TO'; eval { $dbh->pg_getcopydata($data[0]); }; like ($@, qr{COPY TO command}, $t); $t='Calling do() gives an error when in the middle of COPY .. FROM'; eval { $dbh->do('SELECT 123'); }; like ($@, qr{call pg_putcopyend}, $t); $t='pg_putcopydata works after a rude non-COPY attempt'; eval { $result = $dbh->pg_putcopydata("17\tMoreBlueberries"); }; is ($@, q{}, $t); is ($result, 1, $t); $t='pg_putcopyend works and returns a 1'; eval { $result = $dbh->pg_putcopyend(); }; is ($@, q{}, $t); is ($result, 1, $t); $t='pg_putcopydata fails after pg_putcopyend is called'; $dbh->commit(); eval { $result = $dbh->pg_putcopydata('root'); }; like ($@, qr{COPY FROM command}, $t); $t='Normal queries work after pg_putcopyend is called'; eval { $dbh->do('SELECT 123'); }; is ($@, q{}, $t); $t='Data from pg_putcopydata was entered correctly'; $result = $dbh->selectall_arrayref("SELECT id2,val2 FROM $table ORDER BY id2"); $expected = [['12','Mulberry'],['13','Strawberry'],[14,'Blueberry'],[17,'MoreBlueberries']]; is_deeply ($result, $expected, $t); $t='pg_getcopydata fails when argument is not a variable'; $dbh->do("COPY $table TO STDOUT"); eval { $dbh->pg_getcopydata('wrongo'); }; like ($@, qr{read-only}, $t); $t='pg_getcopydata works and returns the length of the string'; $data[0] = 'old'; eval { $dbh->pg_getcopydata($data[0]); }; is ($@, q{}, $t); is ($data[0], "13\tStrawberry\n", $t); $t='pg_getcopydata works when argument is a reference'; eval { $dbh->pg_getcopydata(\$data[0]); }; is ($@, q{}, $t); is ($data[0], "14\tBlueberry\n", $t); $t='Calling do() gives an error when in the middle of COPY .. TO'; eval { $dbh->do('SELECT 234'); }; like ($@, qr{pg_getcopydata}, $t); $t='Calling pg_putcopydata gives an errors when in the middle of COPY .. FROM'; eval { $dbh->pg_putcopydata('pie'); }; like ($@, qr{COPY FROM command}, $t); $t='pg_getcopydata returns 0 when no more data'; $dbh->pg_getcopydata(\$data[0]); eval { $result = $dbh->pg_getcopydata(\$data[0]); }; is ($@, q{}, $t); is ($data[0], '', $t); is ($result, -1, $t); $t='Normal queries work after pg_getcopydata runs out'; eval { $dbh->do('SELECT 234'); }; is ($@, q{}, $t); $t='Async queries work after COPY OUT'; $dbh->do('CREATE TEMP TABLE foobar AS SELECT 123::INTEGER AS x'); $dbh->do('COPY foobar TO STDOUT'); 1 while ($dbh->pg_getcopydata($buffer) >= 0); eval { $dbh->do('SELECT 111', { pg_async => PG_ASYNC} ); }; is ($@, q{}, $t); $dbh->pg_result(); $t='Async queries work after COPY IN'; $dbh->do('COPY foobar FROM STDIN'); $dbh->pg_putcopydata(456); $dbh->pg_putcopyend(); eval { $dbh->do('SELECT 222', { pg_async => PG_ASYNC} ); }; is ($@, q{}, $t); $dbh->pg_result(); SKIP: { $pgversion < 80200 and skip ('Server version 8.2 or greater needed for test', 1); $t='pg_getcopydata works when pulling from an empty table into an empty var'; $dbh->do(q{COPY (SELECT 1 FROM pg_class LIMIT 0) TO STDOUT}); eval { my $newvar; $dbh->pg_getcopydata($newvar); }; is ($@, q{}, $t); } # # Make sure rollback and commit reset our internal copystate tracking # $t='commit resets COPY state'; $dbh->do("COPY $table TO STDOUT"); $dbh->commit(); eval { $dbh->do(q{SELECT 'dbdpg_copytest'}); }; ok (!$@, $t); $t='rollback resets COPY state'; $dbh->do("COPY $table TO STDOUT"); $dbh->rollback(); eval { $dbh->do(q{SELECT 'dbdpg_copytest'}); }; ok (!$@, $t); # # Keep old-style calls around for backwards compatibility # $t=q{old-style dbh->func('text', 'putline') still works}; $dbh->do("COPY $table FROM STDIN"); $result = $dbh->func("13\tOlive\n", 'putline'); is ($result, 1, $t); $t=q{old-style dbh->func(var, length, 'getline') still works}; $dbh->pg_endcopy; $dbh->do("COPY $table TO STDOUT"); $result = $dbh->func($data[0], 100, 'getline'); is ($result, 1, $t); 1 while ($result = $dbh->func($data[0], 100, 'getline')); # 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'); is (substr($copydata, 0, 11), "PGCOPY\n\377\r\n\0", '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 roundtrips}; is_deeply ($dbh->selectall_arrayref('SELECT * FROM binarycopy'), [[1],[1]], $t); $dbh->do("DROP TABLE $table"); $dbh->commit(); cleanup_database($dbh,'test'); $dbh->disconnect; DBD-Pg-3.7.0/t/20savepoints.t0000644000175000017500000000336613066550507014114 0ustar greggreg#!perl ## Test savepoint functionality use 5.006; use strict; use warnings; use Test::More; use DBI ':sql_types'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 3; isnt ($dbh, undef, 'Connect to database for savepoint testing'); my $pgversion = $dbh->{pg_server_version}; my $t; SKIP: { skip ('Cannot test savepoints on pre-8.0 servers', 2) if $pgversion < 80000; my $str = 'Savepoint Test'; my $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id,pname) VALUES (?,?)'); ## Create 500 without a savepoint $sth->execute(500,$str); ## Create 501 inside a savepoint and roll it back $dbh->pg_savepoint('dbd_pg_test_savepoint'); $sth->execute(501,$str); $dbh->pg_rollback_to('dbd_pg_test_savepoint'); $dbh->pg_rollback_to('dbd_pg_test_savepoint'); ## Yes, we call it twice ## Create 502 after the rollback: $sth->execute(502,$str); $dbh->commit; $t='Only row 500 and 502 should be committed'; my $ids = $dbh->selectcol_arrayref('SELECT id FROM dbd_pg_test WHERE pname = ?',undef,$str); ok (eq_set($ids, [500, 502]), $t); ## Create 503, then release the savepoint $dbh->pg_savepoint('dbd_pg_test_savepoint'); $sth->execute(503,$str); $dbh->pg_release('dbd_pg_test_savepoint'); ## Create 504 outside of any savepoint $sth->execute(504,$str); $dbh->commit; $t='Implicit rollback on deallocate should rollback to last savepoint'; $ids = $dbh->selectcol_arrayref('SELECT id FROM dbd_pg_test WHERE pname = ?',undef,$str); ok (eq_set($ids, [500, 502, 503, 504]), $t); } $dbh->do('DELETE FROM dbd_pg_test'); $dbh->commit(); cleanup_database($dbh,'test'); $dbh->disconnect(); DBD-Pg-3.7.0/t/03smethod.t0000644000175000017500000005471713160557511013370 0ustar greggreg#!perl ## Test of the statement handle methods ## The following methods are *not* currently tested here: ## "execute" ## "finish" ## "dump_results" use 5.006; use strict; use warnings; use POSIX qw(:signal_h); use Test::More; use DBI ':sql_types'; use lib 't','.'; require 'dbdpg_test_setup.pl'; select(($|=1,select(STDERR),$|=1)[1]); my $dbh = connect_database(); if (! $dbh) { plan skip_all => 'Connection to database failed, cannot continue testing'; } plan tests => 126; isnt ($dbh, undef, 'Connect to database for statement handle method testing'); my $pglibversion = $dbh->{pg_lib_version}; my ($SQL, $sth, $sth2, $result, @result, $expected, $rows, $t); # # Test of the prepare flags # $t=q{Calling prepare() with no arguments gives an error}; eval{ $sth = $dbh->prepare(); }; like ($@, qr{\+ 0}, $t); $t=q{Calling prepare() with an undefined value returns undef}; $sth = $dbh->prepare(undef); is ($sth, undef, $t); $t='Prepare/execute with no flags works'; $SQL = 'SELECT id FROM dbd_pg_test WHERE id = ?'; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_server_prepare off at database handle works'; $dbh->{pg_server_prepare} = 0; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); $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); } ## 7.4 does not have a full SSP implementation, so we simply skip these tests. if ($pglibversion < 80000) { SKIP: { skip ('Not testing pg_server_prepare on 7.4-compiled servers', 2); } } else { $t='Prepare/execute with pg_server_prepare on at database handle works'; $dbh->{pg_server_prepare} = 1; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); } ## We must send a hashref as the final arg $t='Prepare failes when sent a non-hashref'; eval { $sth = $dbh->prepare('SELECT 123', ['I am not a hashref!']); }; like ($@, qr{not a hash}, $t); # Make sure that undefs are converted to NULL. $t='Prepare/execute with undef converted to NULL'; $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id, pdate) VALUES (?,?)'); ok ($sth->execute(401, undef), $t); $t='Prepare/execute with pg_server_prepare off at statement handle works'; $sth = $dbh->prepare($SQL, {pg_server_prepare => 0}); $sth->execute(1); ok ($sth->execute, $t); if ($pglibversion >= 80000) { $t='Prepare/execute with pg_server_prepare on at statement handle works'; $sth = $dbh->prepare($SQL, {pg_server_prepare => 1}); $sth->execute(1); ok ($sth->execute, $t); } $t='Prepare/execute with pg_prepare_now on at database handle works'; $dbh->{pg_prepare_now} = 1; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_prepare_now off at database handle works'; $dbh->{pg_prepare_now} = 0; $sth = $dbh->prepare($SQL); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_prepare_now off at statement handle works'; $sth = $dbh->prepare($SQL, {pg_prepare_now => 0}); $sth->execute(1); ok ($sth->execute, $t); $t='Prepare/execute with pg_prepare_now on at statement handle works'; $sth = $dbh->prepare($SQL, {pg_prepare_now => 1}); $sth->execute(1); ok ($sth->execute, $t); # Test using our own prepared statements $t='Prepare/execute works with pg_prepare_name'; my $pgversion = $dbh->{pg_server_version}; my $myname = 'dbdpg_test_1'; $dbh->do("PREPARE $myname(int) AS SELECT COUNT(*) FROM pg_class WHERE reltuples > \$1", {pg_direct=> 1}); $sth = $dbh->prepare('SELECT ?'); $sth->bind_param(1, 1, SQL_INTEGER); $sth->{pg_prepare_name} = $myname; ok ($sth->execute(1), $t); $dbh->do("DEALLOCATE $myname"); # # Test of the "bind_param" statement handle method # $t='Statement handle method "bind_param" works when binding an int column with an int'; $SQL = 'SELECT id FROM dbd_pg_test WHERE id = ?'; $sth = $dbh->prepare($SQL); ok ($sth->bind_param(1, 1), $t); $t='Statement handle method "bind_param" works when rebinding an int column with a string'; ok ($sth->bind_param(1, 'foo'), $t); # Check if the server is sending us warning messages # We assume that older servers are okay my $client_level = ''; $sth2 = $dbh->prepare('SHOW client_min_messages'); $sth2->execute(); $client_level = $sth2->fetchall_arrayref()->[0][0]; # # Test of the "bind_param_inout" statement handle method # $t='Invalid placeholder fails for bind_param_inout'; my $var = 123; $sth = $dbh->prepare('SELECT 1+?::int'); eval { $sth->bind_param_inout(0, \$var, 0); }; like ($@, qr{Cannot bind}, $t); eval { $sth->bind_param_inout(3, \$var, 0); }; like ($@, qr{Cannot bind}, $t); $t = q{Calling bind_param_inout with a non-scalar reference fails}; eval { $sth->bind_param_inout(1, 'noway', 0); }; like ($@, qr{needs a reference}, $t); eval { $sth->bind_param_inout(1, $t, 0); }; like ($@, qr{needs a reference}, $t); eval { $sth->bind_param_inout(1, [123], 0); }; like ($@, qr{needs a reference}, $t); $t = q{Calling bind_param_inout changes an integer value}; eval { $sth->bind_param_inout(1, \$var, 0); }; is ($@, q{}, $t); $var = 999; $sth->execute(); $sth->fetch; is ($var, 1000, $t); $t = q{Calling bind_param_inout changes a string value}; $sth = $dbh->prepare(q{SELECT 'X'||?::text}); $sth->bind_param_inout(1, \$var, 0); $var = 'abc'; $sth->execute(); $sth->fetch; is ($var, 'Xabc', $t); $t = q{Calling bind_param_inout changes a string to a float}; $sth = $dbh->prepare('SELECT ?::float'); $sth->bind_param_inout(1, \$var, 0); $var = '1e+6'; $sth->execute(); $sth->fetch; is ($var, '1000000', $t); $t = q{Calling bind_param_inout works for second placeholder}; $sth = $dbh->prepare('SELECT ?::float, 1+?::int'); $sth->bind_param_inout(2, \$var, 0); $var = 111; $sth->execute(222,333); $sth->fetch; is ($var, 112, $t); $t = q{Calling bind_param_inout changes two variables at once}; my $var2 = 234; $sth = $dbh->prepare('SELECT 1+?::float, 1+?::int'); $sth->bind_param_inout(1, \$var, 0); $sth->bind_param_inout(2, \$var2, 0); $var = 444; $var2 = 555; $sth->execute(); $sth->fetch; is ($var, 445, $t); is ($var2, 556, $t); # # Test of the "bind_param_array" statement handle method # $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id, val) VALUES (?,?)'); # Try with 1, 2, and 3 values. All should succeed $t='Statement handle method "bind_param_array" works binding three values to the first placeholder'; eval { $sth->bind_param_array(1, [ 30, 31, 32 ], SQL_INTEGER); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works binding one scalar value to the second placeholder'; eval { $sth->bind_param_array(2, 'Mulberry'); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works binding three values to the second placeholder'; eval { $sth->bind_param_array(2, [ 'Mango', 'Strawberry', 'Gooseberry' ]); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works when binding one value to the second placeholder'; eval { $sth->bind_param_array(2, [ 'Mangoz' ]); }; is ($@, q{}, $t); $t='Statement handle method "bind_param_array" works when binding two values to the second placeholder'; eval { $sth->bind_param_array(2, [ 'Plantain', 'Apple' ]); }; is ($@, q{}, $t); # # Test of the "execute_array" statement handle method # $t='Statement method handle "execute_array" works'; $dbh->{RaiseError}=1; my @tuple_status; $rows = $sth->execute_array( { ArrayTupleStatus => \@tuple_status }); is_deeply (\@tuple_status, [1,1,1], $t); $t='Statement method handle "execute_array" returns correct number of rows'; is ($rows, 3, $t); # Test the ArrayTupleFetch attribute $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id, val) VALUES (?,?)'); # Try with 1, 2, and 3 values. All should succeed $sth->bind_param_array(1, [ 20, 21, 22 ], SQL_INTEGER); $sth->bind_param_array(2, 'fruit'); my $counter=0; my @insertvals = ( [33 => 'Peach'], [34 => 'Huckleberry'], [35 => 'Guava'], [36 => 'Lemon'], ); sub getval { return $insertvals[$counter++]; } $t='Statement method handle "execute_array" works with ArrayTupleFetch'; undef @tuple_status; $rows = $sth->execute_array( { ArrayTupleStatus => \@tuple_status, ArrayTupleFetch => \&getval }); is_deeply (\@tuple_status, [1,1,1,1], $t); $t='Statement method handle "execute_array" returns correct number of rows with ArrayTupleFetch'; is ($rows, 4, $t); # # Test of the "execute_for_fetch" statement handle method # $sth = $dbh->prepare('SELECT id+200, val FROM dbd_pg_test'); my $goodrows = $sth->execute(); $sth2 = $dbh->prepare(q{INSERT INTO dbd_pg_test (id, val) VALUES (?,?)}); $sth2->bind_param(1,'',SQL_INTEGER); my $fetch_tuple_sub = sub { $sth->fetchrow_arrayref() }; undef @tuple_status; $rows = $sth2->execute_for_fetch($fetch_tuple_sub, \@tuple_status); $t='Statement handle method "execute_for_fetch" works'; is_deeply (\@tuple_status, [map{1}(1..$goodrows)], $t); $t='Statement handle method "execute_for_fetch" returns correct number of rows'; is ($rows, $goodrows, $t); # # Test of the "fetchrow_arrayref" statement handle method # $t='Statement handle method "fetchrow_arrayref" returns first row correctly'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id = 34'); $sth->execute(); $result = $sth->fetchrow_arrayref(); is_deeply ($result, [34, 'Huckleberry'], $t); $t='Statement handle method "fetchrow_arrayref" returns undef when done'; $result = $sth->fetchrow_arrayref(); is_deeply ($result, undef, $t); # Test of the "fetch" alias $t='Statement handle method alias "fetch" returns first row correctly'; $sth->execute(); $result = $sth->fetch(); $expected = [34, 'Huckleberry']; is_deeply ($result, $expected, $t); $t='Statement handle method alias "fetch" returns undef when done'; $result = $sth->fetch(); is_deeply ($result, undef, $t); # # Test of the "fetchrow_array" statement handle method # $t='Statement handle method "fetchrow_array" returns first row correctly'; $sth->execute(); @result = $sth->fetchrow_array(); is_deeply (\@result, $expected, $t); $t='Statement handle method "fetchrow_array" returns an empty list when done'; @result = $sth->fetchrow_array(); is_deeply (\@result, [], $t); # # Test of the "fetchrow_hashref" statement handle method # $t='Statement handle method "fetchrow_hashref" works with a slice argument'; $sth->execute(); $result = $sth->fetchrow_hashref(); $expected = {id => 34, val => 'Huckleberry'}; is_deeply ($result, $expected, $t); $t='Statement handle method "fetchrow_hashref" returns undef when done'; $result = $sth->fetchrow_hashref(); is_deeply ($result, undef, $t); # # Test of the "fetchall_arrayref" statement handle method # $t='Statement handle method "fetchall_arrayref" returns first row correctly'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (35,36) ORDER BY id ASC'); $sth->execute(); $result = $sth->fetchall_arrayref(); $expected = [[35,'Guava'],[36,'Lemon']]; is_deeply ($result, $expected, $t); # Test of the 'slice' argument $t='Statement handle method "fetchall_arrayref" works with an arrayref slice'; $sth->execute(); $result = $sth->fetchall_arrayref([1]); $expected = [['Guava'],['Lemon']]; is_deeply ($result, $expected, $t); $t='Statement handle method "fetchall_arrayref" works with a hashref slice'; $sth->execute(); $result = $sth->fetchall_arrayref({id => 1}); $expected = [{id => 35},{id => 36}]; is_deeply ($result, $expected, $t); # My personal favorite way of grabbing data $t='Statement handle method "fetchall_arrayref" works with an empty hashref slice'; $sth->execute(); $result = $sth->fetchall_arrayref({}); $expected = [{id => 35, val => 'Guava'},{id => 36, val => 'Lemon'}]; is_deeply ($result, $expected, $t); SKIP: { if ($DBI::VERSION >= 1.603) { skip ('fetchall_arrayref max rows broken in DBI 1.603', 2); } # Test of the 'maxrows' argument $t=q{Statement handle method "fetchall_arrayref" works with a 'maxrows' argument}; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id >= 33 ORDER BY id ASC LIMIT 10'); $sth->execute(); $result = $sth->fetchall_arrayref(undef,2); $expected = [[33,'Peach'],[34,'Huckleberry']]; is_deeply ($result, $expected, $t); $t=q{Statement handle method "fetchall_arrayref" works with an arrayref slice and a 'maxrows' argument}; $result = $sth->fetchall_arrayref([1],2); $expected = [['Guava'],['Lemon']]; $sth->finish(); is_deeply ($result, $expected, $t); } # # Test of the "fetchall_hashref" statement handle method # $t='Statement handle method "fetchall_hashref" gives an error when called with no arguments'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $sth->execute(); eval { $sth->fetchall_hashref(); }; isnt ($@, q{}, $t); $t='Statement handle method "fetchall_hashref" works with a named key field'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $sth->execute(); $result = $sth->fetchall_hashref('id'); $expected = {33=>{id => 33, val => 'Peach'},34=>{id => 34, val => 'Huckleberry'}}; is_deeply ($result, $expected, $t); $t='Statement handle method "fetchall_hashref" returns an empty hash when no rows returned'; $sth->execute(); $result = $sth->fetchall_hashref(1); is_deeply ($result, $expected, q{Statement handle method "fetchall_hashref" works with a numeric key field}); $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id < 1'); $sth->execute(); $result = $sth->fetchall_hashref(1); is_deeply ($result, {}, $t); # # Test of the "rows" statement handle method # $t='Statement handle method "rows" returns -1 before an execute'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $rows = $sth->rows(); is ($rows, -1, $t); $t='Statement handle method "rows" returns correct number of rows'; $sth->execute(); $rows = $sth->rows(); $sth->finish(); is ($rows, 2, $t); # # Test of the "bind_col" statement handle method # $t='Statement handle method "bind_col" returns the correct value'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34)'); $sth->execute(); my $bindme; $result = $sth->bind_col(2, \$bindme); is ($result, 1, $t); $t='Statement handle method "bind_col" correctly binds parameters'; $sth->fetch(); is ($bindme, 'Peach', $t); $dbh->do(q{UPDATE dbd_pg_test SET testarray = '{2,3,55}' WHERE id = 33}); $t='Statement handle method "bind_col" returns the correct value'; my $bindarray; $sth = $dbh->prepare('SELECT id, testarray FROM dbd_pg_test WHERE id = 33'); $sth->execute(); $result = $sth->bind_col(1, \$bindme); is ($result, 1, $t); $t='Statement handle method "bind_col" returns the correct value'; $result = $sth->bind_col(2, \$bindarray); is ($result, 1, $t); $t='Statement handle method "bind_col" correctly binds parameters'; $sth->fetch(); is ($bindme, '33', $t); $t='Statement handle method "bind_col" correctly binds arrayref'; is_deeply ($bindarray, [2,3,55], $t); # # Test of the "bind_columns" statement handle method # $t='Statement handle method "bind_columns" fails when called with wrong number of arguments'; $sth = $dbh->prepare('SELECT id, val FROM dbd_pg_test WHERE id IN (33,34) ORDER BY id'); $sth->execute(); my $bindme2; eval { $sth->bind_columns(1); }; isnt ($@, q{}, $t); $t='Statement handle method "bind_columns" returns the correct value'; $result = $sth->bind_columns(\$bindme, \$bindme2); is ($result, 1, $t); $t='Statement handle method "bind_columns" correctly binds parameters'; $sth->fetch(); $expected = [33, 'Peach']; my $got = [$bindme, $bindme2]; $sth->finish(); is_deeply ($got, $expected, $t); # # Test of the statement handle method "state" # $t='Statement handle method "state" returns an empty string on success'; $result = $sth->state(); is ($result, q{}, $t); $t='Statement handle method "state" returns a five-character code on error'; eval { $sth = $dbh->prepare('SELECT dbdpg_throws_an_error'); $sth->execute(); }; $result = $sth->state(); like ($result, qr/^[A-Z0-9]{5}$/, $t); $t='Statement and database handle method "state" return same code'; my $result2 = $dbh->state(); is ($result, $result2, $t); $t='Statement handle method "state" returns expected code'; is ($result, '42703', $t); # # Test of the statement handle method "private_attribute_info" # SKIP: { if ($DBI::VERSION < 1.54) { skip ('DBI must be at least version 1.54 to test private_attribute_info', 2); } $t='Statement handle method "private_attribute_info" returns at least one record'; $sth = $dbh->prepare('SELECT 123'); my $private = $sth->private_attribute_info(); my ($valid,$invalid) = (0,0); for my $name (keys %$private) { $name =~ /^pg_\w+/ ? $valid++ : $invalid++; } cmp_ok ($valid, '>=', 1, $t); $t='Statement handle method "private_attribute_info" returns only internal names'; $sth->finish(); is ($invalid, 0, $t); } # # Test of the statement handle method "pg_numbound" # $dbh->rollback(); $t=q{Statement handle attribute pg_numbound returns 0 if no placeholders}; $sth = $dbh->prepare('SELECT 123'); is ($sth->{pg_numbound}, 0, $t); $sth->execute(); is ($sth->{pg_numbound}, 0, $t); $t=q{Statement handle attribute pg_numbound returns 0 if no placeholders bound yet}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); is ($sth->{pg_numbound}, 0, $t); $t=q{Statement handle attribute pg_numbound returns 1 if one placeholder bound}; $sth->bind_param(1, 123); is ($sth->{pg_numbound}, 1, $t); $t=q{Statement handle attribute pg_numbound returns 2 if two placeholders bound}; $sth->bind_param(2, 345); is ($sth->{pg_numbound}, 2, $t); $t=q{Statement handle attribute pg_numbound returns 1 if one placeholders bound as NULL}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); $sth->bind_param(1, undef); is ($sth->{pg_numbound}, 1, $t); # # Test of the statement handle method "pg_bound" # $t=q{Statement handle attribute pg_bound returns an empty hash if no placeholders}; $sth = $dbh->prepare('SELECT 123'); is_deeply ($sth->{pg_bound}, {}, $t); $sth->execute(); is_deeply ($sth->{pg_bound}, {}, $t); $t=q{Statement handle attribute pg_bound returns correct value if no placeholders bound yet}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); is_deeply ($sth->{pg_bound}, {1=>0, 2=>0}, $t); $t=q{Statement handle attribute pg_bound returns correct value if one placeholder bound}; $sth->bind_param(2, 123); is_deeply ($sth->{pg_bound}, {1=>0, 2=>1}, $t); $t=q{Statement handle attribute pg_bound returns correct value if two placeholders bound}; $sth->bind_param(1, 123); is_deeply ($sth->{pg_bound}, {1=>1, 2=>1}, $t); # # Test of the statement handle method "pg_numbound" # $t=q{Statement handle attribute pg_numbound returns 1 if one placeholders bound as NULL}; $sth = $dbh->prepare('SELECT 123 WHERE 1 > ? AND 2 > ?'); $sth->bind_param(1, undef); is_deeply ($sth->{pg_bound}, {1=>1, 2=>0}, $t); # # Test of the statement handle method "pg_current_row" # $t=q{Statement handle attribute pg_current_row returns zero until first row fetched}; $sth = $dbh->prepare('SELECT 1 FROM pg_class LIMIT 5'); is ($sth->{pg_current_row}, 0, $t); $t=q{Statement handle attribute pg_current_row returns zero until first row fetched}; $sth->execute(); is ($sth->{pg_current_row}, 0, $t); $t=q{Statement handle attribute pg_current_row returns 1 after a fetch}; $sth->fetch(); is ($sth->{pg_current_row}, 1, $t); $t=q{Statement handle attribute pg_current_row returns correct value while fetching}; my $x = 2; while (defined $sth->fetch()) { is ($sth->{pg_current_row}, $x++, $t); } $t=q{Statement handle attribute pg_current_row returns 0 when done fetching}; is ($sth->{pg_current_row}, 0, $t); $t=q{Statement handle attribute pg_current_row returns 0 after fetchall_arrayref}; $sth->execute(); $sth->fetchall_arrayref(); is ($sth->{pg_current_row}, 0, $t); # # Test of the statement handle method "cancel" # SKIP: { ## 7.4 does not have cancel if ($pglibversion < 80000) { skip ('Not testing cancel 7.4-compiled servers', 1); } if ($^O =~ /Win/) { skip ('Cannot test POSIX signalling 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); # # Test of the statement handle methods "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; cleanup_database($dbh,'test'); $dbh->rollback(); $dbh->disconnect(); DBD-Pg-3.7.0/LICENSES/0000755000175000017500000000000013162003552012312 5ustar greggregDBD-Pg-3.7.0/LICENSES/artistic.txt0000644000175000017500000001517213066550507014715 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.7.0/LICENSES/gpl-2.0.txt0000644000175000017500000004310313066550507014145 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.7.0/testme.tmp.pl0000755000175000017500000001245313160547236013564 0ustar greggreg#!/usr/bin/env perl BEGIN { use lib '.', 'blib/lib', 'blib/arch'; system 'make'; } use strict; use warnings; use DBI ':sql_types'; use utf8; use Data::Dumper; use YAML; use DBD::Pg qw/:pg_types/; use Data::Peek; use Devel::Leak; use Time::HiRes qw/ sleep /; use vars qw/$sth $info $count $SQL/; my $tracelevel = shift || 0; $ENV{DBI_TRACE} = $tracelevel; my $DSN = 'DBI:Pg:dbname=postgres'; my $dbh = DBI->connect($DSN, '', '', {AutoCommit=>0,RaiseError=>1,PrintError=>0}) or die "Connection failed!\n"; my $me = $dbh->{Driver}{Name}; print "DBI is version $DBI::VERSION, I am $me, version of DBD::Pg is $DBD::Pg::VERSION\n"; print "Name: $dbh->{Name}\n"; fatal_client(); exit; #user_arrays(); #commit_return_test(); #utf8_print_test(); #memory_leak_test_bug_65734(); #memory_leak_arrays(); 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.7.0/win32.mak0000644000175000017500000000466713066550507012570 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.7.0/dbdimp.c0000644000175000017500000047675113162002623012532 0ustar greggreg/* Copyright (c) 2002-2017 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 #define sword signed int #define sb2 signed short #define ub2 unsigned short #if PGLIBVERSION < 80000 /* Should not be called, throw errors: */ PGresult *PQprepare(PGconn *a, const char *b, const char *c, int d, const Oid *e); PGresult *PQprepare(PGconn *a, const char *b, const char *c, int d, const Oid *e) { if (a||b||c||d||e) d=0; croak ("Called wrong PQprepare"); } int PQserverVersion(const PGconn *a); int PQserverVersion(const PGconn *a) { if (!a) return 0; croak ("Called wrong PQserverVersion"); } typedef struct pg_cancel PGcancel; int PQcancel(PGcancel *cancel, char *errbuf, int errbufsize); int PQcancel(PGcancel *cancel, char *errbuf, int errbufsize) { croak ("Called wrong PQcancel"); } PGcancel *PQgetCancel(PGconn *conn); PGcancel *PQgetCancel(PGconn *conn) { croak ("Called wrong PQgetCancel"); } void PQfreeCancel(PGcancel *cancel); void PQfreeCancel(PGcancel *cancel) { croak ("Called wrong PQfreeCancel"); } #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 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') 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, int version, 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); /* ================================================================== */ void dbd_init (dbistate_t *dbistate) { dTHX; DBISTATE_INIT; } /* ================================================================== */ 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; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_db_login\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) 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); } /* Attempt the connection to the database */ if (TLOGIN_slow) TRC(DBILOGFP, "%sLogin connection string: (%s)\n", THEADER_slow, conn_str); 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) { TRACE_PQERRORMESSAGE; strncpy(imp_dbh->sqlstate, "08006", 6); /* "CONNECTION FAILURE" */ pg_error(aTHX_ dbh, connstatus, PQerrorMessage(imp_dbh->conn)); TRACE_PQFINISH; PQfinish(imp_dbh->conn); 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)); /* 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 */ imp_dbh->pg_server_version = -1; #if PGLIBVERSION >= 80000 TRACE_PQSERVERVERSION; imp_dbh->pg_server_version = PQserverVersion(imp_dbh->conn); #endif if (imp_dbh->pg_server_version <= 0) { int cnt, vmaj, vmin, vrev; const char *vers = PQparameterStatus(imp_dbh->conn, "server_version"); if (NULL != vers) { cnt = sscanf(vers, "%d.%d.%d", &vmaj, &vmin, &vrev); if (cnt >= 2) { if (cnt == 2) /* Account for devel version e.g. 8.3beta1 */ vrev = 0; imp_dbh->pg_server_version = (100 * vmaj + vmin) * 100 + vrev; } } else { imp_dbh->pg_server_version = PG_UNKNOWN_VERSION ; } } 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; 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->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 = 0; imp_dbh->async_sth = NULL; /* If using server version 7.4, switch to "smart" */ imp_dbh->server_prepare = PGLIBVERSION >= 80000 ? 1 : 2; /* 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); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_db_login\n", THEADER_slow); return 1; } /* end of dbd_db_login */ /* ================================================================== */ /* 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_setpvn(DBIc_ERRSTR(imp_xxh), error_msg, error_len); sv_setpv(DBIc_STATE(imp_xxh), (char*)imp_dbh->sqlstate); /* 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) { PGresult * result; ExecStatusType status; if (TSTART_slow) TRC(DBILOGFP, "%sBegin _result (sql: %s)\n", THEADER_slow, sql); if (TSQL) TRC(DBILOGFP, "%s;\n\n", sql); TRACE_PQEXEC; result = PQexec(imp_dbh->conn, sql); status = _sqlstate(aTHX_ imp_dbh, result); TRACE_PQCLEAR; PQclear(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; 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 */ 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 (TEND_slow) TRC(DBILOGFP, "%sEnd _sqlstate (imp_dbh->sqlstate: %s)\n", THEADER_slow, imp_dbh->sqlstate); 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 >= 4) { /* 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 */ result = PQexec(imp_dbh->conn, "/* DBD::Pg ping test v3.7.0 */"); if (NULL == result) { /* Something very bad, usually indicating the backend is gone */ return -3; } status = PQresultStatus(result); PQclear(result); /* 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 */ 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 begin_work has been called, turn AutoCommit back on and BegunWork off */ if (DBIc_has(imp_dbh, DBIcf_BegunWork)!=0) { DBIc_set(imp_dbh, DBIcf_AutoCommit, 1); DBIc_set(imp_dbh, DBIcf_BegunWork, 0); } if (!imp_dbh->done_begin) { 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; } /* 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); if (DBIc_ACTIVE(imp_dbh)) (void)dbd_db_disconnect(dbh, imp_dbh); if (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 = 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, dbh ? key : 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_pid_number 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_pid_number", key)) /* Undocumented on purpose */ retsv = newSViv((IV)imp_dbh->pid_number); else if (strEQ("pg_options", key)) { TRACE_PQOPTIONS; retsv = newSVpv(PQoptions(imp_dbh->conn),0); } break; case 11: /* pg_INV_READ pg_protocol */ if (strEQ("pg_INV_READ", key)) retsv = newSViv((IV)INV_READ); else if (strEQ("pg_protocol", key)) retsv = newSViv((IV)imp_dbh->pg_protocol); 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 */ 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); break; case 18: /* pg_switch_prepared */ if (strEQ("pg_switch_prepared", key)) retsv = newSViv((IV)imp_dbh->switch_prepared); 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)) { if (NULL != PQparameterStatus(imp_dbh->conn, "standard_conforming_strings")) { 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 */ if (strEQ("pg_server_prepare", key)) { if (SvOK(valuesv)) { newval = (unsigned)SvIV(valuesv); } /* Default to "2" if an invalid value is passed in */ imp_dbh->server_prepare = 0==newval ? 0 : 1==newval ? 1 : 2; retval = 1; } break; case 18: /* pg_switch_prepared */ if (strEQ("pg_switch_prepared", key)) { if (SvOK(valuesv)) { imp_dbh->switch_prepared = (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, x; 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); } 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,0); 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 (! 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: /* pg_async NULLABLE */ if (strEQ("pg_async", key)) retsv = newSViv((IV)imp_sth->async_flag); else if (strEQ("NULLABLE", key)) { AV *av = newAV(); PGresult *result; int status = -1; D_imp_dbh_from_sth; int nullable; /* 0 = not nullable, 1 = nullable 2 = unknown */ int y; retsv = newRV_inc(sv_2mortal((SV*)av)); while(--fields >= 0) { nullable=2; TRACE_PQFTABLE; x = PQftable(imp_sth->result, fields); TRACE_PQFTABLECOL; y = PQftablecol(imp_sth->result, fields); if (InvalidOid != x && y > 0) { /* We know what table and column this came from */ char statement[128]; snprintf(statement, sizeof(statement), "SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid=%d AND attnum=%d", x, 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 = strEQ(value,"0") ? DBDPG_FALSE : DBDPG_TRUE; 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, wordstart, newsize; /* Used to find and set firstword */ SV **svp; /* To help parse the arguments */ statement_sv = pg_rightgraded_sv(aTHX_ statement_sv, imp_dbh->pg_utf8_flag); char *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 = 0; 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->onetime = DBDPG_FALSE; /* Allow internal shortcut */ 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_fetch((HV*)SvRV(attribs),"pg_server_prepare", 17, 0)) != NULL) { int newval = (int)SvIV(*svp); /* Default to "2" if an invalid value is passed in */ imp_sth->server_prepare = 0==newval ? 0 : 1==newval ? 1 : 2; } if ((svp = hv_fetch((HV*)SvRV(attribs),"pg_direct", 9, 0)) != NULL) imp_sth->direct = 0==SvIV(*svp) ? DBDPG_FALSE : DBDPG_TRUE; else if ((svp = hv_fetch((HV*)SvRV(attribs),"pg_prepare_now", 14, 0)) != NULL) { imp_sth->prepare_now = 0==SvIV(*svp) ? DBDPG_FALSE : DBDPG_TRUE; } if ((svp = hv_fetch((HV*)SvRV(attribs),"pg_placeholder_dollaronly", 25, 0)) != NULL) { imp_sth->dollaronly = SvTRUE(*svp) ? DBDPG_TRUE : DBDPG_FALSE; } if ((svp = hv_fetch((HV*)SvRV(attribs),"pg_placeholder_nocolons", 23, 0)) != NULL) { imp_sth->nocolons = SvTRUE(*svp) ? DBDPG_TRUE : DBDPG_FALSE; } if ((svp = hv_fetch((HV*)SvRV(attribs),"pg_async", 8, 0)) != NULL) { imp_sth->async_flag = (int)SvIV(*svp); } } /* Figure out the first word in the statement */ while (*statement && isSPACE(*statement)) { mypos++; statement++; } if (isALPHA(*statement)) { wordstart = mypos; while (isALPHA(*statement)) { mypos++; statement++; } newsize = mypos-wordstart; New(0, imp_sth->firstword, newsize+1, char); /* freed in dbd_st_destroy */ Copy(statement-newsize, imp_sth->firstword, newsize, char); imp_sth->firstword[newsize] = '\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, "VALUES") || 0 == strcasecmp(imp_sth->firstword, "WITH") ) { imp_sth->is_dml = DBDPG_TRUE; } } statement -= mypos; /* Rewind statement */ /* Break the statement into segments by placeholder */ pg_st_split_statement(aTHX_ imp_sth, imp_dbh->pg_server_version, statement); /* We prepare it right away if: 1. The statement is DML 2. The attribute "direct" is false 3. The attribute "pg_server_prepare" is not 0 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 && 0 != imp_sth->server_prepare && imp_sth->prepare_now && PGLIBVERSION >= 80000 ) { 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)); } } /* 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, int version, 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 */ STRLEN backslashes; /* Counts backslashes, only used in quote section */ STRLEN dollarsize; /* Size of dollarstring */ int topdollar; /* Used to enforce sequential $1 arguments */ 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 */ char quote; /* Current quote or comment character: used only in those two blocks */ bool found; /* Simple boolean */ bool inside_dollar; /* Inside a dollar quoted value */ char * dollarstring = NULL; /* Dynamic string between $$ in dollar quoting */ char standard_conforming_strings = 1; /* Status 0=on 1=unknown -1=off */ STRLEN xlen; /* Because "x" is too hard to search for */ int xint; seg_t *newseg, *currseg = NULL; /* Segment structures to help build linked lists */ ph_t *newph, *thisph, *currph = NULL; /* Placeholder structures to help build ll */ 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) { quote = ch; backslashes = 0; if ('\'' == ch && 1 == standard_conforming_strings) { const char * scs = PQparameterStatus(imp_dbh->conn,"standard_conforming_strings"); standard_conforming_strings = (NULL==scs ? 1 : strncmp(scs,"on",2)); } /* 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 standard_confirming_strings is set, ignore backslashes in single quotes */ if (ch == quote && (quote == '"' || 0==(backslashes&1))) { quote = 0; } else if ('\\' == ch) { if (quote == '"' || standard_conforming_strings) 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) ) { 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 - only if the backend is version 8 or higher */ if (version >= 80000 && '$' == 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 ($) */ sectionsize = 0; /* How far from the first dollar sign are we? */ found = 0; /* Have we found the end of the dollarquote? */ /* Scan forward until we hit the matching dollarsign */ while ((ch = *statement++)) { sectionsize++; if ('$' == 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 -= sectionsize; if (!ch) { ch = 1; /* So the top loop still works */ statement--; } continue; } /* We only need to create a dollarstring if something was between the two dollar signs */ if (sectionsize >= 1) { New(0, dollarstring, sectionsize, char); /* note: a true array, not a null-terminated string */ strncpy(dollarstring, statement-sectionsize, sectionsize); } /* Move on and see if the quote is ever closed */ inside_dollar=0; /* Are we evaluating the dollar sign for the end? */ dollarsize = sectionsize; xlen=0; /* The current character we are tracing */ found=0; while ((ch = *statement++)) { sectionsize++; if (inside_dollar) { /* Special case of $$ */ if (dollarsize < 1) { found = DBDPG_TRUE; break; } if (ch == dollarstring[xlen++]) { /* Got a total match? */ if (xlen >= dollarsize) { found = DBDPG_TRUE; statement++; sectionsize--; break; } } else { /* False dollar string: reset */ inside_dollar=0; xlen=0; /* Fall through in case this is a dollar sign */ } } if ('$' == ch) { inside_dollar = DBDPG_TRUE; } } /* Once here, we are either rewinding, or are done parsing the string */ /* If end of string, rewind one character */ if (0==ch) { sectionsize--; } if (dollarstring) Safefree(dollarstring); /* Advance our cursor to the current position */ currpos += sectionsize+1; statement--; /* Rewind statement by one */ /* If not found, might be end of string, so set ch */ if (!found) { ch = 1; } /* Regardless if found or not, we send it back */ continue; } /* end dollar quoting */ /* All we care about at this point is placeholder characters and end of string */ if ('?' != ch && '$' != ch && ':' != ch && 0!=ch) { continue; } /* 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) { Renew(original_statement, strlen(statement-currpos), char); Copy(statement-currpos, original_statement, strlen(statement-currpos), 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) { sectionsize = 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-sectionsize, strlen(thisph->fooname) > sectionsize ? strlen(thisph->fooname) : sectionsize)) { newseg->placeholder = xint; newseg->ph = thisph; break; } } if (0==newseg->placeholder) { imp_sth->numphs++; newseg->placeholder = imp_sth->numphs; New(0, newph, 1, ph_t); /* freed in dbd_st_destroy */ newseg->ph = newph; newph->nextph = NULL; newph->bind_type = NULL; newph->value = NULL; newph->quoted = NULL; newph->referenced = DBDPG_FALSE; newph->defaultval = DBDPG_TRUE; newph->isdefault = DBDPG_FALSE; newph->iscurrent = DBDPG_FALSE; newph->isinout = DBDPG_FALSE; New(0, newph->fooname, sectionsize+1, char); /* freed in dbd_st_destroy */ Copy(statement-sectionsize, newph->fooname, sectionsize, char); newph->fooname[sectionsize] = '\0'; if (NULL==currph) { imp_sth->ph = newph; } else { currph->nextph = newph; } currph = newph; } } /* end if placeholder_type */ sectionsize = sectionstop-sectionstart; /* 4-0 for "ABCD" */ if (sectionsize>0) { New(0, newseg->segment, sectionsize+1, char); /* freed in dbd_st_destroy */ Copy(statement-(currpos-sectionstart), newseg->segment, sectionsize, char); newseg->segment[sectionsize] = '\0'; imp_sth->totalsize += sectionsize; } else { newseg->segment = NULL; } if (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 */ topdollar=0; for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { if (currseg->placeholder > topdollar) topdollar = currseg->placeholder; } /* Make sure every placeholder from 1 to topdollar is used at least once */ for (xint=1; xint <= topdollar; xint++) { for (found=0, currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { if (currseg->placeholder==xint) { found = DBDPG_TRUE; break; } } if (!found) croak("Invalid placeholders: must start at $1 and increment one at a time (expected: $%d)\n", xint); } if (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); for (xlen=1,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), 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; STRLEN execsize; PGresult * result; int status = -1; seg_t * currseg; bool oldprepare = DBDPG_TRUE; ph_t * currph; long power_of_ten; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_st_prepare_statement\n", THEADER_slow); #if PGLIBVERSION >= 80000 oldprepare = DBDPG_FALSE; #endif Renew(imp_sth->prepare_name, 25, char); /* freed in dbd_st_destroy */ /* Name is "dbdpg_xPID_#", where x is 'p'ositive or 'n'egative */ 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), oldprepare is %d\n", THEADER_slow, imp_sth->prepare_name, oldprepare); /* PQprepare was not added until 8.0 */ execsize = imp_sth->totalsize; if (oldprepare) execsize += strlen("PREPARE AS ") + strlen(imp_sth->prepare_name); /* Two spaces! */ if (imp_sth->numphs!=0) { if (oldprepare) { execsize += strlen("()"); execsize += imp_sth->numphs-1; /* for the commas */ } for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { if (0==currseg->placeholder) continue; /* The parameter itself: dollar sign plus digit(s) */ 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; if (oldprepare) { /* The parameter type, only once per number please */ if (!currseg->ph->referenced) execsize += strlen(currseg->ph->bind_type->type_name); currseg->ph->referenced = DBDPG_TRUE; } } } New(0, statement, execsize+1, char); /* freed below */ if (oldprepare) { sprintf(statement, "PREPARE %s", imp_sth->prepare_name); if (imp_sth->numphs!=0) { strcat(statement, "("); for (x=0, currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { if (currseg->placeholder && currseg->ph->referenced) { if (x!=0) strcat(statement, ","); strcat(statement, currseg->ph->bind_type->type_name); x=1; currseg->ph->referenced = DBDPG_FALSE; } } strcat(statement, ")"); } strcat(statement, " AS "); } else { statement[0] = '\0'; } /* Construct the statement, with proper placeholders */ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { 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); if (oldprepare) { status = _result(aTHX_ imp_dbh, statement); } else { int 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); TRACE_PQPREPARE; result = PQprepare(imp_dbh->conn, imp_sth->prepare_name, statement, params, imp_sth->PQoids); status = _sqlstate(aTHX_ imp_dbh, result); if (result) { TRACE_PQCLEAR; PQclear(result); } if (TRACE6_slow) TRC(DBILOGFP, "%sUsing PQprepare: %s\n", THEADER_slow, statement); } Safefree(statement); if (PGRES_COMMAND_OK != status) { TRACE_PQERRORMESSAGE; Safefree(imp_sth->prepare_name); imp_sth->prepare_name = NULL; 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; } imp_sth->prepared_by_us = DBDPG_TRUE; /* Done here so deallocate is not called spuriously */ imp_dbh->prepare_number++; /* We do this at the end so we don't increment if we fail above */ 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 (strnEQ("DBD::Pg::DefaultValue", neatsvpv(newvalue,0), 21) || strnEQ("DBI::DefaultValue", neatsvpv(newvalue,0), 17)) { /* This is a special type */ Safefree(currph->value); currph->value = NULL; currph->valuelen = 0; currph->isdefault = DBDPG_TRUE; imp_sth->has_default = DBDPG_TRUE; } else if (strnEQ("DBD::Pg::Current", neatsvpv(newvalue,0), 16)) { /* 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) { 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_fetch((HV*)SvRV(attribs),"pg_type", 7, 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)) { /* 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, 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_delimeter); /* 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 delim 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_delimeter == *input) { } else if ('}' == *input) { } else if ('"' == *input) { in_quote = seen_quotes = (bool)1; } else { string[section_size++] = *input; } if ('}' == *input || (coltype->array_delimeter == *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, &PL_sv_undef); } 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; int i, j; const char * const client_encoding = PQparameterStatus(imp_dbh->conn, "client_encoding"); if (NULL != client_encoding) { STRLEN len = strlen(client_encoding); Newx(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); PGresult * result; ExecStatusType status = PGRES_FATAL_ERROR; /* Assume the worst */ PGTransactionStatusType txn_status; char * cmdStatus = NULL; 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 */ if (imp_dbh->async_status) { 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 asychronous 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 = 1; 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); TRACE_PQEXEC; result = PQexec(imp_dbh->conn, sql); status = _sqlstate(aTHX_ imp_dbh, 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(result); break; case PGRES_COMMAND_OK: /* non-select statement */ TRACE_PQCMDSTATUS; cmdStatus = PQcmdStatus(result); /* If the statement indicates a number of rows, we want to return that */ /* Note: COPY and FETCH do not currently reach here, although they return numbers */ if (0 == strncmp(cmdStatus, "INSERT", 6)) { /* INSERT(space)oid(space)numrows */ for (rows=8; cmdStatus[rows-1] != ' '; rows++) { } rows = atol(cmdStatus + rows); } else if (0 == strncmp(cmdStatus, "MOVE", 4)) { rows = atol(cmdStatus + 5); } else if (0 == strncmp(cmdStatus, "DELETE", 6) || 0 == strncmp(cmdStatus, "UPDATE", 6) || 0 == strncmp(cmdStatus, "SELECT", 6)) { rows = atol(cmdStatus + 7); } 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_ 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 (result) { TRACE_PQCLEAR; PQclear(result); } else { 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) */ long dbd_st_execute (SV * sth, imp_sth_t * imp_sth) { dTHX; D_imp_dbh_from_sth; ph_t * currph; int status = -1; STRLEN execsize, x; unsigned int placeholder_digits; seg_t * currseg; char * statement = NULL; int num_fields; long ret = -2; PQExecType pqtype = PQTYPE_UNKNOWN; 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, char); currph->value[currph->valuelen] = '\0'; } } imp_sth->all_bound = DBDPG_TRUE; } /* Check for old async transactions */ if (imp_dbh->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 pg_quickexec (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 7. pg_server_prepare is 2, but all placeholders are not bound */ if (!imp_sth->is_dml || imp_sth->has_default || imp_sth->has_current || imp_sth->direct || !imp_sth->numphs || !imp_sth->server_prepare || (2==imp_sth->server_prepare && imp_sth->numbound != imp_sth->numphs) ) pqtype = PQTYPE_EXEC; 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 not 0 4. The "onetime" attribute has not been set 5. There are no DEFAULT or CURRENT values 6a. The attribute "pg_server_prepare" is 1 OR 6b. All placeholders are bound (and "pg_server_prepare" is 2) */ 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 */ } } /* Set the size of each actual in-place placeholder */ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { if (currseg->placeholder!=0) execsize += currseg->ph->quotedlen; } } else { /* We are using a server that can handle PQexecParams/PQexecPrepared */ /* Put all values into an array to pass to 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, PQexecParams, or PQexecPrepared */ if (PQTYPE_EXEC == pqtype) { /* PQexec */ if (TRACE5_slow) TRC(DBILOGFP, "%sPQexec\n", THEADER_slow); /* Go through and quote each value, then turn into a giant statement */ for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { if (currseg->placeholder!=0) execsize += currseg->ph->quotedlen; } New(0, statement, execsize+1, char); /* freed below */ statement[0] = '\0'; for (currseg=imp_sth->seg; NULL != currseg; currseg=currseg->nextseg) { 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; ret = PQsendQuery(imp_dbh->conn, statement); } else { TRACE_PQEXEC; imp_sth->result = PQexec(imp_dbh->conn, statement); } Safefree(statement); } else if (PQTYPE_PARAMS == pqtype) { /* PQexecParams */ if (TRACE5_slow) TRC(DBILOGFP, "%sPQexecParams\n", THEADER_slow); /* 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 */ 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 PQexecParams with (%s)\n", THEADER_slow, statement); if (imp_sth->async_flag & PG_ASYNC) { TRACE_PQSENDQUERYPARAMS; ret = PQsendQueryParams (imp_dbh->conn, statement, imp_sth->numphs, imp_sth->PQoids, imp_sth->PQvals, imp_sth->PQlens, imp_sth->PQfmts, 0); } else { TRACE_PQEXECPARAMS; imp_sth->result = PQexecParams (imp_dbh->conn, statement, imp_sth->numphs, imp_sth->PQoids, imp_sth->PQvals, imp_sth->PQlens, imp_sth->PQfmts, 0); } Safefree(statement); } else if (PQTYPE_PREPARED == pqtype) { /* PQexecPrepared */ if (TRACE4_slow) TRC(DBILOGFP, "%sPQexecPrepared\n", THEADER_slow); /* 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 (TRACE5_slow) TRC(DBILOGFP, "%sUsing previously prepared statement (%s)\n", THEADER_slow, imp_sth->prepare_name); } 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 PQexecPrepared with (%s)\n", THEADER_slow, 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; ret = PQsendQueryPrepared (imp_dbh->conn, imp_sth->prepare_name, imp_sth->numphs, imp_sth->PQvals, imp_sth->PQlens, imp_sth->PQfmts, 0); } else { TRACE_PQEXECPREPARED; imp_sth->result = PQexecPrepared (imp_dbh->conn, imp_sth->prepare_name, imp_sth->numphs, imp_sth->PQvals, imp_sth->PQlens, imp_sth->PQfmts, 0); } } /* end new-style prepare */ /* Some form of PQexec* 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", THEADER_slow); imp_dbh->async_status = 1; imp_sth->async_status = 1; imp_dbh->async_sth = imp_sth; 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 */ char *cmdStatus = NULL; bool gotrows = DBDPG_FALSE; if (TRACE5_slow) TRC(DBILOGFP, "%sStatus was PGRES_COMMAND_OK\n", THEADER_slow); if (imp_sth->result) { TRACE_PQCMDSTATUS; cmdStatus = PQcmdStatus(imp_sth->result); if (0 == strncmp(cmdStatus, "INSERT", 6)) { /* INSERT(space)oid(space)numrows */ for (ret=8; cmdStatus[ret-1] != ' '; ret++) { } ret = atol(cmdStatus + ret); gotrows = DBDPG_TRUE; } else if (0 == strncmp(cmdStatus, "MOVE", 4)) { ret = atol(cmdStatus + 5); gotrows = DBDPG_TRUE; } else if (0 == strncmp(cmdStatus, "DELETE", 6) || 0 == strncmp(cmdStatus, "UPDATE", 6) || 0 == strncmp(cmdStatus, "SELECT", 6)) { ret = atol(cmdStatus + 7); gotrows = DBDPG_TRUE; } } 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; case PG_INT2: case PG_INT4: #if IVSIZE >= 8 && LONGSIZE >= 8 case PG_INT8: #endif 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); } } } } 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); if (DBIc_ACTIVE(imp_sth) && imp_sth->result) { TRACE_PQCLEAR; PQclear(imp_sth->result); imp_sth->result = NULL; imp_sth->rows = 0; } /* Are we in the middle of an async for this statement handle? */ if (imp_dbh->async_status) { if (imp_sth->async_status) { handle_old_async(aTHX_ sth, imp_dbh, PG_OLDQUERY_WAIT); } } imp_sth->async_status = 0; imp_dbh->async_sth = NULL; 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]; char * stmt; int status; PGTransactionStatusType tstatus; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_st_deallocate_statement\n", THEADER_slow); 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, strlen(imp_dbh->sqlstate)+1); 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; } } 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); 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, strlen(tempsqlstate)+1); } 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; 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() != 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; } if (imp_dbh->async_status) { 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 (imp_sth->result) { TRACE_PQCLEAR; PQclear(imp_sth->result); imp_sth->result = NULL; } /* Free all the segments */ currseg = imp_sth->seg; while (NULL != currseg) { Safefree(currseg->segment); currseg->ph = NULL; nextseg = currseg->nextseg; Safefree(currseg); currseg = nextseg; } imp_sth->seg = NULL; /* Free all the placeholders */ currph = imp_sth->ph; while (NULL != currph) { Safefree(currph->fooname); Safefree(currph->value); Safefree(currph->quoted); currph->bind_type = NULL; nextph = currph->nextph; Safefree(currph); currph = nextph; } imp_sth->ph = NULL; if (imp_dbh->async_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; char * buffer; buffer = SvPV_nolen(svbuf); 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) { *buffer = '\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) { PQclear(result); result = PQgetResult(imp_dbh->conn); } TRACE_PQCLEAR; PQclear(result); 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) { PQclear(result); result = PQgetResult(imp_dbh->conn); } 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_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 */ /* ================================================================== */ 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); if (imp_dbh->pg_server_version < 80000) croak("Savepoints are only supported on server version 8.0 or higher"); /* 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); if (imp_dbh->pg_server_version < 80000) croak("Savepoints are only supported on server version 8.0 or higher"); /* 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); if (imp_dbh->pg_server_version < 80000) croak("Savepoints are only supported on server version 8.0 or higher"); /* 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) { int status = -1; 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) { 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 = -1; 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: %d)\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: %d)\n", THEADER_slow, fd, (int)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: %d)\n", THEADER_slow, fd, (int)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 */ } /* ================================================================== */ int pg_db_lo_lseek (SV * dbh, int fd, int offset, int whence) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_lseek (fd: %d offset: %d 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; if (TLIBPQ_slow) { TRC(DBILOGFP, "%slo_lseek\n", THEADER_slow); } return lo_lseek(imp_dbh->conn, fd, offset, whence); /* new position, -1 on error */ } /* ================================================================== */ int 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; 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, size_t len) { dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_truncate (fd: %d length: %d)\n", THEADER_slow, fd, (int)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; 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: %d)\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: %d)\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) { Oid loid; dTHX; D_imp_dbh(dbh); if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_lo_export (objectid: %d 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); } loid = 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, -1==loid ? 0 : 1)) return -1; } return loid; } /* ================================================================== */ 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 = PGRES_FATAL_ERROR; long rows = 0; char *cmdStatus = NULL; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_result\n", THEADER_slow); if (1 != 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; } 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); if (imp_dbh->async_sth) { 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); } break; case PGRES_COMMAND_OK: /* non-select statement */ TRACE_PQCMDSTATUS; cmdStatus = PQcmdStatus(result); if (0 == strncmp(cmdStatus, "INSERT", 6)) { /* INSERT(space)oid(space)numrows */ for (rows=8; cmdStatus[rows-1] != ' '; rows++) { } rows = atol(cmdStatus + rows); } else if (0 == strncmp(cmdStatus, "MOVE", 4)) { rows = atol(cmdStatus + 5); } else if (0 == strncmp(cmdStatus, "DELETE", 6) || 0 == strncmp(cmdStatus, "UPDATE", 6) || 0 == strncmp(cmdStatus, "SELECT", 6)) { rows = atol(cmdStatus + 7); } 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: default: rows = -2; TRACE_PQERRORMESSAGE; pg_error(aTHX_ h, status, PQerrorMessage(imp_dbh->conn)); break; } if (imp_dbh->async_sth) { if (imp_dbh->async_sth->result) { /* For potential multi-result sets */ TRACE_PQCLEAR; PQclear(imp_dbh->async_sth->result); } imp_dbh->async_sth->result = result; } else { TRACE_PQCLEAR; PQclear(result); } } if (imp_dbh->async_sth) { imp_dbh->async_sth->rows = rows; imp_dbh->async_sth->async_status = 0; } imp_dbh->async_status = 0; 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 */ int pg_db_ready(SV *h, imp_dbh_t *imp_dbh) { dTHX; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_ready (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\n"); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_ready (error: no async)\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; } if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_ready\n", THEADER_slow); TRACE_PQISBUSY; return PQisBusy(imp_dbh->conn) ? 0 : 1; } /* end of pg_db_ready */ /* ================================================================== */ /* 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; PGcancel *cancel; char errbuf[256]; PGresult *result; ExecStatusType status; if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_db_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_cancel (error: no async)\n", THEADER_slow); return DBDPG_FALSE; } if (-1 == imp_dbh->async_status) { pg_error(aTHX_ h, PGRES_FATAL_ERROR, "Asychronous query has already been cancelled"); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_cancel (error: async cancelled)\n", THEADER_slow); return DBDPG_FALSE; } /* Get the cancel structure */ TRACE_PQGETCANCEL; cancel = PQgetCancel(imp_dbh->conn); /* This almost always works. If not, free our structure and complain loudly */ TRACE_PQGETCANCEL; 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 pg_db_cancel (error: cancel failed)\n", THEADER_slow); return DBDPG_FALSE; } TRACE_PQFREECANCEL; PQfreeCancel(cancel); /* Whatever else happens, we should no longer be inside of an async query */ imp_dbh->async_status = -1; if (imp_dbh->async_sth) imp_dbh->async_sth->async_status = -1; /* Read in the result - assume only one */ TRACE_PQGETRESULT; result = PQgetResult(imp_dbh->conn); status = _sqlstate(aTHX_ imp_dbh, result); if (!result) { pg_error(aTHX_ h, PGRES_FATAL_ERROR, "Failed to get a result after PQcancel"); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_cancel (error: no result)\n", THEADER_slow); return DBDPG_FALSE; } TRACE_PQCLEAR; PQclear(result); /* If we actually cancelled a running query, just return true - the caller must rollback if needed */ if (0 == strncmp(imp_dbh->sqlstate, "57014", 5)) { if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_cancel\n", THEADER_slow); return DBDPG_TRUE; } /* If we got any other error, make sure we report it */ if (0 != strncmp(imp_dbh->sqlstate, "00000", 5)) { if (TRACEWARN_slow) TRC(DBILOGFP, "%sQuery was not cancelled: was already finished\n", THEADER_slow); TRACE_PQERRORMESSAGE; pg_error(aTHX_ h, status, PQerrorMessage(imp_dbh->conn)); if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_cancel (error)\n", THEADER_slow); } else if (TEND_slow) TRC(DBILOGFP, "%sEnd pg_db_cancel\n", THEADER_slow); return DBDPG_FALSE; } /* 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) { PGresult *result; ExecStatusType status; if (TSTART_slow) TRC(DBILOGFP, "%sBegin handle_old_sync (flag: %d)\n", THEADER_slow, asyncflag); 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)) { PGcancel *cancel; char errbuf[256]; int cresult; if (TRACE3_slow) TRC(DBILOGFP, "%sAttempting to cancel query\n", THEADER_slow); TRACE_PQGETCANCEL; cancel = PQgetCancel(imp_dbh->conn); TRACE_PQCANCEL; cresult = PQcancel(cancel,errbuf,255); if (! cresult) { if (TRACEWARN_slow) { TRC(DBILOGFP, "%sPQcancel failed: %s\n", THEADER_slow, errbuf); } _fatal_sqlstate(aTHX_ imp_dbh); pg_error(aTHX_ handle, PGRES_FATAL_ERROR, "Could not cancel previous command"); if (TEND_slow) TRC(DBILOGFP, "%sEnd handle_old_async (error: could not cancel)\n", THEADER_slow); return -2; } TRACE_PQFREECANCEL; PQfreeCancel(cancel); /* Suck up the cancellation notice */ TRACE_PQGETRESULT; while ((result = PQgetResult(imp_dbh->conn)) != NULL) { TRACE_PQCLEAR; PQclear(result); } /* We need to rollback! - reprepare!? */ TRACE_PQEXEC; PQexec(imp_dbh->conn, "rollback"); imp_dbh->done_begin = DBDPG_FALSE; } } else if (asyncflag & PG_OLDQUERY_WAIT || imp_dbh->async_status == -1) { /* 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); } TRACE_PQGETRESULT; while ((result = PQgetResult(imp_dbh->conn)) != NULL) { status = _sqlstate(aTHX_ imp_dbh, result); 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) { 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; } } } 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 = 0; if (imp_dbh->async_sth) imp_dbh->async_sth->async_status = 0; 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; PGcancel *cancel; char errbuf[256]; if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_st_cancel\n", THEADER_slow); /* Get the cancel structure */ TRACE_PQGETCANCEL; cancel = PQgetCancel(imp_dbh->conn); /* This almost always works. If not, free our structure and complain loudly */ TRACE_PQGETCANCEL; if (!PQcancel(cancel, errbuf, sizeof(errbuf))) { TRACE_PQFREECANCEL; PQfreeCancel(cancel); if (TRACEWARN_slow) TRC(DBILOGFP, "%sPQcancel failed: %s\n", THEADER_slow, errbuf); pg_error(aTHX_ sth, PGRES_FATAL_ERROR, "PQcancel failed"); if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_st_cancel (error: cancel failed)\n", THEADER_slow); return DBDPG_FALSE; } TRACE_PQFREECANCEL; PQfreeCancel(cancel); 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; int 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 = PGRES_FATAL_ERROR; PGresult * result; TRACE_PQNFIELDS; int fields = PQnfields(imp_sth->result); AV* result_av = newAV(); av_extend(result_av, fields); while(fields--){ TRACE_PQFTABLE; int 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[200]; snprintf(statement, sizeof(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 = %d 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) { TRACE_PQGETLENGTH; int len = PQgetlength(result, 0, 0) + 1; TRACE_PQGETLENGTH; len += PQgetlength(result, 0, 1) + 1; TRACE_PQGETLENGTH; len += PQgetlength(result, 0, 2); SV* table_name = newSV(len); TRACE_PQGETVALUE; char *nsp = PQgetvalue(result, 0, 0); TRACE_PQGETVALUE; char *tbl = PQgetvalue(result, 0, 1); TRACE_PQGETVALUE; 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.7.0/types.c0000644000175000017500000012460413161341517012431 0ustar greggreg/* Copyright (c) 2003-2017 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. */ /* Please do not edit the C portions of this file directly. It is automatically generated by the enclosed Perl script. */ #include "Pg.h" static sql_type_info_t pg_types[] = { {PG_ABSTIMEARRAY ,"_abstime" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_ACLITEMARRAY ,"_aclitem" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_BITARRAY ,"_bit" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_BOOLARRAY ,"_bool" ,1,',',"array_out" ,quote_string,dequote_string,{0},3}, {PG_BOXARRAY ,"_box" ,1,';',"array_out" ,quote_string,dequote_string,{0},0}, {PG_BPCHARARRAY ,"_bpchar" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_BYTEAARRAY ,"_bytea" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_CHARARRAY ,"_char" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_CIDARRAY ,"_cid" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_CIDRARRAY ,"_cidr" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_CIRCLEARRAY ,"_circle" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_CSTRINGARRAY ,"_cstring" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_DATEARRAY ,"_date" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_DATERANGEARRAY ,"_daterange" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_FLOAT4ARRAY ,"_float4" ,1,',',"array_out" ,quote_string,dequote_string,{0},2}, {PG_FLOAT8ARRAY ,"_float8" ,1,',',"array_out" ,quote_string,dequote_string,{0},2}, {PG_GTSVECTORARRAY ,"_gtsvector" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_INETARRAY ,"_inet" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_INT2ARRAY ,"_int2" ,1,',',"array_out" ,quote_string,dequote_string,{0},1}, {PG_INT2VECTORARRAY ,"_int2vector" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_INT4ARRAY ,"_int4" ,1,',',"array_out" ,quote_string,dequote_string,{0},1}, {PG_INT4RANGEARRAY ,"_int4range" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_INT8ARRAY ,"_int8" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_INT8RANGEARRAY ,"_int8range" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_INTERVALARRAY ,"_interval" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_JSONARRAY ,"_json" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_JSONBARRAY ,"_jsonb" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_LINEARRAY ,"_line" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_LSEGARRAY ,"_lseg" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_MACADDRARRAY ,"_macaddr" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_MACADDR8ARRAY ,"_macaddr8" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_MONEYARRAY ,"_money" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_NAMEARRAY ,"_name" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_NUMERICARRAY ,"_numeric" ,1,',',"array_out" ,quote_string,dequote_string,{0},2}, {PG_NUMRANGEARRAY ,"_numrange" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_OIDARRAY ,"_oid" ,1,',',"array_out" ,quote_string,dequote_string,{0},1}, {PG_OIDVECTORARRAY ,"_oidvector" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_PATHARRAY ,"_path" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_PG_LSNARRAY ,"_pg_lsn" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_POINTARRAY ,"_point" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_POLYGONARRAY ,"_polygon" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_RECORDARRAY ,"_record" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_REFCURSORARRAY ,"_refcursor" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_REGCLASSARRAY ,"_regclass" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_REGCONFIGARRAY ,"_regconfig" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_REGDICTIONARYARRAY,"_regdictionary" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_REGNAMESPACEARRAY ,"_regnamespace" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_REGOPERARRAY ,"_regoper" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_REGOPERATORARRAY ,"_regoperator" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_REGPROCARRAY ,"_regproc" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_REGPROCEDUREARRAY ,"_regprocedure" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_REGROLEARRAY ,"_regrole" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_REGTYPEARRAY ,"_regtype" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_RELTIMEARRAY ,"_reltime" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TEXTARRAY ,"_text" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TIDARRAY ,"_tid" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TIMEARRAY ,"_time" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TIMESTAMPARRAY ,"_timestamp" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TIMESTAMPTZARRAY ,"_timestamptz" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TIMETZARRAY ,"_timetz" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TINTERVALARRAY ,"_tinterval" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TSQUERYARRAY ,"_tsquery" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TSRANGEARRAY ,"_tsrange" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TSTZRANGEARRAY ,"_tstzrange" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TSVECTORARRAY ,"_tsvector" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_TXID_SNAPSHOTARRAY,"_txid_snapshot" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_UUIDARRAY ,"_uuid" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_VARBITARRAY ,"_varbit" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_VARCHARARRAY ,"_varchar" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_XIDARRAY ,"_xid" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_XMLARRAY ,"_xml" ,1,',',"array_out" ,quote_string,dequote_string,{0},0}, {PG_ABSTIME ,"abstime" ,1,',',"abstimeout" ,quote_string,dequote_string,{0},0}, {PG_ACLITEM ,"aclitem" ,1,',',"aclitemout" ,quote_string,dequote_string,{0},0}, {PG_ANY ,"any" ,1,',',"any_out" ,quote_string,dequote_string,{0},0}, {PG_ANYARRAY ,"anyarray" ,1,',',"anyarray_out" ,quote_string,dequote_string,{0},0}, {PG_ANYELEMENT ,"anyelement" ,1,',',"anyelement_out" ,quote_string,dequote_string,{0},0}, {PG_ANYENUM ,"anyenum" ,1,',',"anyenum_out" ,quote_string,dequote_string,{0},0}, {PG_ANYNONARRAY ,"anynonarray" ,1,',',"anynonarray_out" ,quote_string,dequote_string,{0},0}, {PG_ANYRANGE ,"anyrange" ,1,',',"anyrange_out" ,quote_string,dequote_string,{0},0}, {PG_BIT ,"bit" ,1,',',"bit_out" ,quote_string,dequote_string,{0},0}, {PG_BOOL ,"bool" ,1,',',"boolout" ,quote_bool ,dequote_bool ,{SQL_BOOLEAN},3}, {PG_BOX ,"box" ,1,';',"box_out" ,quote_geom ,dequote_string,{0},0}, {PG_BPCHAR ,"bpchar" ,1,',',"bpcharout" ,quote_string,dequote_char ,{SQL_CHAR},0}, {PG_BYTEA ,"bytea" ,1,',',"byteaout" ,quote_bytea ,dequote_bytea ,{SQL_VARBINARY},0}, {PG_CHAR ,"char" ,1,',',"charout" ,quote_string,dequote_char ,{SQL_CHAR},0}, {PG_CID ,"cid" ,1,',',"cidout" ,quote_string,dequote_string,{0},0}, {PG_CIDR ,"cidr" ,1,',',"cidr_out" ,quote_string,dequote_string,{0},0}, {PG_CIRCLE ,"circle" ,1,',',"circle_out" ,quote_circle,dequote_string,{0},0}, {PG_CSTRING ,"cstring" ,1,',',"cstring_out" ,quote_string,dequote_string,{0},0}, {PG_DATE ,"date" ,1,',',"date_out" ,quote_string,dequote_string,{SQL_TYPE_DATE},0}, {PG_DATERANGE ,"daterange" ,1,',',"range_out" ,quote_string,dequote_string,{0},0}, {PG_EVENT_TRIGGER ,"event_trigger" ,1,',',"event_trigger_out" ,quote_string,dequote_string,{0},0}, {PG_FDW_HANDLER ,"fdw_handler" ,1,',',"fdw_handler_out" ,quote_string,dequote_string,{0},0}, {PG_FLOAT4 ,"float4" ,1,',',"float4out" ,quote_float ,null_dequote ,{0},2}, {PG_FLOAT8 ,"float8" ,1,',',"float8out" ,quote_float ,null_dequote ,{SQL_FLOAT},2}, {PG_GTSVECTOR ,"gtsvector" ,1,',',"gtsvectorout" ,quote_string,dequote_string,{0},0}, {PG_INDEX_AM_HANDLER ,"index_am_handler" ,1,',',"index_am_handler_out",quote_string,dequote_string,{0},0}, {PG_INET ,"inet" ,1,',',"inet_out" ,quote_string,dequote_string,{0},0}, {PG_INT2 ,"int2" ,1,',',"int2out" ,quote_int ,null_dequote ,{SQL_SMALLINT},1}, {PG_INT2VECTOR ,"int2vector" ,1,',',"int2vectorout" ,quote_string,dequote_string,{0},0}, {PG_INT4 ,"int4" ,1,',',"int4out" ,quote_int ,null_dequote ,{SQL_INTEGER},1}, {PG_INT4RANGE ,"int4range" ,1,',',"range_out" ,quote_string,dequote_string,{0},0}, {PG_INT8 ,"int8" ,1,',',"int8out" ,quote_int ,null_dequote ,{SQL_BIGINT},0}, {PG_INT8RANGE ,"int8range" ,1,',',"range_out" ,quote_string,dequote_string,{0},0}, {PG_INTERNAL ,"internal" ,1,',',"internal_out" ,quote_string,dequote_string,{0},0}, {PG_INTERVAL ,"interval" ,1,',',"interval_out" ,quote_string,dequote_string,{0},0}, {PG_JSON ,"json" ,1,',',"json_out" ,quote_string,dequote_string,{0},0}, {PG_JSONB ,"jsonb" ,1,',',"jsonb_out" ,quote_string,dequote_string,{0},0}, {PG_LANGUAGE_HANDLER ,"language_handler" ,1,',',"language_handler_out",quote_string,dequote_string,{0},0}, {PG_LINE ,"line" ,1,',',"line_out" ,quote_geom ,dequote_string,{0},0}, {PG_LSEG ,"lseg" ,1,',',"lseg_out" ,quote_geom ,dequote_string,{0},0}, {PG_MACADDR ,"macaddr" ,1,',',"macaddr_out" ,quote_string,dequote_string,{0},0}, {PG_MACADDR8 ,"macaddr8" ,1,',',"macaddr8_out" ,quote_string,dequote_string,{0},0}, {PG_MONEY ,"money" ,1,',',"cash_out" ,quote_string,dequote_string,{0},0}, {PG_NAME ,"name" ,1,',',"nameout" ,quote_name ,null_dequote ,{SQL_VARCHAR},0}, {PG_NUMERIC ,"numeric" ,1,',',"numeric_out" ,quote_float ,null_dequote ,{SQL_NUMERIC},2}, {PG_NUMRANGE ,"numrange" ,1,',',"range_out" ,quote_string,dequote_string,{0},0}, {PG_OID ,"oid" ,1,',',"oidout" ,quote_int ,null_dequote ,{0},1}, {PG_OIDVECTOR ,"oidvector" ,1,',',"oidvectorout" ,quote_string,dequote_string,{0},0}, {PG_OPAQUE ,"opaque" ,1,',',"opaque_out" ,quote_string,dequote_string,{0},0}, {PG_PATH ,"path" ,1,',',"path_out" ,quote_path ,dequote_string,{0},0}, {PG_PG_ATTRIBUTE ,"pg_attribute" ,1,',',"record_out" ,quote_string,dequote_string,{0},0}, {PG_PG_CLASS ,"pg_class" ,1,',',"record_out" ,quote_string,dequote_string,{0},0}, {PG_PG_DDL_COMMAND ,"pg_ddl_command" ,1,',',"pg_ddl_command_out" ,quote_string,dequote_string,{0},0}, {PG_PG_DEPENDENCIES ,"pg_dependencies" ,1,',',"pg_dependencies_out" ,quote_string,dequote_string,{0},0}, {PG_PG_LSN ,"pg_lsn" ,1,',',"pg_lsn_out" ,quote_string,dequote_string,{0},0}, {PG_PG_NDISTINCT ,"pg_ndistinct" ,1,',',"pg_ndistinct_out" ,quote_string,dequote_string,{0},0}, {PG_PG_NODE_TREE ,"pg_node_tree" ,1,',',"pg_node_tree_out" ,quote_string,dequote_string,{0},0}, {PG_PG_PROC ,"pg_proc" ,1,',',"record_out" ,quote_string,dequote_string,{0},0}, {PG_PG_TYPE ,"pg_type" ,1,',',"record_out" ,quote_string,dequote_string,{0},0}, {PG_POINT ,"point" ,1,',',"point_out" ,quote_geom ,dequote_string,{0},0}, {PG_POLYGON ,"polygon" ,1,',',"poly_out" ,quote_geom ,dequote_string,{0},0}, {PG_RECORD ,"record" ,1,',',"record_out" ,quote_string,dequote_string,{0},0}, {PG_REFCURSOR ,"refcursor" ,1,',',"textout" ,quote_string,dequote_string,{0},0}, {PG_REGCLASS ,"regclass" ,1,',',"regclassout" ,quote_string,dequote_string,{0},0}, {PG_REGCONFIG ,"regconfig" ,1,',',"regconfigout" ,quote_string,dequote_string,{0},0}, {PG_REGDICTIONARY ,"regdictionary" ,1,',',"regdictionaryout" ,quote_string,dequote_string,{0},0}, {PG_REGNAMESPACE ,"regnamespace" ,1,',',"regnamespaceout" ,quote_string,dequote_string,{0},0}, {PG_REGOPER ,"regoper" ,1,',',"regoperout" ,quote_string,dequote_string,{0},0}, {PG_REGOPERATOR ,"regoperator" ,1,',',"regoperatorout" ,quote_string,dequote_string,{0},0}, {PG_REGPROC ,"regproc" ,1,',',"regprocout" ,quote_string,dequote_string,{0},0}, {PG_REGPROCEDURE ,"regprocedure" ,1,',',"regprocedureout" ,quote_string,dequote_string,{0},0}, {PG_REGROLE ,"regrole" ,1,',',"regroleout" ,quote_string,dequote_string,{0},0}, {PG_REGTYPE ,"regtype" ,1,',',"regtypeout" ,quote_string,dequote_string,{0},0}, {PG_RELTIME ,"reltime" ,1,',',"reltimeout" ,quote_string,dequote_string,{0},0}, {PG_SMGR ,"smgr" ,1,',',"smgrout" ,quote_string,dequote_string,{0},0}, {PG_TEXT ,"text" ,1,',',"textout" ,quote_string,dequote_string,{SQL_LONGVARCHAR},0}, {PG_TID ,"tid" ,1,',',"tidout" ,quote_geom ,dequote_string,{0},0}, {PG_TIME ,"time" ,1,',',"time_out" ,quote_string,dequote_string,{SQL_TYPE_TIME},0}, {PG_TIMESTAMP ,"timestamp" ,1,',',"timestamp_out" ,quote_string,dequote_string,{SQL_TIMESTAMP},0}, {PG_TIMESTAMPTZ ,"timestamptz" ,1,',',"timestamptz_out" ,quote_string,dequote_string,{SQL_TYPE_TIMESTAMP_WITH_TIMEZONE},0}, {PG_TIMETZ ,"timetz" ,1,',',"timetz_out" ,quote_string,dequote_string,{0},0}, {PG_TINTERVAL ,"tinterval" ,1,',',"tintervalout" ,quote_string,dequote_string,{0},0}, {PG_TRIGGER ,"trigger" ,1,',',"trigger_out" ,quote_string,dequote_string,{0},0}, {PG_TSM_HANDLER ,"tsm_handler" ,1,',',"tsm_handler_out" ,quote_string,dequote_string,{0},0}, {PG_TSQUERY ,"tsquery" ,1,',',"tsqueryout" ,quote_string,dequote_string,{0},0}, {PG_TSRANGE ,"tsrange" ,1,',',"range_out" ,quote_string,dequote_string,{0},0}, {PG_TSTZRANGE ,"tstzrange" ,1,',',"range_out" ,quote_string,dequote_string,{0},0}, {PG_TSVECTOR ,"tsvector" ,1,',',"tsvectorout" ,quote_string,dequote_string,{0},0}, {PG_TXID_SNAPSHOT ,"txid_snapshot" ,1,',',"txid_snapshot_out" ,quote_string,dequote_string,{0},0}, {PG_UNKNOWN ,"unknown" ,1,',',"unknownout" ,quote_string,dequote_string,{0},0}, {PG_UUID ,"uuid" ,1,',',"uuid_out" ,quote_string,dequote_string,{0},0}, {PG_VARBIT ,"varbit" ,1,',',"varbit_out" ,quote_string,dequote_string,{0},0}, {PG_VARCHAR ,"varchar" ,1,',',"varcharout" ,quote_string,dequote_string,{SQL_VARCHAR},0}, {PG_VOID ,"void" ,1,',',"void_out" ,quote_string,dequote_string,{0},0}, {PG_XID ,"xid" ,1,',',"xidout" ,quote_string,dequote_string,{0},0}, {PG_XML ,"xml" ,1,',',"xml_out" ,quote_string,dequote_string,{0},0}, }; sql_type_info_t* pg_type_data(int sql_type) { switch(sql_type) { case PG_ABSTIMEARRAY: return &pg_types[0]; case PG_ACLITEMARRAY: return &pg_types[1]; case PG_BITARRAY: return &pg_types[2]; case PG_BOOLARRAY: return &pg_types[3]; case PG_BOXARRAY: return &pg_types[4]; case PG_BPCHARARRAY: return &pg_types[5]; case PG_BYTEAARRAY: return &pg_types[6]; case PG_CHARARRAY: return &pg_types[7]; case PG_CIDARRAY: return &pg_types[8]; case PG_CIDRARRAY: return &pg_types[9]; case PG_CIRCLEARRAY: return &pg_types[10]; case PG_CSTRINGARRAY: return &pg_types[11]; case PG_DATEARRAY: return &pg_types[12]; case PG_DATERANGEARRAY: return &pg_types[13]; case PG_FLOAT4ARRAY: return &pg_types[14]; case PG_FLOAT8ARRAY: return &pg_types[15]; case PG_GTSVECTORARRAY: return &pg_types[16]; case PG_INETARRAY: return &pg_types[17]; case PG_INT2ARRAY: return &pg_types[18]; case PG_INT2VECTORARRAY: return &pg_types[19]; case PG_INT4ARRAY: return &pg_types[20]; case PG_INT4RANGEARRAY: return &pg_types[21]; case PG_INT8ARRAY: return &pg_types[22]; case PG_INT8RANGEARRAY: return &pg_types[23]; case PG_INTERVALARRAY: return &pg_types[24]; case PG_JSONARRAY: return &pg_types[25]; case PG_JSONBARRAY: return &pg_types[26]; case PG_LINEARRAY: return &pg_types[27]; case PG_LSEGARRAY: return &pg_types[28]; case PG_MACADDRARRAY: return &pg_types[29]; case PG_MACADDR8ARRAY: return &pg_types[30]; case PG_MONEYARRAY: return &pg_types[31]; case PG_NAMEARRAY: return &pg_types[32]; case PG_NUMERICARRAY: return &pg_types[33]; case PG_NUMRANGEARRAY: return &pg_types[34]; case PG_OIDARRAY: return &pg_types[35]; case PG_OIDVECTORARRAY: return &pg_types[36]; case PG_PATHARRAY: return &pg_types[37]; case PG_PG_LSNARRAY: return &pg_types[38]; case PG_POINTARRAY: return &pg_types[39]; case PG_POLYGONARRAY: return &pg_types[40]; case PG_RECORDARRAY: return &pg_types[41]; case PG_REFCURSORARRAY: return &pg_types[42]; case PG_REGCLASSARRAY: return &pg_types[43]; case PG_REGCONFIGARRAY: return &pg_types[44]; case PG_REGDICTIONARYARRAY: return &pg_types[45]; case PG_REGNAMESPACEARRAY: return &pg_types[46]; case PG_REGOPERARRAY: return &pg_types[47]; case PG_REGOPERATORARRAY: return &pg_types[48]; case PG_REGPROCARRAY: return &pg_types[49]; case PG_REGPROCEDUREARRAY: return &pg_types[50]; case PG_REGROLEARRAY: return &pg_types[51]; case PG_REGTYPEARRAY: return &pg_types[52]; case PG_RELTIMEARRAY: return &pg_types[53]; case PG_TEXTARRAY: return &pg_types[54]; case PG_TIDARRAY: return &pg_types[55]; case PG_TIMEARRAY: return &pg_types[56]; case PG_TIMESTAMPARRAY: return &pg_types[57]; case PG_TIMESTAMPTZARRAY: return &pg_types[58]; case PG_TIMETZARRAY: return &pg_types[59]; case PG_TINTERVALARRAY: return &pg_types[60]; case PG_TSQUERYARRAY: return &pg_types[61]; case PG_TSRANGEARRAY: return &pg_types[62]; case PG_TSTZRANGEARRAY: return &pg_types[63]; case PG_TSVECTORARRAY: return &pg_types[64]; case PG_TXID_SNAPSHOTARRAY: return &pg_types[65]; case PG_UUIDARRAY: return &pg_types[66]; case PG_VARBITARRAY: return &pg_types[67]; case PG_VARCHARARRAY: return &pg_types[68]; case PG_XIDARRAY: return &pg_types[69]; case PG_XMLARRAY: return &pg_types[70]; case PG_ABSTIME: return &pg_types[71]; case PG_ACLITEM: return &pg_types[72]; case PG_ANY: return &pg_types[73]; case PG_ANYARRAY: return &pg_types[74]; case PG_ANYELEMENT: return &pg_types[75]; case PG_ANYENUM: return &pg_types[76]; case PG_ANYNONARRAY: return &pg_types[77]; case PG_ANYRANGE: return &pg_types[78]; case PG_BIT: return &pg_types[79]; case PG_BOOL: return &pg_types[80]; case PG_BOX: return &pg_types[81]; case PG_BPCHAR: return &pg_types[82]; case PG_BYTEA: return &pg_types[83]; case PG_CHAR: return &pg_types[84]; case PG_CID: return &pg_types[85]; case PG_CIDR: return &pg_types[86]; case PG_CIRCLE: return &pg_types[87]; case PG_CSTRING: return &pg_types[88]; case PG_DATE: return &pg_types[89]; case PG_DATERANGE: return &pg_types[90]; case PG_EVENT_TRIGGER: return &pg_types[91]; case PG_FDW_HANDLER: return &pg_types[92]; case PG_FLOAT4: return &pg_types[93]; case PG_FLOAT8: return &pg_types[94]; case PG_GTSVECTOR: return &pg_types[95]; case PG_INDEX_AM_HANDLER: return &pg_types[96]; case PG_INET: return &pg_types[97]; case PG_INT2: return &pg_types[98]; case PG_INT2VECTOR: return &pg_types[99]; case PG_INT4: return &pg_types[100]; case PG_INT4RANGE: return &pg_types[101]; case PG_INT8: return &pg_types[102]; case PG_INT8RANGE: return &pg_types[103]; case PG_INTERNAL: return &pg_types[104]; case PG_INTERVAL: return &pg_types[105]; case PG_JSON: return &pg_types[106]; case PG_JSONB: return &pg_types[107]; case PG_LANGUAGE_HANDLER: return &pg_types[108]; case PG_LINE: return &pg_types[109]; case PG_LSEG: return &pg_types[110]; case PG_MACADDR: return &pg_types[111]; case PG_MACADDR8: return &pg_types[112]; case PG_MONEY: return &pg_types[113]; case PG_NAME: return &pg_types[114]; case PG_NUMERIC: return &pg_types[115]; case PG_NUMRANGE: return &pg_types[116]; case PG_OID: return &pg_types[117]; case PG_OIDVECTOR: return &pg_types[118]; case PG_OPAQUE: return &pg_types[119]; case PG_PATH: return &pg_types[120]; case PG_PG_ATTRIBUTE: return &pg_types[121]; case PG_PG_CLASS: return &pg_types[122]; case PG_PG_DDL_COMMAND: return &pg_types[123]; case PG_PG_DEPENDENCIES: return &pg_types[124]; case PG_PG_LSN: return &pg_types[125]; case PG_PG_NDISTINCT: return &pg_types[126]; case PG_PG_NODE_TREE: return &pg_types[127]; case PG_PG_PROC: return &pg_types[128]; case PG_PG_TYPE: return &pg_types[129]; case PG_POINT: return &pg_types[130]; case PG_POLYGON: return &pg_types[131]; case PG_RECORD: return &pg_types[132]; case PG_REFCURSOR: return &pg_types[133]; case PG_REGCLASS: return &pg_types[134]; case PG_REGCONFIG: return &pg_types[135]; case PG_REGDICTIONARY: return &pg_types[136]; case PG_REGNAMESPACE: return &pg_types[137]; case PG_REGOPER: return &pg_types[138]; case PG_REGOPERATOR: return &pg_types[139]; case PG_REGPROC: return &pg_types[140]; case PG_REGPROCEDURE: return &pg_types[141]; case PG_REGROLE: return &pg_types[142]; case PG_REGTYPE: return &pg_types[143]; case PG_RELTIME: return &pg_types[144]; case PG_SMGR: return &pg_types[145]; case PG_TEXT: return &pg_types[146]; case PG_TID: return &pg_types[147]; case PG_TIME: return &pg_types[148]; case PG_TIMESTAMP: return &pg_types[149]; case PG_TIMESTAMPTZ: return &pg_types[150]; case PG_TIMETZ: return &pg_types[151]; case PG_TINTERVAL: return &pg_types[152]; case PG_TRIGGER: return &pg_types[153]; case PG_TSM_HANDLER: return &pg_types[154]; case PG_TSQUERY: return &pg_types[155]; case PG_TSRANGE: return &pg_types[156]; case PG_TSTZRANGE: return &pg_types[157]; case PG_TSVECTOR: return &pg_types[158]; case PG_TXID_SNAPSHOT: return &pg_types[159]; case PG_UNKNOWN: return &pg_types[160]; case PG_UUID: return &pg_types[161]; case PG_VARBIT: return &pg_types[162]; case PG_VARCHAR: return &pg_types[163]; case PG_VOID: return &pg_types[164]; case PG_XID: return &pg_types[165]; case PG_XML: return &pg_types[166]; default: return NULL; } } static sql_type_info_t sql_types[] = { {SQL_BOOLEAN,"SQL_BOOLEAN",1,',', "none", quote_bool, dequote_bool, {PG_BOOL}, 3}, {SQL_CHAR,"SQL_CHAR",1,',', "none", quote_string, dequote_char, {PG_BPCHAR}, 0}, {SQL_VARBINARY,"SQL_VARBINARY",1,',', "none", quote_bytea, dequote_bytea, {PG_BYTEA}, 0}, {SQL_CHAR,"SQL_CHAR",1,',', "none", quote_string, dequote_char, {PG_CHAR}, 0}, {SQL_TYPE_DATE,"SQL_TYPE_DATE",1,',', "none", quote_string, dequote_string, {PG_DATE}, 0}, {SQL_FLOAT,"SQL_FLOAT",1,',', "none", quote_float, null_dequote, {PG_FLOAT8}, 2}, {SQL_DOUBLE,"SQL_DOUBLE",1,',', "none", quote_float, null_dequote, {PG_FLOAT8}, 2}, {SQL_REAL,"SQL_REAL",1,',', "none", quote_float, null_dequote, {PG_FLOAT8}, 2}, {SQL_SMALLINT,"SQL_SMALLINT",1,',', "none", quote_int, null_dequote, {PG_INT2}, 1}, {SQL_TINYINT,"SQL_TINYINT",1,',', "none", quote_int, null_dequote, {PG_INT2}, 1}, {SQL_INTEGER,"SQL_INTEGER",1,',', "none", quote_int, null_dequote, {PG_INT4}, 1}, {SQL_BIGINT,"SQL_BIGINT",1,',', "none", quote_int, null_dequote, {PG_INT8}, 0}, {SQL_VARCHAR,"SQL_VARCHAR",1,',', "none", quote_name, null_dequote, {PG_NAME}, 0}, {SQL_NUMERIC,"SQL_NUMERIC",1,',', "none", quote_float, null_dequote, {PG_NUMERIC}, 2}, {SQL_DECIMAL,"SQL_DECIMAL",1,',', "none", quote_float, null_dequote, {PG_NUMERIC}, 2}, {SQL_LONGVARCHAR,"SQL_LONGVARCHAR",1,',', "none", quote_string, dequote_string, {PG_TEXT}, 0}, {SQL_TYPE_TIME,"SQL_TYPE_TIME",1,',', "none", quote_string, dequote_string, {PG_TIME}, 0}, {SQL_TIMESTAMP,"SQL_TIMESTAMP",1,',', "none", quote_string, dequote_string, {PG_TIMESTAMP}, 0}, {SQL_TYPE_TIMESTAMP,"SQL_TYPE_TIMESTAMP",1,',', "none", quote_string, dequote_string, {PG_TIMESTAMP}, 0}, {SQL_TYPE_TIMESTAMP_WITH_TIMEZONE,"SQL_TYPE_TIMESTAMP_WITH_TIMEZONE",1,',', "none", quote_string, dequote_string, {PG_TIMESTAMPTZ}, 0}, {SQL_TYPE_TIME_WITH_TIMEZONE,"SQL_TYPE_TIME_WITH_TIMEZONE",1,',', "none", quote_string, dequote_string, {PG_TIMESTAMPTZ}, 0}, {SQL_VARCHAR,"SQL_VARCHAR",1,',', "none", quote_string, dequote_string, {PG_VARCHAR}, 0}, }; sql_type_info_t* sql_type_data(int sql_type) { switch(sql_type) { case SQL_BOOLEAN: return &sql_types[0]; case SQL_CHAR: return &sql_types[1]; case SQL_VARBINARY: return &sql_types[2]; case SQL_TYPE_DATE: return &sql_types[4]; case SQL_FLOAT: return &sql_types[5]; case SQL_DOUBLE: return &sql_types[6]; case SQL_REAL: return &sql_types[7]; case SQL_SMALLINT: return &sql_types[8]; case SQL_TINYINT: return &sql_types[9]; case SQL_INTEGER: return &sql_types[10]; case SQL_BIGINT: return &sql_types[11]; case SQL_NUMERIC: return &sql_types[13]; case SQL_DECIMAL: return &sql_types[14]; case SQL_LONGVARCHAR: return &sql_types[15]; case SQL_TYPE_TIME: return &sql_types[16]; case SQL_TIMESTAMP: return &sql_types[17]; case SQL_TYPE_TIMESTAMP: return &sql_types[18]; case SQL_TYPE_TIMESTAMP_WITH_TIMEZONE: return &sql_types[19]; case SQL_TYPE_TIME_WITH_TIMEZONE: return &sql_types[20]; case SQL_VARCHAR: return &sql_types[21]; default: return NULL; } } /* #!perl ## Autogenerate all type information and populate ## all files referencing type information. ## 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/catalog/pg_type.h"; my $typefile = $file; open my $fh, '<', $file or die qq{Could not open file "$file": $!\n}; my $maxlen = 1; my %pgtype; my $thisname = 0; while(<$fh>) { s/FLOAT8PASSBYVAL/t/; s/FLOAT4PASSBYVAL/t/; if (/^DATA\(insert OID\s+=\s+(\d+)\s+\(\s+(\S+)\s+\S+ \S+\s+\S+\s+[t|f]\s+. . [tf] ([tf]) \\(\d+) (\d+)\s+(\d+) (\d+) (\S+) (\S+) (\S+) (\S+)/o) { my ($oid,$name,$typedef,$delim,$typrelid,$typelem,$typarray,$tin,$tout,$bin,$bout) = ($1,$2,$3,chr(oct($4)),$5,$6,$7,$8,$9,$10,$11); die "Duplicated OID $oid!: $_\n" if exists $pgtype{$oid}; $pgtype{$name} = { oid => $oid, delim => $delim, textin => $tin, textout => $tout, binin => $bin, binout => $bout, quote => 'quote_string', dequote => 'dequote_string', define => 'PG_' . uc($name), sql => 0, sqlc => 0, svtype => 0, }; if ($name =~ /_/) { (my $basename = $name) =~ s/_//; if (exists $pgtype{$basename}) { $pgtype{$name}{delim} = $pgtype{$basename}{delim}; } } length($name) > $maxlen and $maxlen = length($name); $thisname = $name; ## Special hack for array types if ($tin =~ /^array/ and $name =~ /^_/) { $pgtype{$name}{define} = 'PG' . uc $name . 'ARRAY'; } } elsif (/^DESCR\("(.+?)"/) { $pgtype{$thisname}{description} = $1; } elsif (/^DATA/) { die "Bad line at $. ->$_\n"; } } close $fh or die qq{Could not close "$file": $!\n}; my ($oldfh,$newfh); ## Rewrite types.h $file = 'types.h'; open $newfh, '>', "$file.tmp" or die qq{Could not create "$file.tmp": $!\n}; my $slashstar = '/' . '*'; my $starslash = '*' . '/'; print $newfh qq{$slashstar Do not edit this file directly - it is generated by types.c $starslash typedef struct sql_type_info { int type_id; char* type_name; bool bind_ok; char array_delimeter; char* arrayout; char* (*quote)(); void (*dequote)(); 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); }; $maxlen += 5; for (sort { $pgtype{$a}{define} =~ /ARRAY/ <=> $pgtype{$b}{define} =~ /ARRAY/ or $pgtype{$a}{define} cmp $pgtype{$b}{define} } keys %pgtype) { printf $newfh "#define %${maxlen}s $pgtype{$_}{oid}\n", $pgtype{$_}{define}; } print $newfh "\n"; close $newfh or die qq{Could not close "$file.tmp": $!\n}; system("mv $file.tmp $file"); print "Wrote $file\n"; ## Rewrite Pg.xs $file = 'Pg.xs'; open $oldfh, '<', $file or die qq{Could not open "$file": $!\n}; open $newfh, '>', "$file.tmp" or die qq{Could not write to "$file.tmp": $!\n}; my $step = 0; while (<$oldfh>) { if (0 == $step) { if (/ALIAS:/) { print $newfh $_; $step = 1; for (sort { $pgtype{$a}{define} cmp $pgtype{$b}{define} } keys %pgtype) { printf $newfh "\t%-${maxlen}s = $pgtype{$_}{oid}\n", $pgtype{$_}{define}; } printf $newfh "\n\t%-${maxlen}s = 1\n", 'PG_ASYNC'; printf $newfh "\t%-${maxlen}s = 2\n", 'PG_OLDQUERY_CANCEL'; printf $newfh "\t%-${maxlen}s = 4\n\n", 'PG_OLDQUERY_WAIT'; next; } } elsif (1 == $step) { next unless /CODE:/; $step = 2; } print $newfh $_; } close $newfh or die qq{Could not close "$file.tmp": $!\n}; close $oldfh or die qq{Could not close "$file": $!\n}; system("mv $file.tmp $file"); print "Wrote $file\n"; ## Rewrite Pg.pm $file = 'Pg.pm'; open $oldfh, '<', $file or die qq{Could not open "$file": $!\n}; open $newfh, '>', "$file.tmp" or die qq{Could not write to "$file.tmp": $!\n}; $step = 0; while (<$oldfh>) { if (0 == $step) { if (/pg_types/) { chomp; print $newfh $_; $step = 0; for (sort { $pgtype{$a}{define} cmp $pgtype{$b}{define} } keys %pgtype) { printf $newfh "%s$pgtype{$_}{define}", !($step++ % 5) ? "\n\t\t\t" : ' '; } print $newfh "\n"; $step = 1; next; } } elsif (1 == $step) { next unless /\]/; $step = 2; } elsif (2 == $step) { if (/data types exported/) { print $newfh $_; $step = 0; for (sort { $pgtype{$a}{define} cmp $pgtype{$b}{define} } keys %pgtype) { printf $newfh "%s$pgtype{$_}{define}", !($step++ % 6) ? "\n " : ' '; } print $newfh "\n\n"; $step = 3; next; } } elsif (3 == $step) { next unless /sticky/; $step = 4; } print $newfh $_; } close $newfh or die qq{Could not close "$file.tmp": $!\n}; close $oldfh or die qq{Could not close "$file": $!\n}; system("mv $file.tmp $file"); print "Wrote $file\n"; ## Rewrite 01constants.t $file = 't/01constants.t'; open $oldfh, '<', $file or die qq{Could not open "$file": $!\n}; open $newfh, '>', "$file.tmp" or die qq{Could not write to "$file.tmp": $!\n}; $step = 0; while (<$oldfh>) { if (0 == $step) { if (/^is/) { for (sort { $pgtype{$a}{define} cmp $pgtype{$b}{define} } keys %pgtype) { printf $newfh qq{is (%-*s, %5s, '%s returns correct value');\n}, 3+$maxlen, $pgtype{$_}{define}, $pgtype{$_}{oid}, $pgtype{$_}{define}; } print $newfh "\ndone_testing();\n"; $step = 1; last; } } print $newfh $_; } close $newfh or die qq{Could not close "$file.tmp": $!\n}; close $oldfh or die qq{Could not close "$file": $!\n}; system("mv $file.tmp $file"); print "Wrote $file\n"; ## Rewrite 99_pod.t $file = 't/99_pod.t'; open $oldfh, '<', $file or die qq{Could not open "$file": $!\n}; open $newfh, '>', "$file.tmp" or die qq{Could not write to "$file.tmp": $!\n}; $step = 0; while (<$oldfh>) { if (0 == $step) { if (/types.c/) { print $newfh $_; for (sort { $pgtype{$a}{define} cmp $pgtype{$b}{define} } keys %pgtype) { print $newfh "\t\t qr{$pgtype{$_}{define}},\n"; } print $newfh "\n"; $step = 1; next; } } elsif (1 == $step) { next unless /;/; $step = 2; } print $newfh $_; } close $newfh or die qq{Could not close "$file.tmp": $!\n}; close $oldfh or die qq{Could not close "$file": $!\n}; system("mv $file.tmp $file"); print "Wrote $file\n"; ## Rewrite types.c $file = 'types.c'; open $newfh, '>', "$file.tmp" or die qq{Could not write to "$file.tmp": $!\n}; print $newfh qq{$slashstar Copyright (c) 2003-2017 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. $starslash $slashstar Please do not edit the C portions of this file directly. It is automatically generated by the enclosed Perl script. $starslash #include "Pg.h" }; ## Read in our DATA information to make things more specific while () { last if /^__END__/; next unless /^[a-z]/o; chomp; my ($name,$q,$dq,$sql,$sqlc,$svtype) = split / +/ => $_; if (!exists $pgtype{$name}) { die qq{Type ($name) was not found in source file $typefile!\n}; } $pgtype{$name}{quote} = $q; $pgtype{$name}{dequote} = $dq; $pgtype{$name}{sql} = $sql; $pgtype{$name}{sqlc} = $sqlc; $pgtype{$name}{svtype} = $svtype; ## For arrays, we want to echo the base svtype if ($svtype and exists $pgtype{"_$name"} and $pgtype{"_$name"}{textin} =~ /array/) { $pgtype{"_$name"}{svtype} = $svtype; } } ## Map all types into a sql_type_info structure print $newfh "static sql_type_info_t pg_types[] = {\n"; my %pos; my $item = 0; for my $name (sort {$a cmp $b } keys %pgtype) { my $t = $pgtype{$name}; my ($sqltype,$quote,$dequote) = (0,0,0); (my $sql = $t->{sql}) =~ s{^(\w+).*}{$1}; printf $newfh qq! {%-*s,%-*s,%d,'%s',%-22s,%-12s,%-14s,\{%s\},%d\},\n!, $maxlen, $t->{define}, $maxlen-2, "\"$name\"", 1, $t->{delim}, "\"$t->{textout}\"", $t->{quote}, $t->{dequote}, $sql, $t->{svtype}; $pos{$name} = $item++; } print $newfh "\};\n\n"; print $newfh "sql_type_info_t* pg_type_data(int sql_type) { \tswitch(sql_type) { \n"; for my $name (sort { $a cmp $b } keys %pgtype) { printf $newfh qq{\t\tcase %-*s return \&pg_types\[%d\];\n}, 1+$maxlen, "$pgtype{$name}{define}:", $pos{$name}; } print $newfh "\t\tdefault: return NULL;\n\t\}\n\}\n\n"; print $newfh "static sql_type_info_t sql_types[] = \{\n"; undef %pos; $item=0; $maxlen = 1; for my $name (sort { $a cmp $b } keys %pgtype) { next unless $pgtype{$name}{sql}; for my $sql (split /\|/ => $pgtype{$name}{sql}) { ## {SQL_VARCHAR, "SQL_VARCHAR", quote_string, dequote_string, {VARCHAROID}, DBDPG_TRUE }, printf $newfh qq! {%s,"%s",1,',', "none", $pgtype{$name}{quote}, $pgtype{$name}{dequote}, \{$pgtype{$name}{define}\}, $pgtype{$name}{svtype}\},\n!, $sql, $sql; $maxlen = length $sql if length $sql > $maxlen; $pos{$sql} = $item if $pgtype{$name}{sqlc}; $item++; } } print $newfh "\};\n\n"; print $newfh "sql_type_info_t* sql_type_data(int sql_type)\n\{\n"; print $newfh "\tswitch(sql_type) \{\n"; for (sort { $pos{$a} <=> $pos{$b} } keys %pos) { printf $newfh qq{\t\tcase %-*s return \&sql_types\[%d\];\n}, 1+$maxlen, "$_:", $pos{$_}; } print $newfh "\t\tdefault: return NULL;\n\t\}\n\}\n\n/" ."*\n"; seek(DATA,0,0); 1 while !~ /!perl/; print $newfh "#!perl\n"; while () { print $newfh $_; } close($newfh) or die qq{Could not close "$file.tmp": $!\n}; system("mv $file.tmp $file"); print "Wrote $file\n"; exit; __DATA__ ## Format: for each type, there are 6 items, space separated: ## 1. The given name, from the Postgres source code (pg_type.h) ## 2. The function name we use to do the quoting, or 0 if we do not bind it ## 3. The function name we use for DE-quoting ## 4. The closest SQL_ datatype, or 0 if there is none. May be multiple, separated by | ## 5. Whether this is the one to use for reverse SQL_ type mapping ## 6. What type of SV we can put this in: 1: IV 2: NV ## Simple quoting (e.g. text) - wrap in single quotes, escape backslashes and apostrophes ## This is also the default action for types not specified here varchar quote_string dequote_string SQL_VARCHAR 1 0 text quote_string dequote_string SQL_LONGVARCHAR 1 0 char quote_string dequote_char SQL_CHAR 0 0 bpchar quote_string dequote_char SQL_CHAR 1 0 cid quote_string dequote_string 0 0 0 ## Things that get special quoting int2 quote_int null_dequote SQL_SMALLINT|SQL_TINYINT 1 1 int4 quote_int null_dequote SQL_INTEGER 1 1 int8 quote_int null_dequote SQL_BIGINT 1 0 float4 quote_float null_dequote 0 1 2 float8 quote_float null_dequote SQL_FLOAT|SQL_DOUBLE|SQL_REAL 1 2 numeric quote_float null_dequote SQL_NUMERIC|SQL_DECIMAL 1 2 oid quote_int null_dequote 0 0 1 name quote_name null_dequote SQL_VARCHAR 0 0 ## XXX Wrong ## Boolean bool quote_bool dequote_bool SQL_BOOLEAN 1 3 ## Geometric types point quote_geom dequote_string 0 0 0 line quote_geom dequote_string 0 0 0 lseg quote_geom dequote_string 0 0 0 box quote_geom dequote_string 0 0 0 path quote_path dequote_string 0 0 0 polygon quote_geom dequote_string 0 0 0 circle quote_circle dequote_string 0 0 0 ## Similar enough to geometric types that we use the same quoting rules tid quote_geom dequote_string 0 0 0 ## Binary - very different quoting rules bytea quote_bytea dequote_bytea SQL_VARBINARY 1 0 ## Time and date date quote_string dequote_string SQL_TYPE_DATE 1 0 time quote_string dequote_string SQL_TYPE_TIME 1 0 timestamp quote_string dequote_string SQL_TIMESTAMP|SQL_TYPE_TIMESTAMP 1 0 timestamptz quote_string dequote_string SQL_TYPE_TIMESTAMP_WITH_TIMEZONE|SQL_TYPE_TIME_WITH_TIMEZONE 1 0 __END__ */ DBD-Pg-3.7.0/TODO0000644000175000017500000000353613161224062011604 0ustar greggregPossible items to do, in no particular order Feature requests can be entered at http://rt.cpan.org/Public/Dist/Display.html?Name=DBD-Pg May also be some at https://github.com/bucardo/dbdpg (although we prefer using cpan.org) - ShowErrorStatement should work even for "quickexec" do() calls. (RT #120268) - Remove final reference to 'adsrc' column in Pg.pm - 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 ala 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.7.0/lib/0000755000175000017500000000000013162003552011653 5ustar greggregDBD-Pg-3.7.0/lib/Bundle/0000755000175000017500000000000013162003552013064 5ustar greggregDBD-Pg-3.7.0/lib/Bundle/DBD/0000755000175000017500000000000013162003552013455 5ustar greggregDBD-Pg-3.7.0/lib/Bundle/DBD/Pg.pm0000644000175000017500000000104013162002635014355 0ustar greggreg package Bundle::DBD::Pg; use strict; use warnings; $VERSION = '3.7.0'; 1; __END__ =head1 NAME Bundle::DBD::Pg - A bundle to install all DBD::Pg related modules =head1 SYNOPSIS C =head1 CONTENTS DBI DBD::Pg =head1 DESCRIPTION This bundle includes all the modules needed for DBD::Pg (the Perl interface to the Postgres database system). Please feel free to ask for help or report any problems to dbd-pg@perl.org. =cut =head1 AUTHOR Greg Sabino Mullane EFE DBD-Pg-3.7.0/Pg.pm0000644000175000017500000053317013162002732012021 0ustar greggreg# -*-cperl-*- # # Copyright (c) 2002-2017 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.7.0'); use DBI (); use DynaLoader (); use Exporter (); use vars qw(@ISA %EXPORT_TAGS $err $errstr $sqlstate $drh $dbh $DBDPG_DEFAULT @EXPORT); @ISA = qw(DynaLoader Exporter); %EXPORT_TAGS = ( async => [qw(PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT)], pg_types => [qw( PG_ABSTIME PG_ABSTIMEARRAY PG_ACLITEM PG_ACLITEMARRAY PG_ANY PG_ANYARRAY PG_ANYELEMENT PG_ANYENUM PG_ANYNONARRAY PG_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_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_INT4RANGE PG_INT4RANGEARRAY PG_INT8 PG_INT8ARRAY PG_INT8RANGE PG_INT8RANGEARRAY PG_INTERNAL PG_INTERVAL PG_INTERVALARRAY PG_JSON PG_JSONARRAY PG_JSONB PG_JSONBARRAY 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_NUMRANGE PG_NUMRANGEARRAY PG_OID PG_OIDARRAY PG_OIDVECTOR PG_OIDVECTORARRAY PG_OPAQUE PG_PATH PG_PATHARRAY PG_PG_ATTRIBUTE PG_PG_CLASS PG_PG_DDL_COMMAND PG_PG_DEPENDENCIES PG_PG_LSN PG_PG_LSNARRAY PG_PG_NDISTINCT PG_PG_NODE_TREE PG_PG_PROC PG_PG_TYPE PG_POINT PG_POINTARRAY PG_POLYGON PG_POLYGONARRAY PG_RECORD PG_RECORDARRAY PG_REFCURSOR PG_REFCURSORARRAY PG_REGCLASS PG_REGCLASSARRAY PG_REGCONFIG PG_REGCONFIGARRAY PG_REGDICTIONARY PG_REGDICTIONARYARRAY PG_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_RELTIME PG_RELTIMEARRAY PG_SMGR PG_TEXT PG_TEXTARRAY PG_TID PG_TIDARRAY PG_TIME PG_TIMEARRAY PG_TIMESTAMP PG_TIMESTAMPARRAY PG_TIMESTAMPTZ PG_TIMESTAMPTZARRAY PG_TIMETZ PG_TIMETZARRAY PG_TINTERVAL PG_TINTERVALARRAY PG_TRIGGER PG_TSM_HANDLER PG_TSQUERY PG_TSQUERYARRAY PG_TSRANGE PG_TSRANGEARRAY 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_XIDARRAY PG_XML PG_XMLARRAY )] ); { package DBD::Pg::DefaultValue; sub new { my $self = {}; return bless $self, shift; } } $DBDPG_DEFAULT = DBD::Pg::DefaultValue->new(); Exporter::export_ok_tags('pg_types', 'async'); @EXPORT = qw($DBDPG_DEFAULT PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT PG_BYTEA); require_version DBI 1.614; bootstrap DBD::Pg $VERSION; $err = 0; # holds error code for DBI::err $errstr = ''; # holds error string for DBI::errstr $sqlstate = ''; # holds five character SQLSTATE code $drh = undef; # holds driver handle once initialized ## These two methods are here to allow calling before connect() sub parse_trace_flag { my ($class, $flag) = @_; return (0x7FFFFF00 - 0x08000000) if $flag eq 'DBD'; ## all but the prefix return 0x01000000 if $flag eq 'pglibpq'; return 0x02000000 if $flag eq 'pgstart'; return 0x04000000 if $flag eq 'pgend'; return 0x08000000 if $flag eq 'pgprefix'; return 0x10000000 if $flag eq 'pglogin'; return 0x20000000 if $flag eq 'pgquote'; return DBI::parse_trace_flag($class, $flag); } sub parse_trace_flags { my ($class, $flags) = @_; return DBI::parse_trace_flags($class, $flags); } sub CLONE { $drh = undef; return; } ## Deprecated sub _pg_use_catalog { ## no critic (ProhibitUnusedPrivateSubroutines) return 'pg_catalog.'; } my $methods_are_installed = 0; sub driver { return $drh if defined $drh; my($class, $attr) = @_; $class .= '::dr'; $drh = DBI::_new_drh($class, { 'Name' => 'Pg', 'Version' => $VERSION, 'Err' => \$DBD::Pg::err, 'Errstr' => \$DBD::Pg::errstr, 'State' => \$DBD::Pg::sqlstate, 'Attribution' => "DBD::Pg $VERSION by Greg Sabino Mullane and others", }); if (!$methods_are_installed) { DBD::Pg::db->install_method('pg_cancel'); DBD::Pg::db->install_method('pg_endcopy'); DBD::Pg::db->install_method('pg_getline'); DBD::Pg::db->install_method('pg_getcopydata'); DBD::Pg::db->install_method('pg_getcopydata_async'); DBD::Pg::db->install_method('pg_notifies'); DBD::Pg::db->install_method('pg_putcopydata'); DBD::Pg::db->install_method('pg_putcopyend'); DBD::Pg::db->install_method('pg_ping'); DBD::Pg::db->install_method('pg_putline'); DBD::Pg::db->install_method('pg_ready'); DBD::Pg::db->install_method('pg_release'); DBD::Pg::db->install_method('pg_result'); ## NOT duplicated below! DBD::Pg::db->install_method('pg_rollback_to'); DBD::Pg::db->install_method('pg_savepoint'); DBD::Pg::db->install_method('pg_server_trace'); DBD::Pg::db->install_method('pg_server_untrace'); DBD::Pg::db->install_method('pg_type_info'); DBD::Pg::st->install_method('pg_cancel'); DBD::Pg::st->install_method('pg_result'); DBD::Pg::st->install_method('pg_ready'); DBD::Pg::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_tell'); DBD::Pg::db->install_method('pg_lo_truncate'); 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++; } return $drh; } ## end of driver 1; } ## end of package DBD::Pg { package DBD::Pg::dr; use strict; ## Returns an array of formatted database names from the pg_database table sub data_sources { my $drh = shift; my $attr = shift || ''; ## Future: connect to "postgres" when the minimum version we support is 8.0 my $connstring = 'dbname=template1'; if ($ENV{DBI_DSN}) { ($connstring = $ENV{DBI_DSN}) =~ s/dbi:Pg://i; } if (length $attr) { $connstring .= ";$attr"; } my $dbh = DBD::Pg::dr::connect($drh, $connstring) or return; $dbh->{AutoCommit}=1; my $SQL = 'SELECT pg_catalog.quote_ident(datname) FROM pg_catalog.pg_database ORDER BY 1'; my $sth = $dbh->prepare($SQL); $sth->execute() or die $DBI::errstr; $attr and $attr = ";$attr"; my @sources = map { "dbi:Pg:dbname=$_->[0]$attr" } @{$sth->fetchall_arrayref()}; $dbh->disconnect; return @sources; } sub connect { ## no critic (ProhibitBuiltinHomonyms) my ($drh, $dbname, $user, $pass, $attr) = @_; ## Allow "db" and "database" as synonyms for "dbname" $dbname =~ s/\b(?:db|database)\s*=/dbname=/; my $name = $dbname; if ($dbname =~ m{dbname\s*=\s*[\"\']([^\"\']+)}) { $name = "'$1'"; $dbname =~ s/\"/\'/g; } elsif ($dbname =~ m{dbname\s*=\s*([^;]+)}) { $name = $1; } $user = defined($user) ? $user : defined $ENV{DBI_USER} ? $ENV{DBI_USER} : ''; $pass = defined($pass) ? $pass : defined $ENV{DBI_PASS} ? $ENV{DBI_PASS} : ''; my ($dbh) = DBI::_new_dbh($drh, { 'Name' => $dbname, 'Username' => $user, 'CURRENT_USER' => $user, }); # Connect to the database.. DBD::Pg::db::_login($dbh, $dbname, $user, $pass, $attr) or return undef; my $version = $dbh->{pg_server_version}; $dbh->{private_dbdpg}{version} = $version; if ($attr) { if ($attr->{dbd_verbose}) { $dbh->trace('DBD'); } } return $dbh; } sub private_attribute_info { return { }; } } ## end of package DBD::Pg::dr { package DBD::Pg::db; use DBI qw(:sql_types); use strict; sub parse_trace_flag { my ($h, $flag) = @_; return DBD::Pg->parse_trace_flag($flag); } sub prepare { my($dbh, $statement, @attribs) = @_; return undef if ! defined $statement; # Create a 'blank' statement handle: my $sth = DBI::_new_sth($dbh, { 'Statement' => $statement, }); DBD::Pg::st::_prepare($sth, $statement, @attribs) || 0; return $sth; } sub last_insert_id { my ($dbh, $catalog, $schema, $table, $col, $attr) = @_; ## Our ultimate goal is to get a sequence my ($sth, $count, $SQL, $sequence); ## Cache all of our table lookups? Default is yes my $cache = 1; ## Catalog and col are not used $schema = '' if ! defined $schema; $table = '' if ! defined $table; my $cachename = "lii$table$schema"; if (defined $attr and length $attr) { ## If not a hash, assume it is a sequence name if (! ref $attr) { $attr = {sequence => $attr}; } elsif (ref $attr ne 'HASH') { $dbh->set_err(1, 'last_insert_id must be passed a hashref as the final argument'); return undef; } ## Named sequence overrides any table or schema settings if (exists $attr->{sequence} and length $attr->{sequence}) { $sequence = $attr->{sequence}; } if (exists $attr->{pg_cache}) { $cache = $attr->{pg_cache}; } } if (! defined $sequence and exists $dbh->{private_dbdpg}{$cachename} and $cache) { $sequence = $dbh->{private_dbdpg}{$cachename}; } elsif (! defined $sequence) { ## At this point, we must have a valid table name if (! length $table) { $dbh->set_err(1, 'last_insert_id needs at least a sequence or table name'); return undef; } my @args = ($table); ## Make sure the table in question exists and grab its oid my ($schemajoin,$schemawhere) = ('',''); if (length $schema) { $schemajoin = "\n JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)"; $schemawhere = "\n AND n.nspname = ?"; push @args, $schema; } $SQL = "SELECT c.oid FROM pg_catalog.pg_class c $schemajoin\n WHERE relname = ?$schemawhere"; if (! length $schema) { $SQL .= ' AND pg_catalog.pg_table_is_visible(c.oid)'; } $sth = $dbh->prepare_cached($SQL); $count = $sth->execute(@args); if (!defined $count or $count eq '0E0') { $sth->finish(); my $message = qq{Could not find the table "$table"}; length $schema and $message .= qq{ in the schema "$schema"}; $dbh->set_err(1, $message); return undef; } my $oid = $sth->fetchall_arrayref()->[0][0]; $oid =~ /(\d+)/ or die qq{OID was not numeric?!?\n}; $oid = $1; ## This table has a primary key. Is there a sequence associated with it via a unique, indexed column? $SQL = "SELECT a.attname, i.indisprimary, pg_catalog.pg_get_expr(adbin,adrelid)\n". "FROM pg_catalog.pg_index i, pg_catalog.pg_attribute a, pg_catalog.pg_attrdef d\n ". "WHERE i.indrelid = $oid AND d.adrelid=a.attrelid AND d.adnum=a.attnum\n". " AND a.attrelid = $oid AND i.indisunique IS TRUE\n". " AND a.atthasdef IS TRUE AND i.indkey[0]=a.attnum\n". q{ AND d.adsrc ~ '^nextval'}; $sth = $dbh->prepare($SQL); $count = $sth->execute(); if (!defined $count or $count eq '0E0') { $sth->finish(); $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"}); return undef; } my $info = $sth->fetchall_arrayref(); ## We have at least one with a default value. See if we can determine sequences my @def; for (@$info) { next unless $_->[2] =~ /^nextval\(+'([^']+)'::/o; push @$_, $1; push @def, $_; } if (!@def) { $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n}); } ## Tiebreaker goes to the primary keys if (@def > 1) { my @pri = grep { $_->[1] } @def; if (1 != @pri) { $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n}); } @def = @pri; } $sequence = $def[0]->[3]; ## Cache this information for subsequent calls $dbh->{private_dbdpg}{$cachename} = $sequence; } $sth = $dbh->prepare_cached('SELECT currval(?)'); $count = $sth->execute($sequence); return undef if ! defined $count; return $sth->fetchall_arrayref()->[0][0]; } ## end of last_insert_id sub ping { my $dbh = shift; local $SIG{__WARN__} = sub { } if $dbh->FETCH('PrintError'); my $ret = DBD::Pg::db::_ping($dbh); return $ret < 1 ? 0 : $ret; } sub pg_ping { my $dbh = shift; local $SIG{__WARN__} = sub { } if $dbh->FETCH('PrintError'); return DBD::Pg::db::_ping($dbh); } sub pg_type_info { my($dbh,$pg_type) = @_; local $SIG{__WARN__} = sub { } if $dbh->FETCH('PrintError'); my $ret = DBD::Pg::db::_pg_type_info($pg_type); return $ret; } # Column expected in statement handle returned. # table_cat, table_schem, table_name, column_name, data_type, type_name, # column_size, buffer_length, DECIMAL_DIGITS, NUM_PREC_RADIX, NULLABLE, # REMARKS, COLUMN_DEF, SQL_DATA_TYPE, SQL_DATETIME_SUB, CHAR_OCTET_LENGTH, # ORDINAL_POSITION, IS_NULLABLE # The result set is ordered by TABLE_SCHEM, TABLE_NAME and ORDINAL_POSITION. sub column_info { my $dbh = shift; my ($catalog, $schema, $table, $column) = @_; my @search; ## If the schema or table has an underscore or a %, use a LIKE comparison if (defined $schema and length $schema) { push @search, 'n.nspname ' . ($schema =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($schema); } if (defined $table and length $table) { push @search, 'c.relname ' . ($table =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($table); } if (defined $column and length $column) { push @search, 'a.attname ' . ($column =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($column); } my $whereclause = join "\n\t\t\t\tAND ", '', @search; my $schemajoin = 'JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)'; my $remarks = 'pg_catalog.col_description(a.attrelid, a.attnum)'; my $column_def = $dbh->{private_dbdpg}{version} >= 80000 ? 'pg_catalog.pg_get_expr(af.adbin, af.adrelid)' : 'af.adsrc'; my $col_info_sql = qq! SELECT NULL::text AS "TABLE_CAT" , quote_ident(n.nspname) AS "TABLE_SCHEM" , quote_ident(c.relname) AS "TABLE_NAME" , quote_ident(a.attname) AS "COLUMN_NAME" , a.atttypid AS "DATA_TYPE" , pg_catalog.format_type(a.atttypid, NULL) AS "TYPE_NAME" , a.attlen AS "COLUMN_SIZE" , NULL::text AS "BUFFER_LENGTH" , NULL::text AS "DECIMAL_DIGITS" , NULL::text AS "NUM_PREC_RADIX" , CASE a.attnotnull WHEN 't' THEN 0 ELSE 1 END AS "NULLABLE" , $remarks AS "REMARKS" , $column_def AS "COLUMN_DEF" , NULL::text AS "SQL_DATA_TYPE" , NULL::text AS "SQL_DATETIME_SUB" , NULL::text AS "CHAR_OCTET_LENGTH" , a.attnum AS "ORDINAL_POSITION" , CASE a.attnotnull WHEN 't' THEN 'NO' ELSE 'YES' END AS "IS_NULLABLE" , pg_catalog.format_type(a.atttypid, a.atttypmod) AS "pg_type" , '?' AS "pg_constraint" , n.nspname AS "pg_schema" , c.relname AS "pg_table" , a.attname AS "pg_column" , a.attrelid AS "pg_attrelid" , a.attnum AS "pg_attnum" , a.atttypmod AS "pg_atttypmod" , t.typtype AS "_pg_type_typtype" , t.oid AS "_pg_type_oid" FROM pg_catalog.pg_type t JOIN pg_catalog.pg_attribute a ON (t.oid = a.atttypid) JOIN pg_catalog.pg_class c ON (a.attrelid = c.oid) LEFT JOIN pg_catalog.pg_attrdef af ON (a.attnum = af.adnum AND a.attrelid = af.adrelid) $schemajoin WHERE a.attnum >= 0 AND c.relkind IN ('r','v','m') $whereclause ORDER BY "TABLE_SCHEM", "TABLE_NAME", "ORDINAL_POSITION" !; my $data = $dbh->selectall_arrayref($col_info_sql) or return undef; # To turn the data back into a statement handle, we need # to fetch the data as an array of arrays, and also have a # a matching array of all the column names my %col_map = (qw/ TABLE_CAT 0 TABLE_SCHEM 1 TABLE_NAME 2 COLUMN_NAME 3 DATA_TYPE 4 TYPE_NAME 5 COLUMN_SIZE 6 BUFFER_LENGTH 7 DECIMAL_DIGITS 8 NUM_PREC_RADIX 9 NULLABLE 10 REMARKS 11 COLUMN_DEF 12 SQL_DATA_TYPE 13 SQL_DATETIME_SUB 14 CHAR_OCTET_LENGTH 15 ORDINAL_POSITION 16 IS_NULLABLE 17 pg_type 18 pg_constraint 19 pg_schema 20 pg_table 21 pg_column 22 pg_enum_values 23 /); for my $row (@$data) { my $typoid = pop @$row; my $typtype = pop @$row; my $typmod = pop @$row; my $attnum = pop @$row; my $aid = pop @$row; $row->[$col_map{COLUMN_SIZE}] = _calc_col_size($typmod,$row->[$col_map{COLUMN_SIZE}]); # Replace the Pg type with the SQL_ type $row->[$col_map{DATA_TYPE}] = DBD::Pg::db::pg_type_info($dbh,$row->[$col_map{DATA_TYPE}]); # Add pg_constraint my $SQL = q{SELECT consrc FROM pg_catalog.pg_constraint WHERE contype = 'c' AND }. qq{conrelid = $aid AND conkey = '{$attnum}'}; my $info = $dbh->selectall_arrayref($SQL); if (@$info) { $row->[$col_map{pg_constraint}] = $info->[0][0]; } else { $row->[$col_map{pg_constraint}] = undef; } if ( $typtype eq 'e' ) { my $order_column = $dbh->{private_dbdpg}{version} >= 90100 ? 'enumsortorder' : 'oid'; $SQL = "SELECT enumlabel FROM pg_catalog.pg_enum WHERE enumtypid = $typoid ORDER BY $order_column"; $row->[$col_map{pg_enum_values}] = $dbh->selectcol_arrayref($SQL); } else { $row->[$col_map{pg_enum_values}] = undef; } } # Since we've processed the data in Perl, we have to jump through a hoop # To turn it back into a statement handle # return _prepare_from_data ( 'column_info', $data, [ sort { $col_map{$a} <=> $col_map{$b} } keys %col_map], ); } sub _prepare_from_data { my ($statement, $data, $names, %attr) = @_; my $sponge = DBI->connect('dbi:Sponge:', '', '', { RaiseError => 1 }); my $sth = $sponge->prepare($statement, { rows=>$data, NAME=>$names, %attr }); return $sth; } sub statistics_info { my $dbh = shift; my ($catalog, $schema, $table, $unique_only, $quick, $attr) = @_; ## Catalog is ignored, but table is mandatory return undef unless defined $table and length $table; my $schema_where = ''; my @exe_args = ($table); my $input_schema = (defined $schema and length $schema) ? 1 : 0; if ($input_schema) { $schema_where = 'AND n.nspname = ? AND n.oid = d.relnamespace'; push(@exe_args, $schema); } else { $schema_where = 'AND n.oid = d.relnamespace'; } my $table_stats_sql = qq{ SELECT d.relpages, d.reltuples, n.nspname FROM pg_catalog.pg_class d, pg_catalog.pg_namespace n WHERE d.relname = ? $schema_where }; my $colnames_sql = qq{ SELECT a.attnum, a.attname FROM pg_catalog.pg_attribute a, pg_catalog.pg_class d, pg_catalog.pg_namespace n WHERE a.attrelid = d.oid AND d.relname = ? $schema_where }; my $stats_sql = qq{ SELECT c.relname, i.indkey, i.indisunique, i.indisclustered, a.amname, n.nspname, c.relpages, c.reltuples, i.indexprs, i.indnatts, i.indexrelid, pg_get_expr(i.indpred,i.indrelid) as predicate, pg_get_expr(i.indexprs,i.indrelid, true) AS indexdef FROM pg_catalog.pg_index i, pg_catalog.pg_class c, pg_catalog.pg_class d, pg_catalog.pg_am a, pg_catalog.pg_namespace n WHERE d.relname = ? $schema_where AND d.oid = i.indrelid AND i.indexrelid = c.oid AND c.relam = a.oid ORDER BY i.indisunique desc, a.amname, c.relname }; my $indexdef_sql = q{ SELECT pg_get_indexdef(indexrelid,x,true) FROM pg_index JOIN generate_series(1,?) s(x) ON indexrelid = ? }; my @output_rows; # Table-level stats if (!$unique_only) { my $table_stats_sth = $dbh->prepare($table_stats_sql); $table_stats_sth->execute(@exe_args) or return undef; my $tst = $table_stats_sth->fetchrow_hashref or return undef; push(@output_rows, [ undef, # TABLE_CAT $tst->{nspname}, # TABLE_SCHEM $table, # TABLE_NAME undef, # NON_UNIQUE undef, # INDEX_QUALIFIER undef, # INDEX_NAME 'table', # TYPE undef, # ORDINAL_POSITION undef, # COLUMN_NAME undef, # ASC_OR_DESC $tst->{reltuples},# CARDINALITY $tst->{relpages}, # PAGES undef, # FILTER_CONDITION undef, # pg_expression ]); } # Fetch the column names for later use my $colnames_sth = $dbh->prepare($colnames_sql); $colnames_sth->execute(@exe_args) or return undef; my $colnames = $colnames_sth->fetchall_hashref('attnum'); # Fetch the individual parts of the index my $sth_indexdef = $dbh->prepare($indexdef_sql); # Fetch the index definitions my $sth = $dbh->prepare($stats_sql); $sth->execute(@exe_args) or return undef; STAT_ROW: while (my $row = $sth->fetchrow_hashref) { next if $unique_only and !$row->{indisunique}; my $indtype = $row->{indisclustered} ? 'clustered' : ( $row->{amname} eq 'btree' ) ? 'btree' : ($row->{amname} eq 'hash' ) ? 'hashed' : 'other'; my $nonunique = $row->{indisunique} ? 0 : 1; my @index_row = ( undef, # TABLE_CAT 0 $row->{nspname}, # TABLE_SCHEM 1 $table, # TABLE_NAME 2 $nonunique, # NON_UNIQUE 3 undef, # INDEX_QUALIFIER 4 $row->{relname}, # INDEX_NAME 5 $indtype, # TYPE 6 undef, # ORDINAL_POSITION 7 undef, # COLUMN_NAME 8 'A', # ASC_OR_DESC 9 $row->{reltuples}, # CARDINALITY 10 $row->{relpages}, # PAGES 11 $row->{predicate}, # FILTER_CONDITION 12 undef, # pg_expression 13 ); ## Grab expression information $sth_indexdef->execute($row->{indnatts}, $row->{indexrelid}); my $expression = $sth_indexdef->fetchall_arrayref(); my $col_nums = $row->{indkey}; $col_nums =~ s/^\s+//; my @col_nums = split(/\s+/, $col_nums); my $ord_pos = 1; for my $col_num (@col_nums) { my @copy = @index_row; $copy[7] = $ord_pos; # ORDINAL_POSITION $copy[8] = $colnames->{$col_num}->{attname}; # COLUMN_NAME $copy[13] = $expression->[$ord_pos-1][0]; push(@output_rows, \@copy); $ord_pos++; } } my @output_colnames = qw/ TABLE_CAT TABLE_SCHEM TABLE_NAME NON_UNIQUE INDEX_QUALIFIER INDEX_NAME TYPE ORDINAL_POSITION COLUMN_NAME ASC_OR_DESC CARDINALITY PAGES FILTER_CONDITION pg_expression /; return _prepare_from_data('statistics_info', \@output_rows, \@output_colnames); } sub primary_key_info { my $dbh = shift; my ($catalog, $schema, $table, $attr) = @_; ## Catalog is ignored, but table is mandatory return undef unless defined $table and length $table; my $whereclause = 'AND c.relname = ' . $dbh->quote($table); if (defined $schema and length $schema) { $whereclause .= "\n\t\t\tAND n.nspname = " . $dbh->quote($schema); } my $TSJOIN = 'pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace)'; if ($dbh->{private_dbdpg}{version} < 80000) { $TSJOIN = '(SELECT 0 AS oid, 0 AS spcname, 0 AS spclocation LIMIT 0) AS t ON (t.oid=1)'; } my $pri_key_sql = qq{ SELECT c.oid , quote_ident(n.nspname) , quote_ident(c.relname) , quote_ident(c2.relname) , i.indkey, quote_ident(t.spcname), quote_ident(t.spclocation) , n.nspname, c.relname, c2.relname FROM pg_catalog.pg_class c JOIN pg_catalog.pg_index i ON (i.indrelid = c.oid) JOIN pg_catalog.pg_class c2 ON (c2.oid = i.indexrelid) LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace) LEFT JOIN $TSJOIN WHERE i.indisprimary IS TRUE $whereclause }; if ($dbh->{private_dbdpg}{version} >= 90200) { $pri_key_sql =~ s/t.spclocation/pg_tablespace_location(t.oid)/; } my $sth = $dbh->prepare($pri_key_sql) or return undef; $sth->execute(); my $info = $sth->fetchall_arrayref()->[0]; return undef if ! defined $info; # Get the attribute information my $indkey = join ',', split /\s+/, $info->[4]; my $sql = qq{ SELECT a.attnum, pg_catalog.quote_ident(a.attname) AS colname, pg_catalog.quote_ident(t.typname) AS typename FROM pg_catalog.pg_attribute a, pg_catalog.pg_type t WHERE a.attrelid = '$info->[0]' AND a.atttypid = t.oid AND attnum IN ($indkey); }; $sth = $dbh->prepare($sql) or return undef; $sth->execute(); my $attribs = $sth->fetchall_hashref('attnum'); my $pkinfo = []; ## Normal way: complete "row" per column in the primary key if (!exists $attr->{'pg_onerow'}) { my $x=0; my @key_seq = split/\s+/, $info->[4]; for (@key_seq) { # TABLE_CAT $pkinfo->[$x][0] = undef; # SCHEMA_NAME $pkinfo->[$x][1] = $info->[1]; # TABLE_NAME $pkinfo->[$x][2] = $info->[2]; # COLUMN_NAME $pkinfo->[$x][3] = $attribs->{$_}{colname}; # KEY_SEQ $pkinfo->[$x][4] = $_; # PK_NAME $pkinfo->[$x][5] = $info->[3]; # DATA_TYPE $pkinfo->[$x][6] = $attribs->{$_}{typename}; $pkinfo->[$x][7] = $info->[5]; $pkinfo->[$x][8] = $info->[6]; $pkinfo->[$x][9] = $info->[7]; $pkinfo->[$x][10] = $info->[8]; $pkinfo->[$x][11] = $info->[9]; $x++; } } else { ## Nicer way: return only one row # TABLE_CAT $info->[0] = undef; # TABLESPACES $info->[7] = $info->[5]; $info->[8] = $info->[6]; # Unquoted names $info->[9] = $info->[7]; $info->[10] = $info->[8]; $info->[11] = $info->[9]; # PK_NAME $info->[5] = $info->[3]; # COLUMN_NAME $info->[3] = 2==$attr->{'pg_onerow'} ? [ map { $attribs->{$_}{colname} } split /\s+/, $info->[4] ] : join ', ', map { $attribs->{$_}{colname} } split /\s+/, $info->[4]; # DATA_TYPE $info->[6] = 2==$attr->{'pg_onerow'} ? [ map { $attribs->{$_}{typename} } split /\s+/, $info->[4] ] : join ', ', map { $attribs->{$_}{typename} } split /\s+/, $info->[4]; # KEY_SEQ $info->[4] = 2==$attr->{'pg_onerow'} ? [ split /\s+/, $info->[4] ] : join ', ', split /\s+/, $info->[4]; $pkinfo = [$info]; } my @cols = (qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME DATA_TYPE)); push @cols, 'pg_tablespace_name', 'pg_tablespace_location'; push @cols, 'pg_schema', 'pg_table', 'pg_column'; return _prepare_from_data('primary_key_info', $pkinfo, \@cols); } sub primary_key { my $sth = primary_key_info(@_[0..3], {pg_onerow => 2}); return defined $sth ? @{$sth->fetchall_arrayref()->[0][3]} : (); } sub foreign_key_info { my $dbh = shift; ## PK: catalog, schema, table, FK: catalog, schema, table, attr ## Each of these may be undef or empty my $pschema = $_[1] || ''; my $ptable = $_[2] || ''; my $fschema = $_[4] || ''; my $ftable = $_[5] || ''; my $args = $_[6]; ## Must have at least one named table return undef if !length($ptable) and !length($ftable); ## If only the primary table is given, we return only those columns ## that are used as foreign keys, even if that means that we return ## unique keys but not primary one. We also return all the foreign ## tables/columns that are referencing them, of course. ## 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 NULL, pg_catalog.quote_ident(uk_ns.nspname), pg_catalog.quote_ident(uk_class.relname), pg_catalog.quote_ident(uk_col.attname), NULL, 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, -- wich 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' AND fk_class.relkind = 'r' AND constr.contype = 'f' ORDER BY constr.conname, colnum.i }; my $fkinfo = $dbh->selectall_arrayref($SQL); return undef unless $fkinfo && @{$fkinfo}; 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; } } return _prepare_from_data('foreign_key_info', $fkinfo, \@cols); } sub table_info { my $dbh = shift; my ($catalog, $schema, $table, $type) = @_; my $tbl_sql = (); my $extracols = q{,NULL::text AS pg_schema, NULL::text AS pg_table}; if ( # Rule 19a (defined $catalog and $catalog eq '%') and (defined $schema and $schema eq '') and (defined $table and $table eq '') ) { $tbl_sql = qq{ SELECT NULL::text AS "TABLE_CAT" , NULL::text AS "TABLE_SCHEM" , NULL::text AS "TABLE_NAME" , NULL::text AS "TABLE_TYPE" , NULL::text AS "REMARKS" $extracols }; } elsif (# Rule 19b (defined $catalog and $catalog eq '') and (defined $schema and $schema eq '%') and (defined $table and $table eq '') ) { $extracols = q{,n.nspname AS pg_schema, NULL::text AS pg_table}; $tbl_sql = qq{SELECT NULL::text AS "TABLE_CAT" , quote_ident(n.nspname) AS "TABLE_SCHEM" , NULL::text AS "TABLE_NAME" , NULL::text AS "TABLE_TYPE" , CASE WHEN n.nspname ~ '^pg_' THEN 'system schema' ELSE 'owned by ' || pg_get_userbyid(n.nspowner) END AS "REMARKS" $extracols FROM pg_catalog.pg_namespace n ORDER BY "TABLE_SCHEM" }; } elsif (# Rule 19c (defined $catalog and $catalog eq '') and (defined $schema and $schema eq '') and (defined $table and $table eq '') and (defined $type and $type eq '%') ) { $tbl_sql = 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' AS "REMARKS" UNION SELECT 'SYSTEM TABLE' , 'relkind: r; 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 'LOCAL TEMPORARY' , 'relkind: r; 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', 'v', 'm')|, # No sequences, etc. for now q|NOT (quote_ident(n.nspname) ~ '^pg_(toast_)?temp_' AND NOT has_schema_privilege(n.nspname, 'USAGE'))|); # No others' temp objects my $showtablespace = ', quote_ident(t.spcname) AS "pg_tablespace_name", quote_ident(t.spclocation) AS "pg_tablespace_location"'; if ($dbh->{private_dbdpg}{version} >= 90200) { $showtablespace = ', quote_ident(t.spcname) AS "pg_tablespace_name", quote_ident(pg_tablespace_location(t.oid)) AS "pg_tablespace_location"'; } ## If the schema or table has an underscore or a %, use a LIKE comparison if (defined $schema and length $schema) { push @search, 'n.nspname ' . ($schema =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($schema); } if (defined $table and length $table) { push @search, 'c.relname ' . ($table =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($table); } my $TSJOIN = 'pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace)'; if ($dbh->{private_dbdpg}{version} < 80000) { $TSJOIN = '(SELECT 0 AS oid, 0 AS spcname, 0 AS spclocation LIMIT 0) AS t ON (t.oid=1)'; } my $whereclause = join "\n\t\t\t\t\t AND " => @search; $tbl_sql = qq{ SELECT NULL::text AS "TABLE_CAT" , quote_ident(n.nspname) AS "TABLE_SCHEM" , quote_ident(c.relname) AS "TABLE_NAME" -- any temp table or temp view is LOCAL TEMPORARY for us , CASE WHEN quote_ident(n.nspname) ~ '^pg_(toast_)?temp_' THEN 'LOCAL TEMPORARY' WHEN c.relkind = 'r' THEN CASE WHEN quote_ident(n.nspname) ~ '^pg_' THEN 'SYSTEM TABLE' ELSE 'TABLE' END WHEN c.relkind = 'v' THEN CASE WHEN quote_ident(n.nspname) ~ '^pg_' THEN 'SYSTEM VIEW' ELSE 'VIEW' END WHEN c.relkind = 'm' THEN CASE WHEN quote_ident(n.nspname) ~ '^pg_' THEN 'SYSTEM MATERIALIZED VIEW' ELSE 'MATERIALIZED VIEW' END ELSE 'UNKNOWN' END AS "TABLE_TYPE" , d.description AS "REMARKS" $showtablespace $extracols FROM pg_catalog.pg_class AS c LEFT JOIN pg_catalog.pg_description AS d ON (c.oid = d.objoid AND c.tableoid = d.classoid AND d.objsubid = 0) LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace) LEFT JOIN $TSJOIN WHERE $whereclause ORDER BY "TABLE_TYPE", "TABLE_CAT", "TABLE_SCHEM", "TABLE_NAME" }; 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)}; } } my $sth = $dbh->prepare( $tbl_sql ) or return undef; $sth->execute(); return $sth; } sub tables { my ($dbh, @args) = @_; my $attr = $args[4]; my $sth = $dbh->table_info(@args) or return; my $tables = $sth->fetchall_arrayref() or return; my @tables = map { (! (ref $attr eq 'HASH' and $attr->{pg_noprefix})) ? "$_->[1].$_->[2]" : $_->[2] } @$tables; return @tables; } sub table_attributes { my ($dbh, $table) = @_; my $sth = $dbh->column_info(undef,undef,$table,undef); my %convert = ( COLUMN_NAME => 'NAME', DATA_TYPE => 'TYPE', COLUMN_SIZE => 'SIZE', NULLABLE => 'NOTNULL', REMARKS => 'REMARKS', COLUMN_DEF => 'DEFAULT', pg_constraint => 'CONSTRAINT', ); my $attrs = $sth->fetchall_arrayref(\%convert); for my $row (@$attrs) { # switch the column names for my $name (keys %$row) { $row->{ $convert{$name} } = $row->{$name}; ## Keep some original columns delete $row->{$name} unless ($name eq 'REMARKS' or $name eq 'NULLABLE'); } # Moved check outside of loop as it was inverting the NOTNULL value for # attribute. # NOTNULL inverts the sense of NULLABLE $row->{NOTNULL} = ($row->{NOTNULL} ? 0 : 1); my @pri_keys = $dbh->primary_key( undef, undef, $table ); $row->{PRIMARY_KEY} = scalar(grep { /^$row->{NAME}$/i } @pri_keys) ? 1 : 0; } return $attrs; } sub _calc_col_size { my $mod = shift; my $size = shift; if ((defined $size) and ($size > 0)) { return $size; } elsif ($mod > 0xffff) { my $prec = ($mod & 0xffff) - 4; $mod >>= 16; my $dig = $mod; return "$prec,$dig"; } elsif ($mod >= 4) { return $mod - 4; } # else { # $rtn = $mod; # $rtn = undef; # } return; } sub type_info_all { my ($dbh) = @_; my $names = { TYPE_NAME => 0, DATA_TYPE => 1, COLUMN_SIZE => 2, LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE => 9, FIXED_PREC_SCALE => 10, AUTO_UNIQUE_VALUE => 11, LOCAL_TYPE_NAME => 12, MINIMUM_SCALE => 13, MAXIMUM_SCALE => 14, SQL_DATA_TYPE => 15, SQL_DATETIME_SUB => 16, NUM_PREC_RADIX => 17, INTERVAL_PRECISION => 18, }; ## This list is derived from dbi_sql.h in DBI, from types.c and types.h, and from the PG docs ## Aids to make the list more readable: my $GIG = 1073741824; my $PS = 'precision/scale'; my $LEN = 'length'; my $UN; my $ti = [ $names, # name sql_type size pfx/sfx crt n/c/s +-/P/I local min max sub rdx itvl ['unknown', SQL_UNKNOWN_TYPE, 0, $UN,$UN, $UN, 1,0,0, $UN,0,0, 'UNKNOWN', $UN,$UN, SQL_UNKNOWN_TYPE, $UN, $UN, $UN ], ['bytea', SQL_VARBINARY, $GIG, q{'},q{'}, $UN, 1,0,3, $UN,0,0, 'BYTEA', $UN,$UN, SQL_VARBINARY, $UN, $UN, $UN ], ['bpchar', SQL_CHAR, $GIG, q{'},q{'}, $LEN, 1,1,3, $UN,0,0, 'CHARACTER', $UN,$UN, SQL_CHAR, $UN, $UN, $UN ], ['numeric', SQL_DECIMAL, 1000, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,1000, SQL_DECIMAL, $UN, $UN, $UN ], ['numeric', SQL_NUMERIC, 1000, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,1000, SQL_NUMERIC, $UN, $UN, $UN ], ['int4', SQL_INTEGER, 10, $UN,$UN, $UN, 1,0,2, 0,0,0, 'INTEGER', 0,0, SQL_INTEGER, $UN, $UN, $UN ], ['int2', SQL_SMALLINT, 5, $UN,$UN, $UN, 1,0,2, 0,0,0, 'SMALLINT', 0,0, SQL_SMALLINT, $UN, $UN, $UN ], ['float4', SQL_FLOAT, 6, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,6, SQL_FLOAT, $UN, $UN, $UN ], ['float8', SQL_REAL, 15, $UN,$UN, $PS, 1,0,2, 0,0,0, 'REAL', 0,15, SQL_REAL, $UN, $UN, $UN ], ['int8', SQL_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_VARCHAR, $GIG, q{'},q{'}, $LEN, 1,1,3, $UN,0,0, 'TEXT', $UN,$UN, SQL_VARCHAR, $UN, $UN, $UN ], ['bool', SQL_BOOLEAN, 1, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'BOOLEAN', $UN,$UN, SQL_BOOLEAN, $UN, $UN, $UN ], ['array', SQL_ARRAY, 1, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'ARRAY', $UN,$UN, SQL_ARRAY, $UN, $UN, $UN ], ['date', SQL_TYPE_DATE, 10, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'DATE', 0,0, SQL_TYPE_DATE, $UN, $UN, $UN ], ['time', SQL_TYPE_TIME, 18, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIME', 0,6, SQL_TYPE_TIME, $UN, $UN, $UN ], ['timestamp',SQL_TYPE_TIMESTAMP,29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMP', 0,6, SQL_TYPE_TIMESTAMP, $UN, $UN, $UN ], ['timetz', SQL_TYPE_TIME_WITH_TIMEZONE, 29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMETZ', 0,6, SQL_TYPE_TIME_WITH_TIMEZONE, $UN, $UN, $UN ], ['timestamptz',SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, 29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMPTZ',0,6, SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, $UN, $UN, $UN ], # # intentionally omitted: char, all geometric types, internal types ]; return $ti; } # Characters that need to be escaped by quote(). my %esc = ( q{'} => '\\047', # '\\' . sprintf("%03o", ord("'")), # ISO SQL 2 '\\' => '\\134', # '\\' . sprintf("%03o", ord("\\")), ); # Set up lookup for SQL types we don't want to escape. my %no_escape = map { $_ => 1 } DBI::SQL_INTEGER, DBI::SQL_SMALLINT, DBI::SQL_BIGINT, DBI::SQL_DECIMAL, DBI::SQL_FLOAT, DBI::SQL_REAL, DBI::SQL_DOUBLE, DBI::SQL_NUMERIC; 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 ], 102 => ['SQL_MAX_PROCEDURE_NAME_LEN', 'NAMEDATALEN' ], ## magic word 104 => ['SQL_MAX_ROW_SIZE', 0 ], ## actually 1.6 TB, but too big to represent here 103 => ['SQL_MAX_ROW_SIZE_INCLUDES_LONG', 'Y' ], 32 => ['SQL_MAX_SCHEMA_NAME_LEN', 'NAMEDATALEN' ], ## magic word 105 => ['SQL_MAX_STATEMENT_LEN', 0 ], 35 => ['SQL_MAX_TABLE_NAME_LEN', 'NAMEDATALEN' ], ## magic word 106 => ['SQL_MAX_TABLES_IN_SELECT', 0 ], 107 => ['SQL_MAX_USER_NAME_LEN', 'NAMEDATALEN' ], ## magic word ## Scalar function information 48 => ['SQL_CONVERT_FUNCTIONS', 2 ], ## CVT_CAST only? 49 => ['SQL_NUMERIC_FUNCTIONS', 16777215 ], ## ?? all but some naming clashes: rand(om), trunc(ate), log10=ln, etc. 50 => ['SQL_STRING_FUNCTIONS', 16280984 ], ## ?? 51 => ['SQL_SYSTEM_FUNCTIONS', 0 ], ## ?? 109 => ['SQL_TIMEDATE_ADD_INTERVALS', 0 ], ## ?? no explicit timestampadd? 110 => ['SQL_TIMEDATE_DIFF_INTERVALS', 0 ], ## ?? 52 => ['SQL_TIMEDATE_FUNCTIONS', 1966083 ], ## Conversion information - all but BIT, LONGVARBINARY, and LONGVARCHAR 53 => ['SQL_CONVERT_BIGINT', 1830399 ], 54 => ['SQL_CONVERT_BINARY', 1830399 ], 55 => ['SQL_CONVERT_BIT', 0 ], 56 => ['SQL_CONVERT_CHAR', 1830399 ], 57 => ['SQL_CONVERT_DATE', 1830399 ], 58 => ['SQL_CONVERT_DECIMAL', 1830399 ], 59 => ['SQL_CONVERT_DOUBLE', 1830399 ], 60 => ['SQL_CONVERT_FLOAT', 1830399 ], 61 => ['SQL_CONVERT_INTEGER', 1830399 ], 123 => ['SQL_CONVERT_INTERVAL_DAY_TIME', 1830399 ], 124 => ['SQL_CONVERT_INTERVAL_YEAR_MONTH', 1830399 ], 71 => ['SQL_CONVERT_LONGVARBINARY', 0 ], 62 => ['SQL_CONVERT_LONGVARCHAR', 0 ], 63 => ['SQL_CONVERT_NUMERIC', 1830399 ], 64 => ['SQL_CONVERT_REAL', 1830399 ], 65 => ['SQL_CONVERT_SMALLINT', 1830399 ], 66 => ['SQL_CONVERT_TIME', 1830399 ], 67 => ['SQL_CONVERT_TIMESTAMP', 1830399 ], 68 => ['SQL_CONVERT_TINYINT', 1830399 ], 69 => ['SQL_CONVERT_VARBINARY', 0 ], 70 => ['SQL_CONVERT_VARCHAR', 1830399 ], 122 => ['SQL_CONVERT_WCHAR', 0 ], 125 => ['SQL_CONVERT_WLONGVARCHAR', 0 ], 126 => ['SQL_CONVERT_WVARCHAR', 0 ], ); ## end of %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 defined $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 =~ /^(\d\d?)(\d\d)(\d\d)$/; return sprintf '%02d.%02d.%.2d00', $1,$2,$3; } elsif ($ans eq 'DBDVERSION') { my $simpleversion = $DBD::Pg::VERSION; $simpleversion =~ s/_/./g; no warnings; 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:2003 ## return join ',' => (qw(ANALYSE ANALYZE ASC DEFERRABLE DESC DO FREEZE ILIKE INITIALLY ISNULL LIMIT NOTNULL OFF OFFSET PLACING RETURNING 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 defined $info->[0] ? $info->[0][0] : 'N'; } elsif ($ans eq 'DEFAULTTXN') { my $SQL = q{SELECT CASE WHEN setting = 'read committed' THEN 2 ELSE 8 END FROM pg_settings WHERE name = 'default_transaction_isolation'}; my $info = $dbh->selectall_arrayref($SQL); return defined $info->[0] ? $info->[0][0] : 2; } return $ans; } # end of get_info sub private_attribute_info { return { pg_async_status => undef, pg_bool_tf => undef, pg_db => undef, pg_default_port => undef, pg_enable_utf8 => undef, pg_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_socket => undef, pg_standard_conforming_strings => undef, pg_switch_prepared => undef, pg_user => undef, }; } } { package DBD::Pg::st; sub parse_trace_flag { my ($h, $flag) = @_; return DBD::Pg->parse_trace_flag($flag); } sub bind_param_array { ## Binds an array of data to a specific placeholder in a statement ## The DBI version is broken, so we implement a near-copy here my $sth = shift; my ($p_id, $value_array, $attr) = @_; ## Bail if the second arg is not undef or an arrayref return $sth->set_err(1, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array)) if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY'; ## Bail if the first arg is not a number return $sth->set_err(1, q{Can't use named placeholders for non-driver supported bind_param_array}) unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here ## Store the list of items in the hash (will be undef or an 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); # For asynchronous calls, import the async constants: use DBD::Pg qw(:async); $dbh->do('INSERT INTO mytable(a) VALUES (1)'); $sth = $dbh->prepare('INSERT INTO mytable(a) VALUES (?)'); $sth->execute(); =head1 VERSION This documents version 3.7.0 of the DBD::Pg module =head1 DESCRIPTION DBD::Pg is a Perl module that works with the DBI module to provide access to PostgreSQL databases. =head1 MODULE DOCUMENTATION This documentation describes driver specific behavior and restrictions. It is not supposed to be used as the only reference for the user. In any case consult the B documentation first! =for html Latest DBI docmentation. =head1 THE DBI CLASS =head2 DBI Class Methods =head3 B This method creates a database handle by connecting to a database, and is the DBI equivalent of the "new" method. To connect to a Postgres database with a minimum of parameters, use the following syntax: $dbh = DBI->connect("dbi:Pg:dbname=$dbname", '', '', {AutoCommit => 0}); This connects to the database named in the C<$dbname> variable on the default port (usually 5432) without any user authentication. The following connect statement shows almost all possible parameters: $dbh = DBI->connect("dbi:Pg:dbname=$dbname;host=$host;port=$port;options=$options", $username, $password, {AutoCommit => 0, RaiseError => 1, PrintError => 0} ); Parameters containing unusual characters such as spaces can be wrapped in single quotes around the value e.g. "dbi:Pg:dbname='spacey name';host=$host" If a parameter is not given, the connect() method will first look for specific environment variables, and then fall back to hard-coded defaults: parameter environment variable hard coded default ------------------------------------------------------ host PGHOST local domain socket hostaddr PGHOSTADDR local domain socket port PGPORT 5432 dbname* PGDATABASE current userid username PGUSER current userid password PGPASSWORD (none) options PGOPTIONS (none) service PGSERVICE (none) sslmode PGSSLMODE (none) * May also use the aliases C or C If the username and password values passed via C are undefined (as opposed to merely being empty strings), DBI will use the environment variables I and I if they exist. You can also connect by using a service connection file, which is named F. The location of this file can be controlled by setting the I environment variable. To use one of the named services within the file, set the name by using either the I parameter or the environment variable I. Note that when connecting this way, only the minimum parameters should be used. For example, to connect to a service named "zephyr", you could use: $dbh = DBI->connect("dbi:Pg:service=zephyr", '', ''); You could also set C<$ENV{PGSERVICE}> to "zephyr" and connect like this: $dbh = DBI->connect("dbi:Pg:", '', ''); The format of the F file is simply a bracketed service name, followed by one parameter per line in the format name=value. For example: [zephyr] dbname=winds user=wisp password=W$2Hc00YSgP port=6543 There are four valid arguments to the I parameter, which controls whether to use SSL to connect to the database: =over 4 =item * disable: SSL connections are never used =item * allow: try non-SSL, then SSL =item * prefer: try SSL, then non-SSL =item * require: connect only with SSL =back You can also connect using sockets in a specific directory. This may be needed if the server you are connecting to has a different default socket directory from the one used to compile DBD::Pg. Use the complete path to the socket directory as the name of the host, like this: $dbh = DBI->connect('dbi:Pg:dbname=foo;host=/var/tmp/socket', $username, $password, {AutoCommit => 0, RaiseError => 1}); The attribute hash can also contain a key named C, which simply calls C<< $dbh->trace('DBD') >> after the handle is created. This attribute is not recommended, as it is clearer to simply explicitly call C explicitly in your script. =head3 B $dbh = DBI->connect_cached("dbi:Pg:dbname=$dbname", $username, $password, \%options); Implemented by DBI, no driver-specific impact. =head3 B @data_sources = DBI->data_sources('Pg'); @data_sources = $dbh->data_sources(); Returns a list of available databases. Unless the environment variable C is set, a connection will be attempted to the database C. The normal connection environment variables also apply, such as C, C, C, C, and C. You can also pass in options to add to the connection string For example, to specify an alternate port and host: @data_sources = DBI->data_sources('Pg', 'port=5824;host=example.com'); or: @data_sources = $dbh->data_sources('port=5824;host=example.com'); =head2 Methods Common To All Handles For all of the methods below, B<$h> can be either a database handle (B<$dbh>) or a statement handle (B<$sth>). Note that I<$dbh> and I<$sth> can be replaced with any variable name you choose: these are just the names most often used. Another common variable used in this documentation is $I, which stands for "return value". =head3 B $rv = $h->err; Returns the error code from the last method called. For the connect method it returns C, which is a number used by I (the Postgres connection library). A value of 0 indicates no error (CONNECTION_OK), while any other number indicates a failed connection. The only other number commonly seen is 1 (CONNECTION_BAD). See the libpq documentation for the complete list of return codes. In all other non-connect methods C<< $h->err >> returns the C of the current handle. This is a number used by libpq and is one of: 0 Empty query string 1 A command that returns no data successfully completed. 2 A command that returns data 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 =for text See the DBI section on TRACING for more information. =for html See the DBI section on TRACING for more information.
=head3 B DBD::Pg uses the C method to support a variety of functions. Note that the name of the function comes I, after the arguments. =over =item table_attributes $attrs = $dbh->func($table, 'table_attributes'); Use of the tables_attributes function is no longer recommended. Instead, you can use the more portable C and C methods to access the same information. The table_attributes method returns, for the given table argument, a reference to an array of hashes, each of which contains the following keys: NAME attribute name TYPE attribute type SIZE attribute size (-1 for variable size) NULLABLE flag nullable DEFAULT default value CONSTRAINT constraint PRIMARY_KEY flag is_primary_key REMARKS attribute description =item pg_lo_creat $lobjId = $dbh->pg_lo_creat($mode); Creates a new large object and returns the object-id. C<$mode> is a bitmask describing read and write access to the new object. This setting is ignored since Postgres version 8.1. For backwards compatibility, however, you should set a valid mode anyway (see L for a list of valid modes). Upon failure it returns C. This function cannot be used if AutoCommit is enabled. The old way of calling large objects functions is deprecated: $dbh->func(.., 'lo_); =item 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_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_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_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. =head3 B (boolean, inherited) Enables warnings. This is on by default, and should only be turned off in a local block for a short a time only when absolutely needed. =head3 B (boolean, read-only) Indicates if a handle has been executed. For database handles, this value is true after the L method has been called, or when one of the child statement handles has issued an L. Issuing a L or L always resets the attribute to false for database handles. For statement handles, any call to L or its variants will flip the value to true for the lifetime of the statement handle. =head3 B (integer, inherited) Sets the trace level, similar to the L method. See the sections on L and L for more details. =head3 B (boolean, read-only) Indicates if a handle is active or not. For database handles, this indicates if the database has been disconnected or not. For statement handles, it indicates if all the data has been fetched yet or not. Use of this attribute is not encouraged. =head3 B (integer, read-only) Returns the number of child processes created for each handle type. For a driver handle, indicates the number of database handles created. For a database handle, indicates the number of statement handles created. For statement handles, it always returns zero, because statement handles do not create kids. =head3 B (integer, read-only) Same as C, but only returns those that are active. =head3 B (hash ref) Returns a hashref of handles. If called on a database handle, returns all statement handles created by use of the C method. If called on a driver handle, returns all database handles created by the L method. =head3 B (array ref) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (code ref, inherited) Implemented by DBI, no driver-specific impact. =head3 B (unsigned integer) Implemented by DBI, no driver-specific impact. =head3 B (string, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Supported by DBD::Pg as proposed by DBI. This method is similar to the SQL function C. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (boolean, inherited) Implemented by DBI, no driver-specific impact. =head3 B (inherited) Implemented by DBI, no driver-specific impact. =head3 B (scalar) Returns C for a driver handle, C for a database handle, and C for a statement handle. Should be rarely needed. =head3 B Not used by DBD::Pg =head3 B Not used by DBD::Pg =head3 B Not used by DBD::Pg =head1 DBI DATABASE HANDLE OBJECTS =head2 Database Handle Methods =head3 B $ary_ref = $dbh->selectall_arrayref($sql); $ary_ref = $dbh->selectall_arrayref($sql, \%attr); $ary_ref = $dbh->selectall_arrayref($sql, \%attr, @bind_values); Returns a reference to an array containing the rows returned by preparing and executing the SQL string. See the DBI documentation for full details. =head3 B $hash_ref = $dbh->selectall_hashref($sql, $key_field); Returns a reference to a hash containing the rows returned by preparing and executing the SQL string. See the DBI documentation for full details. =head3 B $ary_ref = $dbh->selectcol_arrayref($sql, \%attr, @bind_values); Returns a reference to an array containing the first column from each rows returned by preparing and executing the SQL string. It is possible to specify exactly which columns to return. See the DBI documentation for full details. =head3 B $sth = $dbh->prepare($statement, \%attr); WARNING: DBD::Pg now (as of version 1.40) uses true prepared statements by sending them to the backend to be prepared by the Postgres server. Statements that were legal before may no longer work. See below for details. The prepare method prepares a statement for later execution. PostgreSQL supports prepared statements, which enables DBD::Pg to only send the query once, and simply send the arguments for every subsequent call to L. DBD::Pg can use these server-side prepared statements, or it can just send the entire query to the server each time. The best way is automatically chosen for each query. This will be sufficient for most users: keep reading for a more detailed explanation and some optional flags. Queries that do not begin with the word "SELECT", "INSERT", "UPDATE", or "DELETE" are never sent as server-side prepared statements. Deciding whether or not to use prepared statements depends on many factors, but you can force them to be used or not used by using the L attribute when calling L. Setting this to "0" means to never use prepared statements. Setting pg_server_prepare to "1" means that prepared statements should be used whenever possible. This is the default when connected to Postgres servers version 8.0 or higher. Servers that are version 7.4 get a special default value of "2", because server-side statements were only partially supported in that version. In this case, it only uses server-side prepares if all parameters are specifically bound. The 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, the this method return undef. You should check C<< $sth->err >> afterwards (or use the L attribute) to discover if the undef returned was due to an error. Note that the same array reference is returned for each fetch, so don't store the reference and then use it after a later fetch. Also, the elements of the array are also reused for each row, so take care if you want to take a reference to an element. See also L. =head3 B @ary = $sth->fetchrow_array; Similar to the L method, but returns a list of column information rather than a reference to a list. Do not use this in a scalar context. =head3 B $hash_ref = $sth->fetchrow_hashref; $hash_ref = $sth->fetchrow_hashref($name); Fetches the next row of data and returns a hashref containing the name of the columns as the keys and the data itself as the values. Any NULL value is returned as an undef value. If there are no more rows or if an error occurs, the this method return undef. You should check C<< $sth->err >> afterwards (or use the L attribute) to discover if the undef returned was due to an error. The optional C<$name> argument should be either C, C or C, and indicates what sort of transformation to make to the keys in the hash. =head3 B $tbl_ary_ref = $sth->fetchall_arrayref(); $tbl_ary_ref = $sth->fetchall_arrayref( $slice ); $tbl_ary_ref = $sth->fetchall_arrayref( $slice, $max_rows ); Returns a reference to an array of arrays that contains all the remaining rows to be fetched from the statement handle. If there are no more rows, an empty arrayref will be returned. If an error occurs, the data read in so far will be returned. Because of this, you should always check C<< $sth->err >> after calling this method, unless L has been enabled. If C<$slice> is an array reference, fetchall_arrayref uses the L method to fetch each row as an array ref. If the C<$slice> array is not empty then it is used as a slice to select individual columns by perl array index number (starting at 0, unlike column and parameter numbers which start at 1). With no parameters, or if $slice is undefined, fetchall_arrayref acts as if passed an empty array ref. If C<$slice> is a hash reference, fetchall_arrayref uses L to fetch each row as a hash reference. See the DBI documentation for a complete discussion. =head3 B $hash_ref = $sth->fetchall_hashref( $key_field ); Returns a hashref containing all rows to be fetched from the statement handle. See the DBI documentation for a full discussion. =head3 B $rv = $sth->finish; Indicates to DBI that you are finished with the statement handle and are not going to use it again. Only needed when you have not fetched all the possible rows. =head3 B $rv = $sth->rows; Returns the number of rows returned by the last query. In contrast to many other DBD modules, the number of rows is available immediately after calling C<< $sth->execute >>. Note that the L method itself returns the number of rows itself, which means that this method is rarely needed. =head3 B $rv = $sth->bind_col($column_number, \$var_to_bind); $rv = $sth->bind_col($column_number, \$var_to_bind, \%attr ); $rv = $sth->bind_col($column_number, \$var_to_bind, $bind_type ); Binds a Perl variable and/or some attributes to an output column of a SELECT statement. Column numbers count up from 1. You do not need to bind output columns in order to fetch data. See the DBI documentation for a discussion of the optional parameters C<\%attr> and C<$bind_type> =head3 B $rv = $sth->bind_columns(@list_of_refs_to_vars_to_bind); Calls the L method for each column in the SELECT statement, using the supplied list. =head3 B $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh); Fetches all the rows from the statement handle, calls C for each row, and prints the results to C<$fh> (which defaults to F). Rows are separated by C<$lsep> (which defaults to a newline). Columns are separated by C<$fsep> (which defaults to a comma). The C<$maxlen> controls how wide the output can be, and defaults to 35. This method is designed as a handy utility for prototyping and testing queries. Since it uses "neat_list" to format and edit the string for reading by humans, it is not recommended for data transfer applications. =head3 B $blob = $sth->blob_read($id, $offset, $len); Supported by DBD::Pg. This method is implemented by DBI but not currently documented by DBI, so this method might change. This method seems to be heavily influenced by the current implementation of blobs in Oracle. Nevertheless we try to be as compatible as possible. Whereas Oracle suffers from the limitation that blobs are related to tables and every table can have only one blob (datatype LONG), PostgreSQL handles its blobs independent of any table by using so-called object identifiers. This explains why the C method is blessed into the STATEMENT package and not part of the DATABASE package. Here the field parameter has been used to handle this object identifier. The offset and len parameters may be set to zero, in which case the whole blob is fetched at once. See also the PostgreSQL-specific functions concerning blobs, which are available via the C interface. For further information and examples about blobs, please read the chapter about Large Objects in the PostgreSQL Programmer's Guide at L. =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. =head2 Statement Handle Attributes =head3 B (integer, read-only) Returns the number of columns returned by the current statement. A number will only be returned for SELECT statements, for SHOW statements (which always return C<1>), and for INSERT, UPDATE, and DELETE statements which contain a RETURNING clause. This method returns undef if called before C. =head3 B (integer, read-only) Returns the number of placeholders in the current statement. =head3 B (arrayref, read-only) Returns an arrayref of column names for the current statement. This method will only work for SELECT statements, for SHOW statements, and for INSERT, UPDATE, and DELETE statements which contain a RETURNING clause. This method returns undef if called before C. =head3 B (arrayref, read-only) The same as the C attribute, except that all column names are forced to lower case. =head3 B (arrayref, read-only) The same as the C attribute, except that all column names are forced to upper case. =head3 B (hashref, read-only) Similar to the C attribute, but returns a hashref of column names instead of an arrayref. The names of the columns are the keys of the hash, and the values represent the order in which the columns are returned, starting at 0. This method returns undef if called before C. =head3 B (hashref, read-only) The same as the C attribute, except that all column names are forced to lower case. =head3 B (hashref, read-only) The same as the C attribute, except that all column names are forced to lower case. =head3 B (arrayref, read-only) Returns an arrayref indicating the data type for each column in the statement. This method returns undef if called before C. =head3 B (arrayref, read-only) Returns an arrayref of integer values for each column returned by the statement. The number indicates the precision for C columns, the size in number of characters for C and C columns, and for all other types of columns it returns the number of I. This method returns undef if called before C. =head3 B (arrayref, read-only) Returns an arrayref of integer values for each column returned by the statement. The number indicates the scale of the that column. The only type that will return a value is C. This method returns undef if called before C. =head3 B (arrayref, read-only) Returns an arrayref of integer values for each column returned by the statement. The number indicates if the column is nullable or not. 0 = not nullable, 1 = nullable, 2 = unknown. This method returns undef if called before C. =head3 B (dbh, read-only) Returns the database handle this statement handle was created from. =head3 B (hash ref, read-only) Returns a reference to a hash containing the values currently bound to placeholders. If the "named parameters" type of placeholders are being used (such as ":foo"), then the keys of the hash will be the names of the placeholders (without the colon). If the "dollar sign numbers" type of placeholders are being used, the keys of the hash will be the numbers, without the dollar signs. If the "question mark" type is used, integer numbers will be returned, starting at one and increasing for every placeholder. If this method is called before L, the literal values passed in are returned. If called after L, then the quoted versions of the values are returned. =head3 B (hash ref, read-only) Returns a reference to a hash containing the type names currently bound to placeholders. The keys are the same as returned by the ParamValues method. The values are hashrefs containing a single key value pair, in which the key is either 'TYPE' if the type has a generic SQL equivalent, and 'pg_type' if the type can only be expressed by a Postgres type. The value is the internal number corresponding to the type originally passed in. (Placeholders that have not yet been bound will return undef as the value). This allows the output of ParamTypes to be passed back to the L method. =head3 B (string, read-only) Returns the statement string passed to the most recent "prepare" method called in this database handle, even if that method failed. This is especially useful where "RaiseError" is enabled and the exception handler checks $@ and sees that a C method call failed. =head3 B (integer, read-only) DBD::Pg specific attribute. Returns the number of the tuple (row) that was most recently fetched. Returns zero before and after fetching is performed. =head3 B (integer, read-only) DBD::Pg specific attribute. Returns the number of placeholders that are currently bound (via bind_param). =head3 B (hashref, read-only) DBD::Pg specific attribute. Returns a hash of all named placeholders. The key is the name of the placeholder, and the value is a 0 or a 1, indicating if the placeholder has been bound yet (e.g. via bind_param) =head3 B (arrayref, read-only) DBD::Pg specific attribute. It returns a reference to an array of integer values for each column. The integer shows the size of the column in bytes. Variable length columns are indicated by -1. =head3 B (arrayref, read-only) DBD::Pg specific attribute. It returns a reference to an array of strings for each column. The string shows the name of the data_type. =head3 B (arrayref, read-only) DBD::Pg specific attribute. Returns an arrayref of the query split on the placeholders. =head3 B (integer, read-only) DBD::Pg specific attribute. It returns the OID of the last INSERT command. =head3 B (integer, read-only) DBD::Pg specific attribute. It returns the type of the last command. Possible types are: "INSERT", "DELETE", "UPDATE", "SELECT". =head3 B (boolean) DBD::Pg specific attribute. Default is false. If true, the query is passed directly to the backend without parsing for placeholders. =head3 B (boolean) DBD::Pg specific attribute. Default is off. If true, the query will be immediately prepared, rather than waiting for the L call. =head3 B (string) DBD::Pg specific attribute. Specifies the name of the prepared statement to use for this statement handle. Not normally needed, see the section on the L method for more information. =head3 B (integer) DBD::Pg specific attribute. Indicates if DBD::Pg should attempt to use server-side prepared statements for this statement handle. The default value, 1, indicates that prepared statements should be used whenever possible. See the section on the L method for more information. =head3 B (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. (NOTE: This will only work if DBD::Pg has been compiled against Postgres libraries of version 8.0 or greater) The basic usage is as follows: use DBD::Pg ':async'; print "Async do() example:\n"; $dbh->do("SELECT long_running_query()", {pg_async => PG_ASYNC}); do_something_else(); { if ($dbh->pg_ready()) { $res = $dbh->pg_result(); print "Result of do(): $res\n"; } print "Query is still running...\n"; if (cancel_request_received) { $dbh->pg_cancel(); } sleep 1; redo; } print "Async prepare/execute example:\n"; $sth = $dbh->prepare("SELECT long_running_query(1)", {pg_async => PG_ASYNC}); $sth->execute(); ## Changed our mind, cancel and run again: $sth = $dbh->prepare("SELECT 678", {pg_async => PG_ASYNC + PG_OLDQUERY_CANCEL}); $sth->execute(); do_something_else(); if (!$sth->pg_ready) { do_another_thing(); } ## We wait until it is done, and get the result: $res = $dbh->pg_result(); =head3 Asynchronous Constants There are currently three asynchronous constants exported by DBD::Pg. You can import all of them by putting either of these at the top of your script: use DBD::Pg; use DBD::Pg ':async'; You may also use the numbers instead of the constants, but using the constants is recommended as it makes your script more readable. =over 4 =item PG_ASYNC This is a constant for the number 1. It is passed to either the L or the L method as a value to the pg_async key and indicates that the query should be sent asynchronously. =item PG_OLDQUERY_CANCEL This is a constant for the number 2. When passed to either the L or the L method, it causes any currently running asynchronous query to be cancelled and rolled back. It has no effect if no asynchronous query is currently running. =item PG_OLDQUERY_WAIT This is a constant for the number 4. When passed to either the L or the L method, it waits for any currently running asynchronous query to complete. It has no effect if there is no asynchronous query currently running. =back =head3 Asynchronous Methods =over 4 =item B This database-level method attempts to cancel any currently running asynchronous query. It returns true if the cancel succeeded, and false otherwise. Note that a query that has finished before this method is executed will also return false. B: a successful cancellation may leave the database in an unusable state, so you may need to ROLLBACK or ROLLBACK TO a savepoint. As of version 2.17.0 of DBD::Pg, rollbacks are not done automatically. $result = $dbh->pg_cancel(); =item B This method can be called as a database handle method or (for convenience) as a statement handle method. Both simply see if a previously issued asynchronous query has completed yet. It returns true if the statement has finished, in which case you should then call the L method. Calls to C should only be used when you have other things to do while the query is running. If you simply want to wait until the query is done, do not call pg_ready() over and over, but simply call the pg_result() method. my $time = 0; while (!$dbh->pg_ready) { print "Query is still running. Seconds: $time\n"; $time++; sleep 1; } $result = $dbh->pg_result; =item B This database handle method returns the results of a previously issued asynchronous query. If the query is still running, this method will wait until it has finished. The result returned is the number of rows: the same thing that would have been returned by the asynchronous L or L if it had been called without an asynchronous flag. $result = $dbh->pg_result; =back =head3 Asynchronous Examples Here are some working examples of asynchronous queries. Note that we'll use the B function to emulate a long-running query. use strict; use warnings; use Time::HiRes 'sleep'; use DBD::Pg ':async'; my $dbh = DBI->connect('dbi:Pg:dbname=postgres', 'postgres', '', {AutoCommit=>0,RaiseError=>1}); ## Kick off a long running query on the first database: my $sth = $dbh->prepare("SELECT pg_sleep(?)", {pg_async => PG_ASYNC}); $sth->execute(5); ## While that is running, do some other things print "Your query is processing. Thanks for waiting\n"; check_on_the_kids(); ## Expensive sub, takes at least three seconds. while (!$dbh->pg_ready) { check_on_the_kids(); ## If the above function returns quickly for some reason, we add a small sleep sleep 0.1; } print "The query has finished. Gathering results\n"; my $result = $sth->pg_result; print "Result: $result\n"; my $info = $sth->fetchall_arrayref(); Without asynchronous queries, the above script would take about 8 seconds to run: five seconds waiting for the execute to finish, then three for the check_on_the_kids() function to return. With asynchronous queries, the script takes about 6 seconds to run, and gets in two iterations of check_on_the_kids in the process. Here's an example showing the ability to cancel a long-running query. Imagine two slave databases in different geographic locations over a slow network. You need information as quickly as possible, so you query both at once. When you get an answer, you tell the other one to stop working on your query, as you don't need it anymore. use strict; use warnings; use Time::HiRes 'sleep'; use DBD::Pg ':async'; my $dbhslave1 = DBI->connect('dbi:Pg:dbname=postgres;host=slave1', 'postgres', '', {AutoCommit=>0,RaiseError=>1}); my $dbhslave2 = DBI->connect('dbi:Pg:dbname=postgres;host=slave2', 'postgres', '', {AutoCommit=>0,RaiseError=>1}); $SQL = "SELECT count(*) FROM largetable WHERE flavor='blueberry'"; my $sth1 = $dbhslave1->prepare($SQL, {pg_async => PG_ASYNC}); my $sth2 = $dbhslave2->prepare($SQL, {pg_async => PG_ASYNC}); $sth1->execute(); $sth2->execute(); my $winner; while (!defined $winner) { if ($sth1->pg_ready) { $winner = 1; } elsif ($sth2->pg_ready) { $winner = 2; } Time::HiRes::sleep 0.05; } my $count; if ($winner == 1) { $sth2->pg_cancel(); $sth1->pg_result(); $count = $sth1->fetchall_arrayref()->[0][0]; } else { $sth1->pg_cancel(); $sth2->pg_result(); $count = $sth2->fetchall_arrayref()->[0][0]; } =head2 Array support DBD::Pg allows arrays (as arrayrefs) to be passed in to both the L and the L methods. In both cases, the array is flattened into a string representing a Postgres array. When fetching rows from a table that contains a column with an array type, the result will be passed back to your script as an arrayref. To turn off the automatic parsing of returned arrays into arrayrefs, you can set the attribute L, which is true by default. $dbh->{pg_expand_array} = 0; =head2 COPY support DBD::Pg allows for quick (bulk) reading and storing of data by using the B command. The basic process is to use C<< $dbh->do >> to issue a COPY command, and then to either add rows using L, or to read them by using L. The first step is to put the server into "COPY" mode. This is done by sending a complete COPY command to the server, by using the L method. For example: $dbh->do("COPY foobar FROM STDIN"); This would tell the server to enter a COPY IN mode (yes, that's confusing, but the I is COPY IN because of the I COPY FROM). It is now ready to receive information via the L method. The complete syntax of the COPY command is more complex and not documented here: the canonical PostgreSQL documentation for COPY can be found at: http://www.postgresql.org/docs/current/static/sql-copy.html Once a COPY command has been issued, no other SQL commands are allowed until L has been issued (for COPY FROM), or the final L has been called (for COPY TO). Note: All other COPY methods (pg_putline, pg_getline, etc.) are now heavily deprecated in favor of the pg_getcopydata, pg_putcopydata, and pg_putcopyend methods. =head3 B Used to retrieve data from a table after the server has been put into a COPY OUT mode by calling "COPY tablename TO STDOUT". Data is always returned one data row at a time. The first argument to pg_getcopydata is the variable into which the data will be stored (this variable should not be undefined, or it may throw a warning, although it may be a reference). The pg_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 Large Objects DBD::Pg supports all largeobject functions provided by libpq via the C<< $dbh->pg_lo* >> methods. Please note that access to a large object, even read-only large objects, must be put into a transaction. =head2 Cursors Although PostgreSQL supports cursors, they have not been used in the current implementation. When DBD::Pg was created, cursors in PostgreSQL could only be used inside a transaction block. Because only one transaction block at a time is allowed, this would have implied the restriction not to use any nested C