4

(2 rows)

---

--- Some OUT and OUT array tests

---

CREATE OR REPLACE FUNCTION test_out_params(OUT a varchar, OUT b varchar) AS $$

return { a=> 'ahoj', b=>'svete'};

$$ LANGUAGE plperl;

SELECT '01' AS i, * FROM test_out_params();

i | a | b

----+------+-------

01 | ahoj | svete

(1 row)

CREATE OR REPLACE FUNCTION test_out_params_array(OUT a varchar[], OUT b varchar[]) AS $$

return { a=> ['ahoj'], b=>['svete']};

$$ LANGUAGE plperl;

SELECT '02' AS i, * FROM test_out_params_array();

ERROR: array value must start with "{" or dimension information

CREATE OR REPLACE FUNCTION test_out_params_set(OUT a varchar, out b varchar) RETURNS SETOF RECORD AS $$

return_next { a=> 'ahoj', b=>'svete'};

return_next { a=> 'ahoj', b=>'svete'};

return_next { a=> 'ahoj', b=>'svete'};

$$ LANGUAGE plperl;

SELECT '03' AS I,* FROM test_out_params_set();

i | a | b

----+------+-------

03 | ahoj | svete

03 | ahoj | svete

03 | ahoj | svete

(3 rows)

CREATE OR REPLACE FUNCTION test_out_params_set_array(OUT a varchar[], out b varchar[]) RETURNS SETOF RECORD AS $$

return_next { a=> ['ahoj'], b=>['velky','svete']};

return_next { a=> ['ahoj'], b=>['velky','svete']};

return_next { a=> ['ahoj'], b=>['velky','svete']};

$$ LANGUAGE plperl;

SELECT '04' AS I,* FROM test_out_params_set_array();

ERROR: error from Perl function: array value must start with "{" or dimension information at line 2.

DROP FUNCTION test_out_params();

DROP FUNCTION test_out_params_set();

DROP FUNCTION test_out_params_array();

DROP FUNCTION test_out_params_set_array();

-- one out argument can be returned as scalar or hash

CREATE OR REPLACE FUNCTION test01(OUT a varchar) AS $$

return 'ahoj';

$$ LANGUAGE plperl ;

SELECT '01' AS i,* FROM test01();

i | a

----+------

01 | ahoj

(1 row)

CREATE OR REPLACE FUNCTION test02(OUT a varchar[]) AS $$

return {a=>['ahoj']};

$$ LANGUAGE plperl;

SELECT '02' AS i,a[1] FROM test02();

ERROR: array value must start with "{" or dimension information

CREATE OR REPLACE FUNCTION test03(OUT a varchar[]) RETURNS SETOF varchar[] AS $$

return_next { a=> ['ahoj']};

return_next { a=> ['ahoj']};

return_next { a=> ['ahoj']};

$$ LANGUAGE plperl;

SELECT '03' AS i,* FROM test03();

ERROR: error from Perl function: array value must start with "{" or dimension information at line 2.

CREATE OR REPLACE FUNCTION test04() RETURNS SETOF VARCHAR[] AS $$

return_next ['ahoj'];

return_next ['ahoj'];

$$ LANGUAGE plperl;

SELECT '04' AS i,* FROM test04();

ERROR: error from Perl function: array value must start with "{" or dimension information at line 2.

CREATE OR REPLACE FUNCTION test05(OUT a varchar) AS $$

return {a=>'ahoj'};

$$ LANGUAGE plperl;

SELECT '05' AS i,a FROM test05();

i | a

----+-----------------

05 | HASH(0x8558f9c)

(1 row)

CREATE OR REPLACE FUNCTION test06(OUT a varchar) RETURNS SETOF varchar AS $$

return_next { a=> 'ahoj'};

return_next { a=> 'ahoj'};

return_next { a=> 'ahoj'};

$$ LANGUAGE plperl;

SELECT '06' AS i,* FROM test06();

i | a

----+-----------------

06 | HASH(0x8559230)

06 | HASH(0x8559230)

06 | HASH(0x8559230)

(3 rows)

CREATE OR REPLACE FUNCTION test07() RETURNS SETOF VARCHAR AS $$

return_next 'ahoj';

return_next 'ahoj';

$$ LANGUAGE plperl;

SELECT '07' AS i,* FROM test07();

i | test07

----+--------

07 | ahoj

07 | ahoj

(2 rows)

DROP FUNCTION test01();

DROP FUNCTION test02();

DROP FUNCTION test03();

DROP FUNCTION test04();

DROP FUNCTION test05();

DROP FUNCTION test06();

DROP FUNCTION test07();

FmgrInforesult_in_func;/* I/O function and arg for result type */

Oidresult_typioparam;

intnargs;

intnum_out_args;/* number of out arguments */

FmgrInfoarg_out_func[FUNC_MAX_ARGS];

boolarg_is_rowtype[FUNC_MAX_ARGS];

SV*reference;

staticvoidplperl_init_shared_libs(pTHX);

staticHV*plperl_spi_execute_fetch_result(SPITupleTable*,int,int);

staticSV*plperl_convert_to_pg_array(SV*src);

staticSV*plperl_transform_result(plperl_proc_desc*prodesc,SV*result);

(errcode(ERRCODE_UNDEFINED_COLUMN),

errmsg("Perl hash contains nonexistent column \"%s\"",

key)));

if (SvTYPE(val)==SVt_RV&&

SvTYPE(SvRV(val))==SVt_PVAV)

values[attn-1]=SvPV(plperl_convert_to_pg_array(val),PL_na);

elseif (SvOK(val)&&SvTYPE(val)!=SVt_NULL)

if (SvOK(val)&&SvTYPE(val)!=SVt_NULL)

values[attn-1]=SvPV(val,PL_na);

}

hv_iterinit(perlhash);

HeapTupletuple;

Form_pg_procproc;

charfunctyptype;

intnumargs;

Oid*argtypes;

char**argnames;

char*argmodes;

boolistrigger= false;

inti;

tuple=SearchSysCache(PROCOID,

format_type_be(proc->prorettype))));

}

numargs=get_func_arg_info(tuple,

&argtypes,&argnames,&argmodes);

for (i=0;i<numargs;i++)

{

if (get_typtype(argtypes[i])=='p')

ereport(ERROR,

(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),

errmsg("plperl functions cannot take type %s",

format_type_be(argtypes[i]))));

}

ReleaseSysCache(tuple);

char*val;

perlret=plperl_transform_result(prodesc,perlret);

if (prodesc->fn_retisarray&&SvROK(perlret)&&

SvTYPE(SvRV(perlret))==SVt_PVAV)

{

charinternal_proname[64];

intproname_len;

plperl_proc_desc*prodesc=NULL;

inti;

SV**svp;

Datumprosrcdatum;

boolisnull;

char*proc_source;

inti;

intnumargs;

Oid*argtypes;

char**argnames;

char*argmodes;

(procStruct->provolatile!=PROVOLATILE_VOLATILE);

numargs=get_func_arg_info(procTup,

&argtypes,&argnames,&argmodes);

for (i=0;i<numargs;i++)

{

if (get_typtype(argtypes[i])=='p')

ereport(ERROR,

(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),

errmsg("plperl functions cannot take type %s",

format_type_be(argtypes[i]))));

if (argmodes&&argmodes[i]==PROARGMODE_OUT)

prodesc->num_out_args++;

}

fcinfo=current_call_data->fcinfo;

rsi= (ReturnSetInfo*)fcinfo->resultinfo;

sv=plperl_transform_result(prodesc,sv);

if (!prodesc->fn_retisset)

ereport(ERROR,

(errcode(ERRCODE_SYNTAX_ERROR),

if (SvOK(sv)&&SvTYPE(sv)!=SVt_NULL)

{

char*val;

SV*array_ret;

if (SvROK(sv)&&SvTYPE(SvRV(sv))==SVt_PVAV )

{

array_ret=plperl_convert_to_pg_array(sv);

sv=array_ret;

}

val=SvPV(sv,PL_na);

char*val=SvPV(sv,PL_na);

ret=InputFunctionCall(&prodesc->result_in_func,val,

prodesc->result_typioparam,-1);

SPI_freeplan(plan);

}

plperl_transform_result(plperl_proc_desc*prodesc,SV*result)

{

boolexactly_one_field= false;

HV*hvr;

SV*val;

char*key;

I32klen;

if (prodesc->num_out_args==1&&SvOK(result)

&&SvTYPE(result)==SVt_RV&&SvTYPE(SvRV(result))==SVt_PVHV)

{

hvr= (HV*)SvRV(result);

hv_iterinit(hvr);

while ((val=hv_iternextsv(hvr,&key,&klen)))

{

if (exactly_one_field)

ereport(ERROR,

(errcode(ERRCODE_UNDEFINED_COLUMN),

errmsg("Perl hash contains nonexistent column \"%s\"",

key)));

exactly_one_field= true;

result=val;

}

if (!exactly_one_field)

ereport(ERROR,

(errcode(ERRCODE_UNDEFINED_COLUMN),

errmsg("Perl hash is empty")));

hv_iterinit(hvr);

}

returnresult;

}