3333 * ENHANCEMENTS, OR MODIFICATIONS.
3434 *
3535 * IDENTIFICATION
36- * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.64 2004/11/24 18:47:38 tgl Exp $
36+ * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.65 2004/11/29 20:11:05 tgl Exp $
3737 *
3838 **********************************************************************/
3939
@@ -200,7 +200,7 @@ plperl_init_interp(void)
200200
201201plperl_interp = perl_alloc ();
202202if (!plperl_interp )
203- elog (ERROR ,"could not allocateperl interpreter" );
203+ elog (ERROR ,"could not allocatePerl interpreter" );
204204
205205perl_construct (plperl_interp );
206206perl_parse (plperl_interp ,plperl_init_shared_libs ,3 ,embedding ,NULL );
@@ -233,8 +233,8 @@ plperl_safe_init(void)
233233"$PLContainer->permit_only(':default');"
234234"$PLContainer->share(qw[&elog &ERROR ]);"
235235"sub ::mksafefunc { return $PLContainer->reval(qq[sub { "
236- "elog(ERROR,'trustedperl functions disabled - "
237- "please upgradeperl Safe module toat least 2.09');}]); }"
236+ "elog(ERROR,'trustedPerl functions disabled - "
237+ "please upgradePerl Safe module toversion 2.09 or later ');}]); }"
238238 ;
239239
240240SV * res ;
@@ -291,7 +291,10 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
291291int attn = SPI_fnumber (td ,key );
292292
293293if (attn <=0 || td -> attrs [attn - 1 ]-> attisdropped )
294- elog (ERROR ,"plperl: invalid attribute \"%s\" in hash" ,key );
294+ ereport (ERROR ,
295+ (errcode (ERRCODE_UNDEFINED_COLUMN ),
296+ errmsg ("Perl hash contains nonexistent column \"%s\"" ,
297+ key )));
295298if (SvTYPE (val )!= SVt_NULL )
296299values [attn - 1 ]= SvPV (val ,PL_na );
297300}
@@ -408,8 +411,9 @@ get_function_tupdesc(Oid result_type, ReturnSetInfo *rsinfo)
408411if (!rsinfo || !IsA (rsinfo ,ReturnSetInfo )||
409412rsinfo -> expectedDesc == NULL )
410413ereport (ERROR ,
411- (errcode (ERRCODE_DATATYPE_MISMATCH ),
412- errmsg ("could not determine row description for function returning record" )));
414+ (errcode (ERRCODE_FEATURE_NOT_SUPPORTED ),
415+ errmsg ("function returning record called in context "
416+ "that cannot accept type record" )));
413417return rsinfo -> expectedDesc ;
414418}
415419else /* ordinary composite type */
@@ -439,9 +443,13 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
439443
440444svp = hv_fetch (hvTD ,"new" ,3 , FALSE);
441445if (!svp )
442- elog (ERROR ,"plperl: key \"new\" not found" );
446+ ereport (ERROR ,
447+ (errcode (ERRCODE_UNDEFINED_COLUMN ),
448+ errmsg ("$_TD->{new} does not exist" )));
443449if (SvTYPE (* svp )!= SVt_RV || SvTYPE (SvRV (* svp ))!= SVt_PVHV )
444- elog (ERROR ,"plperl: $_TD->{new} is not a hash reference" );
450+ ereport (ERROR ,
451+ (errcode (ERRCODE_DATATYPE_MISMATCH ),
452+ errmsg ("$_TD->{new} is not a hash reference" )));
445453hvNew = (HV * )SvRV (* svp );
446454
447455modattrs = palloc (tupdesc -> natts * sizeof (int ));
@@ -455,7 +463,10 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
455463int attn = SPI_fnumber (tupdesc ,key );
456464
457465if (attn <=0 || tupdesc -> attrs [attn - 1 ]-> attisdropped )
458- elog (ERROR ,"plperl: invalid attribute \"%s\" in hash" ,key );
466+ ereport (ERROR ,
467+ (errcode (ERRCODE_UNDEFINED_COLUMN ),
468+ errmsg ("Perl hash contains nonexistent column \"%s\"" ,
469+ key )));
459470if (SvTYPE (val )!= SVt_NULL )
460471{
461472Oid typinput ;
@@ -490,7 +501,7 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
490501pfree (modnulls );
491502
492503if (rtup == NULL )
493- elog (ERROR ,"plperl: SPI_modifytuple failed: %s" ,
504+ elog (ERROR ,"SPI_modifytuple failed: %s" ,
494505SPI_result_code_string (SPI_result ));
495506
496507return rtup ;
@@ -594,8 +605,10 @@ plperl_create_sub(char *s, bool trusted)
594605PUTBACK ;
595606FREETMPS ;
596607LEAVE ;
597- elog (ERROR ,"creation of function failed: %s" ,
598- strip_trailing_ws (SvPV (ERRSV ,PL_na )));
608+ ereport (ERROR ,
609+ (errcode (ERRCODE_SYNTAX_ERROR ),
610+ errmsg ("creation of Perl function failed: %s" ,
611+ strip_trailing_ws (SvPV (ERRSV ,PL_na )))));
599612}
600613
601614/*
@@ -722,8 +735,10 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
722735PUTBACK ;
723736FREETMPS ;
724737LEAVE ;
725- elog (ERROR ,"error from function: %s" ,
726- strip_trailing_ws (SvPV (ERRSV ,PL_na )));
738+ /* XXX need to find a way to assign an errcode here */
739+ ereport (ERROR ,
740+ (errmsg ("error from Perl function: %s" ,
741+ strip_trailing_ws (SvPV (ERRSV ,PL_na )))));
727742}
728743
729744retval = newSVsv (POPs );
@@ -780,8 +795,10 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
780795PUTBACK ;
781796FREETMPS ;
782797LEAVE ;
783- elog (ERROR ,"error from trigger function: %s" ,
784- strip_trailing_ws (SvPV (ERRSV ,PL_na )));
798+ /* XXX need to find a way to assign an errcode here */
799+ ereport (ERROR ,
800+ (errmsg ("error from Perl trigger function: %s" ,
801+ strip_trailing_ws (SvPV (ERRSV ,PL_na )))));
785802}
786803
787804retval = newSVsv (POPs );
@@ -857,7 +874,9 @@ plperl_func_handler(PG_FUNCTION_ARGS)
857874AttInMetadata * attinmeta ;
858875
859876if (SvTYPE (perlret )!= SVt_RV || SvTYPE (SvRV (perlret ))!= SVt_PVAV )
860- elog (ERROR ,"plperl: set-returning function must return reference to array" );
877+ ereport (ERROR ,
878+ (errcode (ERRCODE_DATATYPE_MISMATCH ),
879+ errmsg ("set-returning Perl function must return reference to array" )));
861880ret_av = (AV * )SvRV (perlret );
862881
863882if (SRF_IS_FIRSTCALL ())
@@ -893,7 +912,9 @@ plperl_func_handler(PG_FUNCTION_ARGS)
893912Assert (svp != NULL );
894913
895914if (SvTYPE (* svp )!= SVt_RV || SvTYPE (SvRV (* svp ))!= SVt_PVHV )
896- elog (ERROR ,"plperl: element of result array is not a reference to hash" );
915+ ereport (ERROR ,
916+ (errcode (ERRCODE_DATATYPE_MISMATCH ),
917+ errmsg ("elements of Perl result array must be reference to hash" )));
897918row_hv = (HV * )SvRV (* svp );
898919
899920tuple = plperl_build_tuple_result (row_hv ,attinmeta );
@@ -913,7 +934,9 @@ plperl_func_handler(PG_FUNCTION_ARGS)
913934FuncCallContext * funcctx ;
914935
915936if (SvTYPE (perlret )!= SVt_RV || SvTYPE (SvRV (perlret ))!= SVt_PVAV )
916- elog (ERROR ,"plperl: set-returning function must return reference to array" );
937+ ereport (ERROR ,
938+ (errcode (ERRCODE_DATATYPE_MISMATCH ),
939+ errmsg ("set-returning Perl function must return reference to array" )));
917940ret_av = (AV * )SvRV (perlret );
918941
919942if (SRF_IS_FIRSTCALL ())
@@ -966,7 +989,9 @@ plperl_func_handler(PG_FUNCTION_ARGS)
966989HeapTuple tup ;
967990
968991if (SvTYPE (perlret )!= SVt_RV || SvTYPE (SvRV (perlret ))!= SVt_PVHV )
969- elog (ERROR ,"plperl: composite-returning function must return a reference to hash" );
992+ ereport (ERROR ,
993+ (errcode (ERRCODE_DATATYPE_MISMATCH ),
994+ errmsg ("composite-returning Perl function must return reference to hash" )));
970995perlhash = (HV * )SvRV (perlret );
971996
972997/*
@@ -1036,7 +1061,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
10361061* because SPI_finish would free it).
10371062************************************************************/
10381063if (SPI_finish ()!= SPI_OK_FINISH )
1039- elog (ERROR ,"plperl: SPI_finish() failed" );
1064+ elog (ERROR ,"SPI_finish() failed" );
10401065
10411066if (!(perlret && SvOK (perlret )&& SvTYPE (perlret )!= SVt_NULL ))
10421067{
@@ -1073,13 +1098,17 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
10731098trigdata -> tg_newtuple );
10741099else
10751100{
1076- elog (WARNING ,"plperl: ignoring modified tuple in DELETE trigger" );
1101+ ereport (WARNING ,
1102+ (errcode (ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED ),
1103+ errmsg ("ignoring modified tuple in DELETE trigger" )));
10771104trv = NULL ;
10781105}
10791106}
10801107else
10811108{
1082- elog (ERROR ,"plperl: expected trigger result to be undef, \"SKIP\" or \"MODIFY\"" );
1109+ ereport (ERROR ,
1110+ (errcode (ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED ),
1111+ errmsg ("result of Perl trigger function must be undef, \"SKIP\" or \"MODIFY\"" )));
10831112trv = NULL ;
10841113}
10851114retval = PointerGetDatum (trv );
@@ -1318,7 +1347,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
13181347 ************************************************************/
13191348prodesc -> reference = plperl_create_sub (proc_source ,prodesc -> lanpltrusted );
13201349pfree (proc_source );
1321- if (!prodesc -> reference )
1350+ if (!prodesc -> reference )/* can this happen? */
13221351{
13231352free (prodesc -> proname );
13241353free (prodesc );