open-dsi
/
postgres
mirror of https://github.com/postgres/postgres
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Adjust plperl to ensure that all strings and hash keys passed to Perl

Browse Source 
are marked as UTF8 when the database encoding is UTF8.  This should
avoid inconsistencies like that exhibited in bug #2683 from Vitali Stupin.
REL8_2_STABLE
Tom Lane 20 years ago
parent 87eed2e3e1
commit a3dff39c53
1 changed files with 114 additions and 70 deletions
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Show Stats Download Patch File Download Diff File
  1. 184
      src/pl/plperl/plperl.c

184
src/pl/plperl/plperl.c
Unescape View File

@ -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);
}

Write Preview
Loading…
Cancel
Save