diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile index a3c3495..5729459 100644 --- a/src/pl/plperl/GNUmakefile +++ b/src/pl/plperl/GNUmakefile @@ -39,7 +39,7 @@ OBJS = plperl.o spi_internal.o SPI.o SHLIB_LINK = $(perl_embed_ldflags) REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl -REGRESS = plperl plperl_trigger plperl_shared plperl_elog +REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_array # where to find psql for running the tests PSQLDIR = $(bindir) diff --git a/src/pl/plperl/expected/plperl_array.out b/src/pl/plperl/expected/plperl_array.out new file mode 100644 index 0000000..ee37a5f --- /dev/null +++ b/src/pl/plperl/expected/plperl_array.out @@ -0,0 +1,54 @@ +CREATE OR REPLACE FUNCTION input_array(INTEGER[]) RETURNS INTEGER AS $$ + my $arref = shift; + my $result = 0; + + foreach (@$arref) { + $result += $_; + } + return $result; +$$ LANGUAGE plperl; +select input_array('{1,2,NULL}'); + input_array +------------- + 3 +(1 row) + +select input_array('{}'); + input_array +------------- + 0 +(1 row) + +select input_array('{{1,2,3}, {4,5,6}}'); + input_array +------------- + 21 +(1 row) + +CREATE OR REPLACE FUNCTION plperl_concat(TEXT[]) RETURNS TEXT AS $$ + my $arref = shift; + my $result = ""; + + foreach (@$arref) { + $result .= $_; + } + return $result; +$$ LANGUAGE plperl; +select plperl_concat('{"hello"," ","world!"}'); + plperl_concat +--------------- + hello world! +(1 row) + +select plperl_concat('{"NULL","NULL","NULL''"}'); + plperl_concat +--------------- + NULLNULLNULL' +(1 row) + +select plperl_concat('{{NULL,NULL,NULL}}'); + plperl_concat +--------------- + +(1 row) + diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index 4ed4f59..832eb21 100644 --- a/src/pl/plperl/plperl.c +++ b/src/pl/plperl/plperl.c @@ -64,6 +64,7 @@ typedef struct plperl_proc_desc int nargs; FmgrInfo arg_out_func[FUNC_MAX_ARGS]; bool arg_is_rowtype[FUNC_MAX_ARGS]; + bool arg_is_array[FUNC_MAX_ARGS]; SV *reference; } plperl_proc_desc; @@ -162,6 +163,7 @@ static SV **hv_store_string(HV *hv, const char *key, SV *val); static SV **hv_fetch_string(HV *hv, const char *key); static SV *plperl_create_sub(char *proname, char *s, bool trusted); static SV *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo); +static SV *plperl_ref_from_pg_array(Datum arg); static void plperl_compile_callback(void *arg); static void plperl_exec_callback(void *arg); @@ -575,6 +577,7 @@ plperl_safe_init(void) desc.reference = func; desc.nargs = 1; desc.arg_is_rowtype[0] = false; + desc.arg_is_array[0] = false; fmgr_info(F_TEXTOUT, &(desc.arg_out_func[0])); fcinfo.arg[0] = CStringGetTextDatum("a"); @@ -1119,6 +1122,13 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) XPUSHs(sv_2mortal(hashref)); ReleaseTupleDesc(tupdesc); } + else if (desc->arg_is_array[i]) + { + SV *arrayref; + /* Get perl array reference from the postgresql array */ + arrayref = plperl_ref_from_pg_array(fcinfo->arg[i]); + XPUSHs(sv_2mortal(arrayref)); + } else { char *tmp; @@ -1709,6 +1719,12 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) perm_fmgr_info(typeStruct->typoutput, &(prodesc->arg_out_func[i])); } + + /* Set flag for array attributes */ + if (typeStruct->typlen == -1 && typeStruct->typelem) + prodesc->arg_is_array[i] = true; + else + prodesc->arg_is_array[i] = false; ReleaseSysCache(typeTup); } @@ -2736,3 +2752,81 @@ plperl_compile_callback(void *arg) if (procname) errcontext("compilation of PL/Perl function \"%s\"", procname); } + +/* + * Convert PostgreSQL array to a perl array reference. + * The code is heavily based on array_out. + */ +static SV * +plperl_ref_from_pg_array(Datum arg) +{ + ArrayType *ar = DatumGetArrayTypeP(arg); + Oid elementtype = ARR_ELEMTYPE(ar); + AV *result; + int16 typlen; + bool typbyval; + char typalign, + typdelim; + Oid typioparam; + Oid typoutputfunc; + FmgrInfo proc; + int i, + nitems, + ndims, + *dims, + *lb; + bits8 *bitmap; + int bitmask; + char *data; + + + /* get element type information, including output coversion function */ + get_type_io_data(elementtype, IOFunc_output, + &typlen, &typbyval, &typalign, + &typdelim, &typioparam, &typoutputfunc); + + perm_fmgr_info(typoutputfunc, &proc); + + ndims = ARR_NDIM(ar); + dims = ARR_DIMS(ar); + lb = ARR_LBOUND(ar); + nitems = ArrayGetNItems(ndims, dims); + + bitmap = ARR_NULLBITMAP(ar); + bitmask = 1; + data = ARR_DATA_PTR(ar); + + result = newAV(); + + for (i = 0; i < nitems; i++ ) + { + /* write undef on NULL elements*/ + if (bitmap && (*bitmap & bitmask) == 0) + av_push(result, newSV(0)); + else + { + Datum itemvalue; + char *val; + + itemvalue = fetch_att(data, typbyval, typlen); + val = OutputFunctionCall(&proc, itemvalue); + av_push(result, newSVstring(val)); + /* get to the next array element */ + data = att_addlength_pointer(data, typlen, data); + data = (char *) att_align_nominal(data, typalign); + } + + /* advance bitmap pointer if any */ + if (bitmap) + { + bitmask <<= 1; + if (bitmask == 0x100) + { + bitmap++; + bitmask = 1; + } + } + + } + return newRV_noinc((SV *) result); +} diff --git a/src/pl/plperl/sql/plperl_array.sql b/src/pl/plperl/sql/plperl_array.sql new file mode 100644 index 0000000..b84eed3 --- /dev/null +++ b/src/pl/plperl/sql/plperl_array.sql @@ -0,0 +1,27 @@ +CREATE OR REPLACE FUNCTION input_array(INTEGER[]) RETURNS INTEGER AS $$ + my $arref = shift; + my $result = 0; + + foreach (@$arref) { + $result += $_; + } + return $result; +$$ LANGUAGE plperl; + +select input_array('{1,2,NULL}'); +select input_array('{}'); +select input_array('{{1,2,3}, {4,5,6}}'); + +CREATE OR REPLACE FUNCTION plperl_concat(TEXT[]) RETURNS TEXT AS $$ + my $arref = shift; + my $result = ""; + + foreach (@$arref) { + $result .= $_; + } + return $result; +$$ LANGUAGE plperl; + +select plperl_concat('{"hello"," ","world!"}'); +select plperl_concat('{"NULL","NULL","NULL''"}'); +select plperl_concat('{{NULL,NULL,NULL}}');