mirror/postgresql
2
0
Fork 0
mirror of https://git.postgresql.org/git/postgresql.git synced 2024-12-21 08:29:39 +08:00
Code Issues Packages Projects Releases Wiki Activity

Force strings passed to and from plperl to be in UTF8 encoding.

Browse Source 
String are converted to UTF8 on the way into perl and to the
database encoding on the way back. This avoids a number of
observed anomalies, and ensures Perl a consistent view of the
world.

Some minor code cleanups are also accomplished.

Alex Hunsaker, reviewed by Andy Colson.
This commit is contained in:
Andrew Dunstan 2011-02-06 17:29:26 -05:00
parent 5ed45ac09c
commit 50d89d422f
5 changed files with 295 additions and 160 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
doc/src/sgml/plperl.sgml
View File

@ -125,6 +125,14 @@ $$ LANGUAGE plperl;
</programlisting>
</para>
<note>
<para>
Arguments will be converted from the database's encoding to UTF-8
for use inside plperl, and then converted from UTF-8 back to the
database encoding upon return.
</para>
</note>
<para>
If an SQL null value<indexterm><primary>null value</><secondary
sortas="PL/Perl">in PL/Perl</></indexterm> is passed to a function,

52
src/pl/plperl/SPI.xs
View File

@ -9,11 +9,14 @@
/* this must be first: */
#include "postgres.h"
#include "mb/pg_wchar.h" /* for GetDatabaseEncoding */
/* Defined by Perl */
#undef _
/* perl stuff */
#include "plperl.h"
#include "plperl_helpers.h"
/*
@ -50,18 +53,21 @@ PROTOTYPES: ENABLE
VERSIONCHECK: DISABLE
SV*
spi_spi_exec_query(query, ...)
char* query;
spi_spi_exec_query(sv, ...)
SV* sv;
PREINIT:
HV *ret_hash;
int limit = 0;
char *query;
CODE:
if (items > 2)
croak("Usage: spi_exec_query(query, limit) "
"or spi_exec_query(query)");
if (items == 2)
limit = SvIV(ST(1));
query = sv2cstr(sv);
ret_hash = plperl_spi_exec(query, limit);
pfree(query);
RETVAL = newRV_noinc((SV*) ret_hash);
OUTPUT:
RETVAL
@ -73,27 +79,32 @@ spi_return_next(rv)
do_plperl_return_next(rv);
SV *
spi_spi_query(query)
char *query;
spi_spi_query(sv)
SV *sv;
CODE:
char* query = sv2cstr(sv);
RETVAL = plperl_spi_query(query);
pfree(query);
OUTPUT:
RETVAL
SV *
spi_spi_fetchrow(cursor)
char *cursor;
spi_spi_fetchrow(sv)
SV* sv;
CODE:
char* cursor = sv2cstr(sv);
RETVAL = plperl_spi_fetchrow(cursor);
pfree(cursor);
OUTPUT:
RETVAL
SV*
spi_spi_prepare(query, ...)
char* query;
spi_spi_prepare(sv, ...)
SV* sv;
CODE:
int i;
SV** argv;
char* query = sv2cstr(sv);
if (items < 1)
Perl_croak(aTHX_ "Usage: spi_prepare(query, ...)");
argv = ( SV**) palloc(( items - 1) * sizeof(SV*));
@ -101,18 +112,20 @@ spi_spi_prepare(query, ...)
argv[i - 1] = ST(i);
RETVAL = plperl_spi_prepare(query, items - 1, argv);
pfree( argv);
pfree(query);
OUTPUT:
RETVAL
SV*
spi_spi_exec_prepared(query, ...)
char * query;
spi_spi_exec_prepared(sv, ...)
SV* sv;
PREINIT:
HV *ret_hash;
CODE:
HV *attr = NULL;
int i, offset = 1, argc;
SV ** argv;
char *query = sv2cstr(sv);
if ( items < 1)
Perl_croak(aTHX_ "Usage: spi_exec_prepared(query, [\\%%attr,] "
"[\\@bind_values])");
@ -128,15 +141,17 @@ spi_spi_exec_prepared(query, ...)
ret_hash = plperl_spi_exec_prepared(query, attr, argc, argv);
RETVAL = newRV_noinc((SV*)ret_hash);
pfree( argv);
pfree(query);
OUTPUT:
RETVAL
SV*
spi_spi_query_prepared(query, ...)
char * query;
spi_spi_query_prepared(sv, ...)
SV * sv;
CODE:
int i;
SV ** argv;
char *query = sv2cstr(sv);
if ( items < 1)
Perl_croak(aTHX_ "Usage: spi_query_prepared(query, "
"[\\@bind_values])");
@ -145,20 +160,25 @@ spi_spi_query_prepared(query, ...)
argv[i - 1] = ST(i);
RETVAL = plperl_spi_query_prepared(query, items - 1, argv);
pfree( argv);
pfree(query);
OUTPUT:
RETVAL
void
spi_spi_freeplan(query)
char *query;
spi_spi_freeplan(sv)
SV *sv;
CODE:
char *query = sv2cstr(sv);
plperl_spi_freeplan(query);
pfree(query);
void
spi_spi_cursor_close(cursor)
char *cursor;
spi_spi_cursor_close(sv)
SV *sv;
CODE:
char *cursor = sv2cstr(sv);
plperl_spi_cursor_close(cursor);
pfree(cursor);
BOOT:

66
src/pl/plperl/Util.xs
View File

@ -21,7 +21,7 @@
/* perl stuff */
#include "plperl.h"
#include "plperl_helpers.h"
/*
* Implementation of plperl's elog() function
@ -34,13 +34,16 @@
* This is out-of-line to suppress "might be clobbered by longjmp" warnings.
*/
static void
do_util_elog(int level, char *message)
do_util_elog(int level, SV *msg)
{
MemoryContext oldcontext = CurrentMemoryContext;
char *cmsg = NULL;
PG_TRY();
{
elog(level, "%s", message);
cmsg = sv2cstr(msg);
elog(level, "%s", cmsg);
pfree(cmsg);
}
PG_CATCH();
{
@ -51,35 +54,20 @@ do_util_elog(int level, char *message)
edata = CopyErrorData();
FlushErrorState();
if (cmsg)
pfree(cmsg);
/* Punt the error to Perl */
croak("%s", edata->message);
}
PG_END_TRY();
}
static SV *
newSVstring_len(const char *str, STRLEN len)
{
SV *sv;
sv = newSVpvn(str, len);
#if PERL_BCDVERSION >= 0x5006000L
if (GetDatabaseEncoding() == PG_UTF8)
SvUTF8_on(sv);
#endif
return sv;
}
static text *
sv2text(SV *sv)
{
STRLEN sv_len;
char *sv_pv;
if (!sv)
sv = &PL_sv_undef;
sv_pv = SvPV(sv, sv_len);
return cstring_to_text_with_len(sv_pv, sv_len);
char *str = sv2cstr(sv);
return cstring_to_text(str);
}
MODULE = PostgreSQL::InServer::Util PREFIX = util_
@ -105,15 +93,15 @@ _aliased_constants()
void
util_elog(level, message)
util_elog(level, msg)
int level
char* message
SV *msg
CODE:
if (level > ERROR) /* no PANIC allowed thanks */
level = ERROR;
if (level < DEBUG5)
level = DEBUG5;
do_util_elog(level, message);
do_util_elog(level, msg);
SV *
util_quote_literal(sv)
@ -125,7 +113,9 @@ util_quote_literal(sv)
else {
text *arg = sv2text(sv);
text *ret = DatumGetTextP(DirectFunctionCall1(quote_literal, PointerGetDatum(arg)));
RETVAL = newSVstring_len(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ));
char *str = text_to_cstring(ret);
RETVAL = cstr2sv(str);
pfree(str);
}
OUTPUT:
RETVAL
@ -136,13 +126,15 @@ util_quote_nullable(sv)
CODE:
if (!sv || !SvOK(sv))
{
RETVAL = newSVstring_len("NULL", 4);
RETVAL = cstr2sv("NULL");
}
else
{
text *arg = sv2text(sv);
text *ret = DatumGetTextP(DirectFunctionCall1(quote_nullable, PointerGetDatum(arg)));
RETVAL = newSVstring_len(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ));
char *str = text_to_cstring(ret);
RETVAL = cstr2sv(str);
pfree(str);
}
OUTPUT:
RETVAL
@ -153,10 +145,13 @@ util_quote_ident(sv)
PREINIT:
text *arg;
text *ret;
char *str;
CODE:
arg = sv2text(sv);
ret = DatumGetTextP(DirectFunctionCall1(quote_ident, PointerGetDatum(arg)));
RETVAL = newSVstring_len(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ));
str = text_to_cstring(ret);
RETVAL = cstr2sv(str);
pfree(str);
OUTPUT:
RETVAL
@ -167,9 +162,9 @@ util_decode_bytea(sv)
char *arg;
text *ret;
CODE:
arg = SvPV_nolen(sv);
arg = SvPVbyte_nolen(sv);
ret = DatumGetTextP(DirectFunctionCall1(byteain, PointerGetDatum(arg)));
/* not newSVstring_len because this is raw bytes not utf8'able */
/* not cstr2sv because this is raw bytes not utf8'able */
RETVAL = newSVpvn(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ));
OUTPUT:
RETVAL
@ -180,10 +175,13 @@ util_encode_bytea(sv)
PREINIT:
text *arg;
char *ret;
STRLEN len;
CODE:
arg = sv2text(sv);
/* not sv2text because this is raw bytes not utf8'able */
ret = SvPVbyte(sv, len);
arg = cstring_to_text_with_len(ret, len);
ret = DatumGetCString(DirectFunctionCall1(byteaout, PointerGetDatum(arg)));
RETVAL = newSVstring_len(ret, strlen(ret));
RETVAL = cstr2sv(ret);
OUTPUT:
RETVAL

260
src/pl/plperl/plperl.c
View File

@ -43,6 +43,7 @@
/* perl stuff */
#include "plperl.h"
#include "plperl_helpers.h"
/* string literal macros defining chunks of perl code */
#include "perlchunks.h"
@ -222,7 +223,7 @@ static void plperl_init_shared_libs(pTHX);
static void plperl_trusted_init(void);
static void plperl_untrusted_init(void);
static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
static SV *newSVstring(const char *str);
static char *hek2cstr(HE *he);
static SV **hv_store_string(HV *hv, const char *key, SV *val);
static SV **hv_fetch_string(HV *hv, const char *key);
static void plperl_create_sub(plperl_proc_desc *desc, char *s, Oid fn_oid);
@ -239,24 +240,39 @@ static char *setlocale_perl(int category, char *locale);
#endif
/*
* Convert an SV to char * and verify the encoding via pg_verifymbstr()
* convert a HE (hash entry) key to a cstr in the current database encoding
*/
static inline char *
sv2text_mbverified(SV *sv)
static char *
hek2cstr(HE *he)
{
char *val;
STRLEN len;
/*
* The value returned here might include an embedded nul byte, because
* perl allows such things. That's OK, because pg_verifymbstr will choke
* on it, If we just used strlen() instead of getting perl's idea of the
* length, whatever uses the "verified" value might get something quite
* weird.
* Unfortunately, while HeUTF8 is true for most things > 256, for
* values 128..255 it's not, but perl will treat them as
* unicode code points if the utf8 flag is not set ( see
* The "Unicode Bug" in perldoc perlunicode for more)
*
* So if we did the expected:
* if (HeUTF8(he))
* utf_u2e(key...);
* else // must be ascii
* return HePV(he);
* we won't match columns with codepoints from 128..255
*
* For a more concrete example given a column with the
* name of the unicode codepoint U+00ae (registered sign)
* and a UTF8 database and the perl return_next {
* "\N{U+00ae}=>'text } would always fail as heUTF8
* returns 0 and HePV() would give us a char * with 1 byte
* contains the decimal value 174
*
* Perl has the brains to know when it should utf8 encode
* 174 properly, so here we force it into an SV so that
* perl will figure it out and do the right thing
*/
val = SvPV(sv, len);
pg_verifymbstr(val, len, false);
return val;
SV *sv = HeSVKEY_force(he);
if (HeUTF8(he))
SvUTF8_on(sv);
return sv2cstr(sv);
}
/*
@ -568,7 +584,7 @@ select_perl_context(bool trusted)
eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
if (SvTRUE(ERRSV))
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
(errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
/* Fully initialized, so mark the hashtable entry valid */
@ -609,7 +625,6 @@ static PerlInterpreter *
plperl_init_interp(void)
{
PerlInterpreter *plperl;
static int perl_sys_init_done;
static char *embedding[3 + 2] = {
"", "-e", PLC_PERLBOOT
@ -678,15 +693,19 @@ plperl_init_interp(void)
* true when MYMALLOC is set.
*/
#if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
/* only call this the first time through, as per perlembed man page */
if (!perl_sys_init_done)
{
char *dummy_env[1] = {NULL};
static int perl_sys_init_done;
PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
perl_sys_init_done = 1;
/* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */
dummy_env[0] = NULL;
/* only call this the first time through, as per perlembed man page */
if (!perl_sys_init_done)
{
char *dummy_env[1] = {NULL};
PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
perl_sys_init_done = 1;
/* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */
dummy_env[0] = NULL;
}
}
#endif
@ -727,12 +746,12 @@ plperl_init_interp(void)
if (perl_parse(plperl, plperl_init_shared_libs,
nargs, embedding, NULL) != 0)
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
(errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
errcontext("while parsing Perl initialization")));
if (perl_run(plperl) != 0)
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
(errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
errcontext("while running Perl initialization")));
#ifdef PLPERL_RESTORE_LOCALE
@ -836,22 +855,19 @@ plperl_trusted_init(void)
eval_pv(PLC_TRUSTED, FALSE);
if (SvTRUE(ERRSV))
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
(errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
errcontext("while executing PLC_TRUSTED")));
if (GetDatabaseEncoding() == PG_UTF8)
{
/*
* Force loading of utf8 module now to prevent errors that can arise
* from the regex code later trying to load utf8 modules. See
* http://rt.perl.org/rt3/Ticket/Display.html?id=47576
*/
eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE);
if (SvTRUE(ERRSV))
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
errcontext("while executing utf8fix")));
}
/*
* Force loading of utf8 module now to prevent errors that can arise
* from the regex code later trying to load utf8 modules. See
* http://rt.perl.org/rt3/Ticket/Display.html?id=47576
*/
eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE);
if (SvTRUE(ERRSV))
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
errcontext("while executing utf8fix")));
/*
* Lock down the interpreter
@ -891,7 +907,7 @@ plperl_trusted_init(void)
eval_pv(plperl_on_plperl_init, FALSE);
if (SvTRUE(ERRSV))
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
(errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
errcontext("while executing plperl.on_plperl_init")));
}
@ -912,7 +928,7 @@ plperl_untrusted_init(void)
eval_pv(plperl_on_plperlu_init, FALSE);
if (SvTRUE(ERRSV))
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
(errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
errcontext("while executing plperl.on_plperlu_init")));
}
}
@ -940,17 +956,18 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
{
TupleDesc td = attinmeta->tupdesc;
char **values;
SV *val;
char *key;
I32 klen;
HE *he;
HeapTuple tup;
int i;
values = (char **) palloc0(td->natts * sizeof(char *));
hv_iterinit(perlhash);
while ((val = hv_iternextsv(perlhash, &key, &klen)))
while ((he = hv_iternext(perlhash)))
{
int attn = SPI_fnumber(td, key);
SV *val = HeVAL(he);
char *key = hek2cstr(he);
int attn = SPI_fnumber(td, key);
if (attn <= 0 || td->attrs[attn - 1]->attisdropped)
ereport(ERROR,
@ -959,13 +976,22 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
key)));
if (SvOK(val))
{
values[attn - 1] = sv2text_mbverified(val);
values[attn - 1] = sv2cstr(val);
}
pfree(key);
}
hv_iterinit(perlhash);
tup = BuildTupleFromCStrings(attinmeta, values);
for(i = 0; i < td->natts; i++)
{
if (values[i])
pfree(values[i]);
}
pfree(values);
return tup;
}
@ -1025,8 +1051,8 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
)
);
hv_store_string(hv, "name", newSVstring(tdata->tg_trigger->tgname));
hv_store_string(hv, "relid", newSVstring(relid));
hv_store_string(hv, "name", cstr2sv(tdata->tg_trigger->tgname));
hv_store_string(hv, "relid", cstr2sv(relid));
if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
{
@ -1062,7 +1088,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
else
event = "UNKNOWN";
hv_store_string(hv, "event", newSVstring(event));
hv_store_string(hv, "event", cstr2sv(event));
hv_store_string(hv, "argc", newSViv(tdata->tg_trigger->tgnargs));
if (tdata->tg_trigger->tgnargs > 0)
@ -1071,18 +1097,18 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
av_extend(av, tdata->tg_trigger->tgnargs);
for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
av_push(av, newSVstring(tdata->tg_trigger->tgargs[i]));
av_push(av, cstr2sv(tdata->tg_trigger->tgargs[i]));
hv_store_string(hv, "args", newRV_noinc((SV *) av));
}
hv_store_string(hv, "relname",
newSVstring(SPI_getrelname(tdata->tg_relation)));
cstr2sv(SPI_getrelname(tdata->tg_relation)));
hv_store_string(hv, "table_name",
newSVstring(SPI_getrelname(tdata->tg_relation)));
cstr2sv(SPI_getrelname(tdata->tg_relation)));
hv_store_string(hv, "table_schema",
newSVstring(SPI_getnspname(tdata->tg_relation)));
cstr2sv(SPI_getnspname(tdata->tg_relation)));
if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
when = "BEFORE";
@ -1092,7 +1118,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
when = "INSTEAD OF";
else
when = "UNKNOWN";
hv_store_string(hv, "when", newSVstring(when));
hv_store_string(hv, "when", cstr2sv(when));
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
level = "ROW";
@ -1100,7 +1126,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
level = "STATEMENT";
else
level = "UNKNOWN";
hv_store_string(hv, "level", newSVstring(level));
hv_store_string(hv, "level", cstr2sv(level));
return newRV_noinc((SV *) hv);
}
@ -1113,10 +1139,8 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
{
SV **svp;
HV *hvNew;
HE *he;
HeapTuple rtup;
SV *val;
char *key;
I32 klen;
int slotsused;
int *modattrs;
Datum *modvalues;
@ -1143,13 +1167,15 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
slotsused = 0;
hv_iterinit(hvNew);
while ((val = hv_iternextsv(hvNew, &key, &klen)))
while ((he = hv_iternext(hvNew)))
{
int attn = SPI_fnumber(tupdesc, key);
Oid typinput;
Oid typioparam;
int32 atttypmod;
FmgrInfo finfo;
SV *val = HeVAL(he);
char *key = hek2cstr(he);
int attn = SPI_fnumber(tupdesc, key);
if (attn <= 0 || tupdesc->attrs[attn - 1]->attisdropped)
ereport(ERROR,
@ -1163,11 +1189,13 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
atttypmod = tupdesc->attrs[attn - 1]->atttypmod;
if (SvOK(val))
{
char *str = sv2cstr(val);
modvalues[slotsused] = InputFunctionCall(&finfo,
sv2text_mbverified(val),
str,
typioparam,
atttypmod);
modnulls[slotsused] = ' ';
pfree(str);
}
else
{
@ -1179,6 +1207,8 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
}
modattrs[slotsused] = attn;
slotsused++;
pfree(key);
}
hv_iterinit(hvNew);
@ -1420,7 +1450,7 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
SAVETMPS;
PUSHMARK(SP);
EXTEND(SP, 4);
PUSHs(sv_2mortal(newSVstring(subname)));
PUSHs(sv_2mortal(cstr2sv(subname)));
PUSHs(sv_2mortal(newRV_noinc((SV *) pragma_hv)));
/*
* Use 'false' for $prolog in mkfunc, which is kept for compatibility
@ -1428,7 +1458,7 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
* the function compiler.
*/
PUSHs(&PL_sv_no);
PUSHs(sv_2mortal(newSVstring(s)));
PUSHs(sv_2mortal(cstr2sv(s)));
PUTBACK;
/*
@ -1457,7 +1487,7 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
if (SvTRUE(ERRSV))
ereport(ERROR,
(errcode(ERRCODE_SYNTAX_ERROR),
errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
if (!subref)
ereport(ERROR,
@ -1533,7 +1563,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
fcinfo->arg[i]);
sv = newSVstring(tmp);
sv = cstr2sv(tmp);
PUSHs(sv_2mortal(sv));
pfree(tmp);
}
@ -1561,7 +1591,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
LEAVE;
/* XXX need to find a way to assign an errcode here */
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
(errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
}
retval = newSVsv(POPs);
@ -1594,7 +1624,7 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
EXTEND(sp, tg_trigger->tgnargs);
for (i = 0; i < tg_trigger->tgnargs; i++)
PUSHs(sv_2mortal(newSVstring(tg_trigger->tgargs[i])));
PUSHs(sv_2mortal(cstr2sv(tg_trigger->tgargs[i])));
PUTBACK;
/* Do NOT use G_KEEPERR here */
@ -1618,7 +1648,7 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
LEAVE;
/* XXX need to find a way to assign an errcode here */
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
(errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
}
retval = newSVsv(POPs);
@ -1766,6 +1796,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
else
{
/* Return a perl string converted to a Datum */
char *str;
if (prodesc->fn_retisarray && SvROK(perlret) &&
SvTYPE(SvRV(perlret)) == SVt_PVAV)
@ -1775,9 +1806,11 @@ plperl_func_handler(PG_FUNCTION_ARGS)
perlret = array_ret;
}
str = sv2cstr(perlret);
retval = InputFunctionCall(&prodesc->result_in_func,
sv2text_mbverified(perlret),
str,
prodesc->result_typioparam, -1);
pfree(str);
}
/* Restore the previous error callback */
@ -1857,7 +1890,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
HeapTuple trv;
char *tmp;
tmp = SvPV_nolen(perlret);
tmp = sv2cstr(perlret);
if (pg_strcasecmp(tmp, "SKIP") == 0)
trv = NULL;
@ -1888,6 +1921,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
trv = NULL;
}
retval = PointerGetDatum(trv);
pfree(tmp);
}
/* Restore the previous error callback */
@ -2231,7 +2265,7 @@ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
outputstr = OidOutputFunctionCall(typoutput, attr);
hv_store_string(hv, attname, newSVstring(outputstr));
hv_store_string(hv, attname, cstr2sv(outputstr));
pfree(outputstr);
}
@ -2336,7 +2370,7 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
result = newHV();
hv_store_string(result, "status",
newSVstring(SPI_result_code_string(status)));
cstr2sv(SPI_result_code_string(status)));
hv_store_string(result, "processed",
newSViv(processed));
@ -2466,16 +2500,20 @@ plperl_return_next(SV *sv)
if (SvOK(sv))
{
char *str;
if (prodesc->fn_retisarray && SvROK(sv) &&
SvTYPE(SvRV(sv)) == SVt_PVAV)
{
sv = plperl_convert_to_pg_array(sv);
}
str = sv2cstr(sv);
ret = InputFunctionCall(&prodesc->result_in_func,
sv2text_mbverified(sv),
str,
prodesc->result_typioparam, -1);
isNull = false;
pfree(str);
}
else
{
@ -2531,7 +2569,7 @@ plperl_spi_query(char *query)
if (portal == NULL)
elog(ERROR, "SPI_cursor_open() failed:%s",
SPI_result_code_string(SPI_result));
cursor = newSVstring(portal->name);
cursor = cstr2sv(portal->name);
/* Commit the inner transaction, return to outer xact context */
ReleaseCurrentSubTransaction();
@ -2716,8 +2754,11 @@ plperl_spi_prepare(char *query, int argc, SV **argv)
typInput,
typIOParam;
int32 typmod;
char *typstr;
parseTypeString(SvPV_nolen(argv[i]), &typId, &typmod);
typstr = sv2cstr(argv[i]);
parseTypeString(typstr, &typId, &typmod);
pfree(typstr);
getTypeInputInfo(typId, &typInput, &typIOParam);
@ -2804,7 +2845,7 @@ plperl_spi_prepare(char *query, int argc, SV **argv)
HASH_ENTER, &found);
hash_entry->query_data = qdesc;
return newSVstring(qdesc->qname);
return cstr2sv(qdesc->qname);
}
HV *
@ -2881,11 +2922,13 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
{
if (SvOK(argv[i]))
{
char *str = sv2cstr(argv[i]);
argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
sv2text_mbverified(argv[i]),
str,
qdesc->argtypioparams[i],
-1);
nulls[i] = ' ';
pfree(str);
}
else
{
@ -3014,11 +3057,13 @@ plperl_spi_query_prepared(char *query, int argc, SV **argv)
{
if (SvOK(argv[i]))
{
char *str = sv2cstr(argv[i]);
argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
sv2text_mbverified(argv[i]),
str,
qdesc->argtypioparams[i],
-1);
nulls[i] = ' ';
pfree(str);
}
else
{
@ -3044,7 +3089,7 @@ plperl_spi_query_prepared(char *query, int argc, SV **argv)
elog(ERROR, "SPI_cursor_open() failed:%s",
SPI_result_code_string(SPI_result));
cursor = newSVstring(portal->name);
cursor = cstr2sv(portal->name);
/* Commit the inner transaction, return to outer xact context */
ReleaseCurrentSubTransaction();
@ -3124,23 +3169,6 @@ plperl_spi_freeplan(char *query)
SPI_freeplan(plan);
}
/*
* Create a new SV from a string assumed to be in the current database's
* encoding.
*/
static SV *
newSVstring(const char *str)
{
SV *sv;
sv = newSVpv(str, 0);
#if PERL_BCDVERSION >= 0x5006000L
if (GetDatabaseEncoding() == PG_UTF8)
SvUTF8_on(sv);
#endif
return sv;
}
/*
* Store an SV into a hash table under a key that is a string assumed to be
* in the current database's encoding.
@ -3148,7 +3176,11 @@ newSVstring(const char *str)
static SV **
hv_store_string(HV *hv, const char *key, SV *val)
{
int32 klen = strlen(key);
int32 hlen;
char *hkey;
SV **ret;
hkey = (char*)pg_do_encoding_conversion((unsigned char *)key, strlen(key), GetDatabaseEncoding(), PG_UTF8);
/*
* This seems nowhere documented, but under Perl 5.8.0 and up, hv_store()
@ -3156,11 +3188,13 @@ hv_store_string(HV *hv, const char *key, SV *val)
* does not appear that hashes track UTF-8-ness of keys at all in Perl
* 5.6.
*/
#if PERL_BCDVERSION >= 0x5008000L
if (GetDatabaseEncoding() == PG_UTF8)
klen = -klen;
#endif
return hv_store(hv, key, klen, val, 0);
hlen = -strlen(hkey);
ret = hv_store(hv, hkey, hlen, val, 0);
if (hkey != key)
pfree(hkey);
return ret;
}
/*
@ -3170,14 +3204,20 @@ hv_store_string(HV *hv, const char *key, SV *val)
static SV **
hv_fetch_string(HV *hv, const char *key)
{
int32 klen = strlen(key);
int32 hlen;
char *hkey;
SV **ret;
hkey = (char*)pg_do_encoding_conversion((unsigned char *)key, strlen(key), GetDatabaseEncoding(), PG_UTF8);
/* See notes in hv_store_string */
#if PERL_BCDVERSION >= 0x5008000L
if (GetDatabaseEncoding() == PG_UTF8)
klen = -klen;
#endif
return hv_fetch(hv, key, klen, 0);
hlen = -strlen(hkey);
ret = hv_fetch(hv, hkey, hlen, 0);
if(hkey != key)
pfree(hkey);
return ret;
}
/*

69
src/pl/plperl/plperl_helpers.h Normal file
View File

@ -0,0 +1,69 @@
#ifndef PL_PERL_HELPERS_H
#define PL_PERL_HELPERS_H
/*
* convert from utf8 to database encoding
*/
static inline char *
utf_u2e(const char *utf8_str, size_t len)
{
char *ret = (char*)pg_do_encoding_conversion((unsigned char*)utf8_str, len, PG_UTF8, GetDatabaseEncoding());
if (ret == utf8_str)
ret = pstrdup(ret);
return ret;
}
/*
* convert from database encoding to utf8
*/
static inline char *
utf_e2u(const char *str)
{
char *ret = (char*)pg_do_encoding_conversion((unsigned char*)str, strlen(str), GetDatabaseEncoding(), PG_UTF8);
if (ret == str)
ret = pstrdup(ret);
return ret;
}
/*
* Convert an SV to a char * in the current database encoding
*/
static inline char *
sv2cstr(SV *sv)
{
char *val;
STRLEN len;
/*
* get a utf8 encoded char * out of perl. *note* it may not be valid utf8!
*/
val = SvPVutf8(sv, len);
/*
* we use perls length in the event we had an embedded null byte to ensure
* we error out properly
*/
return utf_u2e(val, len);
}
/*
* Create a new SV from a string assumed to be in the current database's
* encoding.
*/
static inline SV *
cstr2sv(const char *str)
{
SV *sv;
char *utf8_str = utf_e2u(str);
sv = newSVpv(utf8_str, 0);
SvUTF8_on(sv);
pfree(utf8_str);
return sv;
}
#endif /* PL_PERL_HELPERS_H */