From a3dff39c53bddf633bc0ba2ab3dc8681be50d6bf Mon Sep 17 00:00:00 2001
From: Tom Lane <tgl@sss.pgh.pa.us>
Date: Sun, 15 Oct 2006 18:56:39 +0000
Subject: [PATCH] Adjust plperl to ensure that all strings and hash keys passed
to Perl are marked as UTF8 when the database encoding is UTF8. This should
avoid inconsistencies like that exhibited in bug #2683 from Vitali Stupin.
---
src/pl/plperl/plperl.c | 184 +++++++++++++++++++++++++----------------
1 file changed, 114 insertions(+), 70 deletions(-)
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index d683e42cf54..d645c5c8592 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -1,7 +1,7 @@
/**********************************************************************
* plperl.c - perl as a procedural language for PostgreSQL
*
- * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.119 2006/10/04 00:30:13 momjian Exp $
+ * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.120 2006/10/15 18:56:39 tgl Exp $
*
**********************************************************************/
@@ -114,6 +114,9 @@ static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
static void plperl_init_shared_libs(pTHX);
static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
+static SV *newSVstring(const char *str);
+static SV **hv_store_string(HV *hv, const char *key, SV *val);
+static SV **hv_fetch_string(HV *hv, const char *key);
/*
* This routine is a crock, and so is everyplace that calls it. The problem
@@ -471,61 +474,61 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
)
);
- hv_store(hv, "name", 4, newSVpv(tdata->tg_trigger->tgname, 0), 0);
- hv_store(hv, "relid", 5, newSVpv(relid, 0), 0);
+ hv_store_string(hv, "name", newSVstring(tdata->tg_trigger->tgname));
+ hv_store_string(hv, "relid", newSVstring(relid));
if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
{
event = "INSERT";
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
- hv_store(hv, "new", 3,
- plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
- 0);
+ hv_store_string(hv, "new",
+ plperl_hash_from_tuple(tdata->tg_trigtuple,
+ tupdesc));
}
else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
{
event = "DELETE";
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
- hv_store(hv, "old", 3,
- plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
- 0);
+ hv_store_string(hv, "old",
+ plperl_hash_from_tuple(tdata->tg_trigtuple,
+ tupdesc));
}
else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
{
event = "UPDATE";
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
{
- hv_store(hv, "old", 3,
- plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
- 0);
- hv_store(hv, "new", 3,
- plperl_hash_from_tuple(tdata->tg_newtuple, tupdesc),
- 0);
+ hv_store_string(hv, "old",
+ plperl_hash_from_tuple(tdata->tg_trigtuple,
+ tupdesc));
+ hv_store_string(hv, "new",
+ plperl_hash_from_tuple(tdata->tg_newtuple,
+ tupdesc));
}
}
else
event = "UNKNOWN";
- hv_store(hv, "event", 5, newSVpv(event, 0), 0);
- hv_store(hv, "argc", 4, newSViv(tdata->tg_trigger->tgnargs), 0);
+ hv_store_string(hv, "event", newSVstring(event));
+ hv_store_string(hv, "argc", newSViv(tdata->tg_trigger->tgnargs));
if (tdata->tg_trigger->tgnargs > 0)
{
AV *av = newAV();
for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
- av_push(av, newSVpv(tdata->tg_trigger->tgargs[i], 0));
- hv_store(hv, "args", 4, newRV_noinc((SV *) av), 0);
+ av_push(av, newSVstring(tdata->tg_trigger->tgargs[i]));
+ hv_store_string(hv, "args", newRV_noinc((SV *) av));
}
- hv_store(hv, "relname", 7,
- newSVpv(SPI_getrelname(tdata->tg_relation), 0), 0);
+ hv_store_string(hv, "relname",
+ newSVstring(SPI_getrelname(tdata->tg_relation)));
- hv_store(hv, "table_name", 10,
- newSVpv(SPI_getrelname(tdata->tg_relation), 0), 0);
+ hv_store_string(hv, "table_name",
+ newSVstring(SPI_getrelname(tdata->tg_relation)));
- hv_store(hv, "table_schema", 12,
- newSVpv(SPI_getnspname(tdata->tg_relation), 0), 0);
+ hv_store_string(hv, "table_schema",
+ newSVstring(SPI_getnspname(tdata->tg_relation)));
if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
when = "BEFORE";
@@ -533,7 +536,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
when = "AFTER";
else
when = "UNKNOWN";
- hv_store(hv, "when", 4, newSVpv(when, 0), 0);
+ hv_store_string(hv, "when", newSVstring(when));
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
level = "ROW";
@@ -541,7 +544,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
level = "STATEMENT";
else
level = "UNKNOWN";
- hv_store(hv, "level", 5, newSVpv(level, 0), 0);
+ hv_store_string(hv, "level", newSVstring(level));
return newRV_noinc((SV *) hv);
}
@@ -567,7 +570,7 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
tupdesc = tdata->tg_relation->rd_att;
- svp = hv_fetch(hvTD, "new", 3, FALSE);
+ svp = hv_fetch_string(hvTD, "new");
if (!svp)
ereport(ERROR,
(errcode(ERRCODE_UNDEFINED_COLUMN),
@@ -741,9 +744,10 @@ plperl_validator(PG_FUNCTION_ARGS)
}
-/* Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
- * supplied in s, and returns a reference to the closure. */
-
+/*
+ * Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
+ * supplied in s, and returns a reference to the closure.
+ */
static SV *
plperl_create_sub(char *s, bool trusted)
{
@@ -761,8 +765,8 @@ plperl_create_sub(char *s, bool trusted)
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv("our $_TD; local $_TD=$_[0]; shift;", 0)));
- XPUSHs(sv_2mortal(newSVpv(s, 0)));
+ XPUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=$_[0]; shift;")));
+ XPUSHs(sv_2mortal(newSVstring(s)));
PUTBACK;
/*
@@ -900,11 +904,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
fcinfo->arg[i]);
- sv = newSVpv(tmp, 0);
-#if PERL_BCDVERSION >= 0x5006000L
- if (GetDatabaseEncoding() == PG_UTF8)
- SvUTF8_on(sv);
-#endif
+ sv = newSVstring(tmp);
XPUSHs(sv_2mortal(sv));
pfree(tmp);
}
@@ -965,7 +965,7 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger;
for (i = 0; i < tg_trigger->tgnargs; i++)
- XPUSHs(sv_2mortal(newSVpv(tg_trigger->tgargs[i], 0)));
+ XPUSHs(sv_2mortal(newSVstring(tg_trigger->tgargs[i])));
PUTBACK;
/* Do NOT use G_KEEPERR here */
@@ -1256,7 +1256,6 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
HeapTuple procTup;
Form_pg_proc procStruct;
char internal_proname[64];
- int proname_len;
plperl_proc_desc *prodesc = NULL;
int i;
SV **svp;
@@ -1277,12 +1276,10 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
else
sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
- proname_len = strlen(internal_proname);
-
/************************************************************
* Lookup the internal proc name in the hashtable
************************************************************/
- svp = hv_fetch(plperl_proc_hash, internal_proname, proname_len, FALSE);
+ svp = hv_fetch_string(plperl_proc_hash, internal_proname);
if (svp)
{
bool uptodate;
@@ -1484,8 +1481,8 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
internal_proname);
}
- hv_store(plperl_proc_hash, internal_proname, proname_len,
- newSVuv(PTR2UV(prodesc)), 0);
+ hv_store_string(plperl_proc_hash, internal_proname,
+ newSVuv(PTR2UV(prodesc)));
}
ReleaseSysCache(procTup);
@@ -1512,36 +1509,27 @@ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
char *outputstr;
Oid typoutput;
bool typisvarlena;
- int namelen;
- SV *sv;
if (tupdesc->attrs[i]->attisdropped)
continue;
attname = NameStr(tupdesc->attrs[i]->attname);
- namelen = strlen(attname);
attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
if (isnull)
{
/* Store (attname => undef) and move on. */
- hv_store(hv, attname, namelen, newSV(0), 0);
+ hv_store_string(hv, attname, newSV(0));
continue;
}
/* XXX should have a way to cache these lookups */
-
getTypeOutputInfo(tupdesc->attrs[i]->atttypid,
&typoutput, &typisvarlena);
outputstr = OidOutputFunctionCall(typoutput, attr);
- sv = newSVpv(outputstr, 0);
-#if PERL_BCDVERSION >= 0x5006000L
- if (GetDatabaseEncoding() == PG_UTF8)
- SvUTF8_on(sv);
-#endif
- hv_store(hv, attname, namelen, sv, 0);
+ hv_store_string(hv, attname, newSVstring(outputstr));
pfree(outputstr);
}
@@ -1627,10 +1615,10 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
result = newHV();
- hv_store(result, "status", strlen("status"),
- newSVpv((char *) SPI_result_code_string(status), 0), 0);
- hv_store(result, "processed", strlen("processed"),
- newSViv(processed), 0);
+ hv_store_string(result, "status",
+ newSVstring(SPI_result_code_string(status)));
+ hv_store_string(result, "processed",
+ newSViv(processed));
if (status > 0 && tuptable)
{
@@ -1644,8 +1632,8 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
av_push(rows, row);
}
- hv_store(result, "rows", strlen("rows"),
- newRV_noinc((SV *) rows), 0);
+ hv_store_string(result, "rows",
+ newRV_noinc((SV *) rows));
}
SPI_freetuptable(tuptable);
@@ -1811,7 +1799,7 @@ plperl_spi_query(char *query)
if (portal == NULL)
elog(ERROR, "SPI_cursor_open() failed:%s",
SPI_result_code_string(SPI_result));
- cursor = newSVpv(portal->name, 0);
+ cursor = newSVstring(portal->name);
/* Commit the inner transaction, return to outer xact context */
ReleaseCurrentSubTransaction();
@@ -2065,9 +2053,9 @@ plperl_spi_prepare(char *query, int argc, SV **argv)
* Insert a hashtable entry for the plan and return
* the key to the caller.
************************************************************/
- hv_store(plperl_query_hash, qdesc->qname, strlen(qdesc->qname), newSVuv(PTR2UV(qdesc)), 0);
+ hv_store_string(plperl_query_hash, qdesc->qname, newSVuv(PTR2UV(qdesc)));
- return newSVpv(qdesc->qname, strlen(qdesc->qname));
+ return newSVstring(qdesc->qname);
}
HV *
@@ -2098,7 +2086,7 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
/************************************************************
* Fetch the saved plan descriptor, see if it's o.k.
************************************************************/
- sv = hv_fetch(plperl_query_hash, query, strlen(query), 0);
+ sv = hv_fetch_string(plperl_query_hash, query);
if (sv == NULL)
elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
if (*sv == NULL || !SvOK(*sv))
@@ -2118,7 +2106,7 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
limit = 0;
if (attr != NULL)
{
- sv = hv_fetch(attr, "limit", 5, 0);
+ sv = hv_fetch_string(attr, "limit");
if (*sv && SvIOK(*sv))
limit = SvIV(*sv);
}
@@ -2239,7 +2227,7 @@ plperl_spi_query_prepared(char *query, int argc, SV **argv)
/************************************************************
* Fetch the saved plan descriptor, see if it's o.k.
************************************************************/
- sv = hv_fetch(plperl_query_hash, query, strlen(query), 0);
+ sv = hv_fetch_string(plperl_query_hash, query);
if (sv == NULL)
elog(ERROR, "spi_query_prepared: Invalid prepared query passed");
if (*sv == NULL || !SvOK(*sv))
@@ -2301,7 +2289,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 = newSVpv(portal->name, 0);
+ cursor = newSVstring(portal->name);
/* Commit the inner transaction, return to outer xact context */
ReleaseCurrentSubTransaction();
@@ -2353,7 +2341,7 @@ plperl_spi_freeplan(char *query)
void *plan;
plperl_query_desc *qdesc;
- sv = hv_fetch(plperl_query_hash, query, strlen(query), 0);
+ sv = hv_fetch_string(plperl_query_hash, query);
if (sv == NULL)
elog(ERROR, "spi_exec_freeplan: Invalid prepared query passed");
if (*sv == NULL || !SvOK(*sv))
@@ -2376,3 +2364,59 @@ 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.
+ */
+static SV **
+hv_store_string(HV *hv, const char *key, SV *val)
+{
+ int32 klen = strlen(key);
+
+ /*
+ * This seems nowhere documented, but under Perl 5.8.0 and up,
+ * hv_store() recognizes a negative klen parameter as meaning
+ * a UTF-8 encoded key. It 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);
+}
+
+/*
+ * Fetch an SV from a hash table under a key that is a string assumed to be
+ * in the current database's encoding.
+ */
+static SV **
+hv_fetch_string(HV *hv, const char *key)
+{
+ int32 klen = strlen(key);
+
+ /* See notes in hv_store_string */
+#if PERL_BCDVERSION >= 0x5008000L
+ if (GetDatabaseEncoding() == PG_UTF8)
+ klen = -klen;
+#endif
+ return hv_fetch(hv, key, klen, 0);
+}
--
GitLab