2000-01-20 06:08:58 +01:00
|
|
|
/**********************************************************************
|
|
|
|
* plperl.c - perl as a procedural language for PostgreSQL
|
|
|
|
*
|
|
|
|
* IDENTIFICATION
|
|
|
|
*
|
|
|
|
* This software is copyrighted by Mark Hollomon
|
2000-04-12 19:17:23 +02:00
|
|
|
* but is shameless cribbed from pltcl.c by Jan Weick.
|
2000-01-20 06:08:58 +01:00
|
|
|
*
|
|
|
|
* The author hereby grants permission to use, copy, modify,
|
|
|
|
* distribute, and license this software and its documentation
|
|
|
|
* for any purpose, provided that existing copyright notices are
|
|
|
|
* retained in all copies and that this notice is included
|
|
|
|
* verbatim in any distributions. No written agreement, license,
|
|
|
|
* or royalty fee is required for any of the authorized uses.
|
|
|
|
* Modifications to this software may be copyrighted by their
|
|
|
|
* author and need not follow the licensing terms described
|
|
|
|
* here, provided that the new terms are clearly indicated on
|
|
|
|
* the first page of each file where they apply.
|
|
|
|
*
|
|
|
|
* IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY
|
|
|
|
* PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR
|
|
|
|
* CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS
|
|
|
|
* SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN
|
|
|
|
* IF THE AUTHOR HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH
|
|
|
|
* DAMAGE.
|
|
|
|
*
|
|
|
|
* THE AUTHOR AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY
|
|
|
|
* WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
|
|
|
* WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
|
|
|
|
* PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON
|
|
|
|
* AN "AS IS" BASIS, AND THE AUTHOR AND DISTRIBUTORS HAVE NO
|
|
|
|
* OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES,
|
|
|
|
* ENHANCEMENTS, OR MODIFICATIONS.
|
|
|
|
*
|
2000-05-28 19:56:29 +02:00
|
|
|
* IDENTIFICATION
|
2004-10-15 19:08:26 +02:00
|
|
|
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.55 2004/10/15 17:08:26 momjian Exp $
|
2000-05-28 19:56:29 +02:00
|
|
|
*
|
2000-01-20 06:08:58 +01:00
|
|
|
**********************************************************************/
|
|
|
|
|
2001-10-20 00:43:49 +02:00
|
|
|
#include "postgres.h"
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/* system stuff */
|
|
|
|
#include <fcntl.h>
|
2004-07-31 02:45:57 +02:00
|
|
|
#include <unistd.h>
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/* postgreSQL stuff */
|
|
|
|
#include "access/heapam.h"
|
2001-10-20 00:43:49 +02:00
|
|
|
#include "catalog/pg_language.h"
|
2000-01-20 06:08:58 +01:00
|
|
|
#include "catalog/pg_proc.h"
|
|
|
|
#include "catalog/pg_type.h"
|
2004-07-01 22:50:22 +02:00
|
|
|
#include "funcapi.h" /* need for SRF support */
|
2004-04-01 23:28:47 +02:00
|
|
|
#include "commands/trigger.h"
|
|
|
|
#include "executor/spi.h"
|
|
|
|
#include "fmgr.h"
|
|
|
|
#include "tcop/tcopprot.h"
|
2004-09-13 22:10:13 +02:00
|
|
|
#include "utils/lsyscache.h"
|
2004-04-01 23:28:47 +02:00
|
|
|
#include "utils/syscache.h"
|
|
|
|
#include "utils/typcache.h"
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/* perl stuff */
|
2000-05-29 23:25:07 +02:00
|
|
|
#include "EXTERN.h"
|
|
|
|
#include "perl.h"
|
2002-01-24 22:40:44 +01:00
|
|
|
#include "XSUB.h"
|
2000-10-24 19:01:06 +02:00
|
|
|
#include "ppport.h"
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2002-01-24 22:40:44 +01:00
|
|
|
/* just in case these symbols aren't provided */
|
|
|
|
#ifndef pTHX_
|
|
|
|
#define pTHX_
|
|
|
|
#define pTHX void
|
|
|
|
#endif
|
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/**********************************************************************
|
|
|
|
* The information we cache about loaded procedures
|
|
|
|
**********************************************************************/
|
|
|
|
typedef struct plperl_proc_desc
|
|
|
|
{
|
|
|
|
char *proname;
|
2001-10-20 00:43:49 +02:00
|
|
|
TransactionId fn_xmin;
|
|
|
|
CommandId fn_cmin;
|
2004-09-13 22:10:13 +02:00
|
|
|
bool fn_readonly;
|
2001-10-20 00:43:49 +02:00
|
|
|
bool lanpltrusted;
|
2004-07-01 22:50:22 +02:00
|
|
|
bool fn_retistuple; /* true, if function returns tuple */
|
2004-08-29 07:07:03 +02:00
|
|
|
bool fn_retisset; /* true, if function returns set */
|
2004-07-01 22:50:22 +02:00
|
|
|
Oid ret_oid; /* Oid of returning type */
|
2000-01-20 06:08:58 +01:00
|
|
|
FmgrInfo result_in_func;
|
2004-06-06 02:41:28 +02:00
|
|
|
Oid result_typioparam;
|
2000-01-20 06:08:58 +01:00
|
|
|
int nargs;
|
|
|
|
FmgrInfo arg_out_func[FUNC_MAX_ARGS];
|
2004-06-06 02:41:28 +02:00
|
|
|
Oid arg_typioparam[FUNC_MAX_ARGS];
|
2004-04-01 23:28:47 +02:00
|
|
|
bool arg_is_rowtype[FUNC_MAX_ARGS];
|
2000-04-12 19:17:23 +02:00
|
|
|
SV *reference;
|
2004-08-30 04:54:42 +02:00
|
|
|
} plperl_proc_desc;
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
|
|
|
|
/**********************************************************************
|
|
|
|
* Global data
|
|
|
|
**********************************************************************/
|
|
|
|
static int plperl_firstcall = 1;
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
static bool plperl_safe_init_done = false;
|
Well, after persuading cvsup and cvs that it _is_ possible to have local
modifiable repositories, I have a clean untrusted plperl patch to offer
you :)
Highlights:
* There's one perl interpreter used for both trusted and untrusted
procedures. I do think its unnecessary to keep two perl
interpreters around. If someone can break out from trusted "Safe" perl
mode, well, they can do what they want already. If someone disagrees, I
can change this.
* Opcode is not statically loaded anymore. Instead, we load Dynaloader,
which then can grab Opcode (and anything else you can 'use') on its own.
* Checked to work on FreeBSD 4.3 + perl 5.5.3 , OpenBSD 2.8 + perl5.6.1,
RedHat 6.2 + perl 5.5.3
* Uses ExtUtils::Embed to find what options are necessary to link with
perl shared libraries
* createlang is also updated, it can create untrusted perl using 'plperlu'
* Example script (assuming you have Mail::Sendmail installed):
create function foo() returns text as '
use Mail::Sendmail;
%mail = ( To => q(you@yourname.com),
From => q(me@here.com),
Message => "This is a very short message"
);
sendmail(%mail) or die $Mail::Sendmail::error;
return "OK. Log says:\n", $Mail::Sendmail::log;
' language 'plperlu';
Alex Pilosov
2001-06-18 23:40:06 +02:00
|
|
|
static PerlInterpreter *plperl_interp = NULL;
|
2000-04-12 19:17:23 +02:00
|
|
|
static HV *plperl_proc_hash = NULL;
|
2004-08-29 07:07:03 +02:00
|
|
|
static AV *g_column_keys = NULL;
|
|
|
|
static SV *srf_perlret = NULL; /* keep returned value */
|
|
|
|
static int g_attr_num = 0;
|
2000-04-12 19:17:23 +02:00
|
|
|
|
2004-09-13 22:10:13 +02:00
|
|
|
/* this is saved and restored by plperl_call_handler */
|
|
|
|
static plperl_proc_desc *plperl_current_prodesc = NULL;
|
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
/**********************************************************************
|
|
|
|
* Forward declarations
|
|
|
|
**********************************************************************/
|
|
|
|
static void plperl_init_all(void);
|
Well, after persuading cvsup and cvs that it _is_ possible to have local
modifiable repositories, I have a clean untrusted plperl patch to offer
you :)
Highlights:
* There's one perl interpreter used for both trusted and untrusted
procedures. I do think its unnecessary to keep two perl
interpreters around. If someone can break out from trusted "Safe" perl
mode, well, they can do what they want already. If someone disagrees, I
can change this.
* Opcode is not statically loaded anymore. Instead, we load Dynaloader,
which then can grab Opcode (and anything else you can 'use') on its own.
* Checked to work on FreeBSD 4.3 + perl 5.5.3 , OpenBSD 2.8 + perl5.6.1,
RedHat 6.2 + perl 5.5.3
* Uses ExtUtils::Embed to find what options are necessary to link with
perl shared libraries
* createlang is also updated, it can create untrusted perl using 'plperlu'
* Example script (assuming you have Mail::Sendmail installed):
create function foo() returns text as '
use Mail::Sendmail;
%mail = ( To => q(you@yourname.com),
From => q(me@here.com),
Message => "This is a very short message"
);
sendmail(%mail) or die $Mail::Sendmail::error;
return "OK. Log says:\n", $Mail::Sendmail::log;
' language 'plperlu';
Alex Pilosov
2001-06-18 23:40:06 +02:00
|
|
|
static void plperl_init_interp(void);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2001-03-22 05:01:46 +01:00
|
|
|
Datum plperl_call_handler(PG_FUNCTION_ARGS);
|
2003-07-31 20:36:46 +02:00
|
|
|
void plperl_init(void);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2000-05-28 19:56:29 +02:00
|
|
|
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2004-07-01 22:50:22 +02:00
|
|
|
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
|
2001-10-20 00:43:49 +02:00
|
|
|
static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
|
|
|
|
|
2000-04-12 19:17:23 +02:00
|
|
|
static SV *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
|
2002-01-24 22:40:44 +01:00
|
|
|
static void plperl_init_shared_libs(pTHX);
|
2004-09-13 22:10:13 +02:00
|
|
|
static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
|
2001-06-01 20:17:44 +02:00
|
|
|
/*
|
|
|
|
* This routine is a crock, and so is everyplace that calls it. The problem
|
|
|
|
* is that the cached form of plperl functions/queries is allocated permanently
|
|
|
|
* (mostly via malloc()) and never released until backend exit. Subsidiary
|
|
|
|
* data structures such as fmgr info records therefore must live forever
|
|
|
|
* as well. A better implementation would store all this stuff in a per-
|
|
|
|
* function memory context that could be reclaimed at need. In the meantime,
|
2001-10-07 01:21:45 +02:00
|
|
|
* fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
|
|
|
|
* it might allocate, and whatever the eventual function might allocate using
|
|
|
|
* fn_mcxt, will live forever too.
|
2001-06-01 20:17:44 +02:00
|
|
|
*/
|
|
|
|
static void
|
|
|
|
perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
|
|
|
|
{
|
2001-10-07 01:21:45 +02:00
|
|
|
fmgr_info_cxt(functionId, finfo, TopMemoryContext);
|
2001-06-01 20:17:44 +02:00
|
|
|
}
|
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
/**********************************************************************
|
2003-07-31 20:36:46 +02:00
|
|
|
* plperl_init() - Initialize everything that can be
|
|
|
|
* safely initialized during postmaster
|
|
|
|
* startup.
|
|
|
|
*
|
|
|
|
* DO NOT make this static --- it has to be callable by preload
|
2000-01-20 06:08:58 +01:00
|
|
|
**********************************************************************/
|
2003-07-31 20:36:46 +02:00
|
|
|
void
|
|
|
|
plperl_init(void)
|
2000-01-20 06:08:58 +01:00
|
|
|
{
|
|
|
|
/************************************************************
|
|
|
|
* Do initialization only once
|
|
|
|
************************************************************/
|
|
|
|
if (!plperl_firstcall)
|
|
|
|
return;
|
|
|
|
|
2003-04-20 23:15:34 +02:00
|
|
|
/************************************************************
|
|
|
|
* Free the proc hash table
|
|
|
|
************************************************************/
|
|
|
|
if (plperl_proc_hash != NULL)
|
|
|
|
{
|
|
|
|
hv_undef(plperl_proc_hash);
|
|
|
|
SvREFCNT_dec((SV *) plperl_proc_hash);
|
|
|
|
plperl_proc_hash = NULL;
|
|
|
|
}
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/************************************************************
|
2001-10-20 00:43:49 +02:00
|
|
|
* Destroy the existing Perl interpreter
|
2000-01-20 06:08:58 +01:00
|
|
|
************************************************************/
|
Well, after persuading cvsup and cvs that it _is_ possible to have local
modifiable repositories, I have a clean untrusted plperl patch to offer
you :)
Highlights:
* There's one perl interpreter used for both trusted and untrusted
procedures. I do think its unnecessary to keep two perl
interpreters around. If someone can break out from trusted "Safe" perl
mode, well, they can do what they want already. If someone disagrees, I
can change this.
* Opcode is not statically loaded anymore. Instead, we load Dynaloader,
which then can grab Opcode (and anything else you can 'use') on its own.
* Checked to work on FreeBSD 4.3 + perl 5.5.3 , OpenBSD 2.8 + perl5.6.1,
RedHat 6.2 + perl 5.5.3
* Uses ExtUtils::Embed to find what options are necessary to link with
perl shared libraries
* createlang is also updated, it can create untrusted perl using 'plperlu'
* Example script (assuming you have Mail::Sendmail installed):
create function foo() returns text as '
use Mail::Sendmail;
%mail = ( To => q(you@yourname.com),
From => q(me@here.com),
Message => "This is a very short message"
);
sendmail(%mail) or die $Mail::Sendmail::error;
return "OK. Log says:\n", $Mail::Sendmail::log;
' language 'plperlu';
Alex Pilosov
2001-06-18 23:40:06 +02:00
|
|
|
if (plperl_interp != NULL)
|
2000-01-20 06:08:58 +01:00
|
|
|
{
|
Well, after persuading cvsup and cvs that it _is_ possible to have local
modifiable repositories, I have a clean untrusted plperl patch to offer
you :)
Highlights:
* There's one perl interpreter used for both trusted and untrusted
procedures. I do think its unnecessary to keep two perl
interpreters around. If someone can break out from trusted "Safe" perl
mode, well, they can do what they want already. If someone disagrees, I
can change this.
* Opcode is not statically loaded anymore. Instead, we load Dynaloader,
which then can grab Opcode (and anything else you can 'use') on its own.
* Checked to work on FreeBSD 4.3 + perl 5.5.3 , OpenBSD 2.8 + perl5.6.1,
RedHat 6.2 + perl 5.5.3
* Uses ExtUtils::Embed to find what options are necessary to link with
perl shared libraries
* createlang is also updated, it can create untrusted perl using 'plperlu'
* Example script (assuming you have Mail::Sendmail installed):
create function foo() returns text as '
use Mail::Sendmail;
%mail = ( To => q(you@yourname.com),
From => q(me@here.com),
Message => "This is a very short message"
);
sendmail(%mail) or die $Mail::Sendmail::error;
return "OK. Log says:\n", $Mail::Sendmail::log;
' language 'plperlu';
Alex Pilosov
2001-06-18 23:40:06 +02:00
|
|
|
perl_destruct(plperl_interp);
|
|
|
|
perl_free(plperl_interp);
|
|
|
|
plperl_interp = NULL;
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
/************************************************************
|
2001-10-20 00:43:49 +02:00
|
|
|
* Now recreate a new Perl interpreter
|
2000-01-20 06:08:58 +01:00
|
|
|
************************************************************/
|
Well, after persuading cvsup and cvs that it _is_ possible to have local
modifiable repositories, I have a clean untrusted plperl patch to offer
you :)
Highlights:
* There's one perl interpreter used for both trusted and untrusted
procedures. I do think its unnecessary to keep two perl
interpreters around. If someone can break out from trusted "Safe" perl
mode, well, they can do what they want already. If someone disagrees, I
can change this.
* Opcode is not statically loaded anymore. Instead, we load Dynaloader,
which then can grab Opcode (and anything else you can 'use') on its own.
* Checked to work on FreeBSD 4.3 + perl 5.5.3 , OpenBSD 2.8 + perl5.6.1,
RedHat 6.2 + perl 5.5.3
* Uses ExtUtils::Embed to find what options are necessary to link with
perl shared libraries
* createlang is also updated, it can create untrusted perl using 'plperlu'
* Example script (assuming you have Mail::Sendmail installed):
create function foo() returns text as '
use Mail::Sendmail;
%mail = ( To => q(you@yourname.com),
From => q(me@here.com),
Message => "This is a very short message"
);
sendmail(%mail) or die $Mail::Sendmail::error;
return "OK. Log says:\n", $Mail::Sendmail::log;
' language 'plperlu';
Alex Pilosov
2001-06-18 23:40:06 +02:00
|
|
|
plperl_init_interp();
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
plperl_firstcall = 0;
|
|
|
|
}
|
|
|
|
|
2003-07-31 20:36:46 +02:00
|
|
|
/**********************************************************************
|
|
|
|
* plperl_init_all() - Initialize all
|
|
|
|
**********************************************************************/
|
|
|
|
static void
|
|
|
|
plperl_init_all(void)
|
|
|
|
{
|
|
|
|
|
|
|
|
/************************************************************
|
|
|
|
* Execute postmaster-startup safe initialization
|
|
|
|
************************************************************/
|
|
|
|
if (plperl_firstcall)
|
|
|
|
plperl_init();
|
|
|
|
|
|
|
|
/************************************************************
|
|
|
|
* Any other initialization that must be done each time a new
|
|
|
|
* backend starts -- currently none
|
|
|
|
************************************************************/
|
|
|
|
|
|
|
|
}
|
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/**********************************************************************
|
2001-10-20 00:43:49 +02:00
|
|
|
* plperl_init_interp() - Create the Perl interpreter
|
2000-01-20 06:08:58 +01:00
|
|
|
**********************************************************************/
|
|
|
|
static void
|
Well, after persuading cvsup and cvs that it _is_ possible to have local
modifiable repositories, I have a clean untrusted plperl patch to offer
you :)
Highlights:
* There's one perl interpreter used for both trusted and untrusted
procedures. I do think its unnecessary to keep two perl
interpreters around. If someone can break out from trusted "Safe" perl
mode, well, they can do what they want already. If someone disagrees, I
can change this.
* Opcode is not statically loaded anymore. Instead, we load Dynaloader,
which then can grab Opcode (and anything else you can 'use') on its own.
* Checked to work on FreeBSD 4.3 + perl 5.5.3 , OpenBSD 2.8 + perl5.6.1,
RedHat 6.2 + perl 5.5.3
* Uses ExtUtils::Embed to find what options are necessary to link with
perl shared libraries
* createlang is also updated, it can create untrusted perl using 'plperlu'
* Example script (assuming you have Mail::Sendmail installed):
create function foo() returns text as '
use Mail::Sendmail;
%mail = ( To => q(you@yourname.com),
From => q(me@here.com),
Message => "This is a very short message"
);
sendmail(%mail) or die $Mail::Sendmail::error;
return "OK. Log says:\n", $Mail::Sendmail::log;
' language 'plperlu';
Alex Pilosov
2001-06-18 23:40:06 +02:00
|
|
|
plperl_init_interp(void)
|
2000-01-20 06:08:58 +01:00
|
|
|
{
|
|
|
|
|
2000-04-18 17:04:02 +02:00
|
|
|
char *embedding[3] = {
|
2001-03-22 05:01:46 +01:00
|
|
|
"", "-e",
|
|
|
|
|
|
|
|
/*
|
2004-08-29 07:07:03 +02:00
|
|
|
* no commas between the next lines please. They are supposed to
|
|
|
|
* be one string
|
2000-04-18 17:04:02 +02:00
|
|
|
*/
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
"SPI::bootstrap(); use vars qw(%_SHARED);"
|
2004-07-01 22:50:22 +02:00
|
|
|
"sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
|
2001-03-22 05:01:46 +01:00
|
|
|
};
|
2000-01-20 06:08:58 +01:00
|
|
|
|
Well, after persuading cvsup and cvs that it _is_ possible to have local
modifiable repositories, I have a clean untrusted plperl patch to offer
you :)
Highlights:
* There's one perl interpreter used for both trusted and untrusted
procedures. I do think its unnecessary to keep two perl
interpreters around. If someone can break out from trusted "Safe" perl
mode, well, they can do what they want already. If someone disagrees, I
can change this.
* Opcode is not statically loaded anymore. Instead, we load Dynaloader,
which then can grab Opcode (and anything else you can 'use') on its own.
* Checked to work on FreeBSD 4.3 + perl 5.5.3 , OpenBSD 2.8 + perl5.6.1,
RedHat 6.2 + perl 5.5.3
* Uses ExtUtils::Embed to find what options are necessary to link with
perl shared libraries
* createlang is also updated, it can create untrusted perl using 'plperlu'
* Example script (assuming you have Mail::Sendmail installed):
create function foo() returns text as '
use Mail::Sendmail;
%mail = ( To => q(you@yourname.com),
From => q(me@here.com),
Message => "This is a very short message"
);
sendmail(%mail) or die $Mail::Sendmail::error;
return "OK. Log says:\n", $Mail::Sendmail::log;
' language 'plperlu';
Alex Pilosov
2001-06-18 23:40:06 +02:00
|
|
|
plperl_interp = perl_alloc();
|
|
|
|
if (!plperl_interp)
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "could not allocate perl interpreter");
|
2000-01-20 06:08:58 +01:00
|
|
|
|
Well, after persuading cvsup and cvs that it _is_ possible to have local
modifiable repositories, I have a clean untrusted plperl patch to offer
you :)
Highlights:
* There's one perl interpreter used for both trusted and untrusted
procedures. I do think its unnecessary to keep two perl
interpreters around. If someone can break out from trusted "Safe" perl
mode, well, they can do what they want already. If someone disagrees, I
can change this.
* Opcode is not statically loaded anymore. Instead, we load Dynaloader,
which then can grab Opcode (and anything else you can 'use') on its own.
* Checked to work on FreeBSD 4.3 + perl 5.5.3 , OpenBSD 2.8 + perl5.6.1,
RedHat 6.2 + perl 5.5.3
* Uses ExtUtils::Embed to find what options are necessary to link with
perl shared libraries
* createlang is also updated, it can create untrusted perl using 'plperlu'
* Example script (assuming you have Mail::Sendmail installed):
create function foo() returns text as '
use Mail::Sendmail;
%mail = ( To => q(you@yourname.com),
From => q(me@here.com),
Message => "This is a very short message"
);
sendmail(%mail) or die $Mail::Sendmail::error;
return "OK. Log says:\n", $Mail::Sendmail::log;
' language 'plperlu';
Alex Pilosov
2001-06-18 23:40:06 +02:00
|
|
|
perl_construct(plperl_interp);
|
|
|
|
perl_parse(plperl_interp, plperl_init_shared_libs, 3, embedding, NULL);
|
|
|
|
perl_run(plperl_interp);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/************************************************************
|
|
|
|
* Initialize the proc and query hash tables
|
2001-10-20 00:43:49 +02:00
|
|
|
************************************************************/
|
2000-04-12 19:17:23 +02:00
|
|
|
plperl_proc_hash = newHV();
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
}
|
|
|
|
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
|
|
|
|
static void
|
|
|
|
plperl_safe_init(void)
|
|
|
|
{
|
2004-08-29 07:07:03 +02:00
|
|
|
static char *safe_module =
|
|
|
|
"require Safe; $Safe::VERSION";
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
static char *safe_ok =
|
|
|
|
"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
|
|
|
|
"$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
|
|
|
|
"$PLContainer->share(qw[&elog &spi_exec_query &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
|
|
|
|
"sub ::mksafefunc { return $PLContainer->reval(qq[sub { $_[0] $_[1]}]); }"
|
|
|
|
;
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
static char *safe_bad =
|
|
|
|
"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
|
|
|
|
"$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
|
|
|
|
"$PLContainer->share(qw[&elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
|
|
|
|
"sub ::mksafefunc { return $PLContainer->reval(qq[sub { "
|
|
|
|
"elog(ERROR,'trusted perl functions disabled - please upgrade perl Safe module to at least 2.09');}]); }"
|
|
|
|
;
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
SV *res;
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
float safe_version;
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
res = eval_pv(safe_module, FALSE); /* TRUE = croak if failure */
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
|
|
|
|
safe_version = SvNV(res);
|
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
eval_pv((safe_version < 2.09 ? safe_bad : safe_ok), FALSE);
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
|
|
|
|
plperl_safe_init_done = true;
|
|
|
|
}
|
|
|
|
|
2004-07-01 22:50:22 +02:00
|
|
|
|
2004-10-15 19:08:26 +02:00
|
|
|
static HV *
|
|
|
|
plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
|
|
|
|
{
|
|
|
|
int i;
|
|
|
|
HV *hv = newHV();
|
2004-07-01 22:50:22 +02:00
|
|
|
for (i = 0; i < tupdesc->natts; i++)
|
|
|
|
{
|
2004-10-15 19:08:26 +02:00
|
|
|
SV *value;
|
|
|
|
|
|
|
|
char *key = SPI_fname(tupdesc, i+1);
|
|
|
|
char *val = SPI_getvalue(tuple, tupdesc, i + 1);
|
|
|
|
|
|
|
|
if (val)
|
|
|
|
value = newSVpv(val, 0);
|
2004-07-01 22:50:22 +02:00
|
|
|
else
|
2004-10-15 19:08:26 +02:00
|
|
|
value = newSV(0);
|
2004-07-01 22:50:22 +02:00
|
|
|
|
2004-10-15 19:08:26 +02:00
|
|
|
hv_store(hv, key, strlen(key), value, 0);
|
|
|
|
}
|
|
|
|
return hv;
|
2004-07-01 22:50:22 +02:00
|
|
|
}
|
|
|
|
|
2004-10-15 19:08:26 +02:00
|
|
|
|
2004-07-01 22:50:22 +02:00
|
|
|
/**********************************************************************
|
|
|
|
* set up arguments for a trigger call
|
|
|
|
**********************************************************************/
|
|
|
|
static SV *
|
|
|
|
plperl_trigger_build_args(FunctionCallInfo fcinfo)
|
|
|
|
{
|
|
|
|
TriggerData *tdata;
|
|
|
|
TupleDesc tupdesc;
|
|
|
|
int i = 0;
|
2004-10-15 19:08:26 +02:00
|
|
|
char *level;
|
|
|
|
char *event;
|
|
|
|
char *relid;
|
|
|
|
char *when;
|
|
|
|
HV *hv;
|
2004-07-01 22:50:22 +02:00
|
|
|
|
2004-10-15 19:08:26 +02:00
|
|
|
hv = newHV();
|
2004-07-01 22:50:22 +02:00
|
|
|
|
|
|
|
tdata = (TriggerData *) fcinfo->context;
|
|
|
|
tupdesc = tdata->tg_relation->rd_att;
|
|
|
|
|
2004-10-15 19:08:26 +02:00
|
|
|
relid = DatumGetCString(
|
|
|
|
DirectFunctionCall1(
|
|
|
|
oidout, ObjectIdGetDatum(tdata->tg_relation->rd_id)
|
|
|
|
)
|
|
|
|
);
|
|
|
|
|
|
|
|
hv_store(hv, "name", 4, newSVpv(tdata->tg_trigger->tgname, 0), 0);
|
|
|
|
hv_store(hv, "relid", 5, newSVpv(relid, 0), 0);
|
2004-07-01 22:50:22 +02:00
|
|
|
|
|
|
|
if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
|
|
|
|
{
|
2004-10-15 19:08:26 +02:00
|
|
|
event = "INSERT";
|
|
|
|
hv_store(hv, "new", 3,
|
|
|
|
newRV((SV *)plperl_hash_from_tuple(tdata->tg_trigtuple,
|
|
|
|
tupdesc)),
|
|
|
|
0);
|
2004-07-01 22:50:22 +02:00
|
|
|
}
|
|
|
|
else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
|
|
|
|
{
|
2004-10-15 19:08:26 +02:00
|
|
|
event = "DELETE";
|
|
|
|
hv_store(hv, "old", 3,
|
|
|
|
newRV((SV *)plperl_hash_from_tuple(tdata->tg_trigtuple,
|
|
|
|
tupdesc)),
|
|
|
|
0);
|
2004-07-01 22:50:22 +02:00
|
|
|
}
|
|
|
|
else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
|
|
|
|
{
|
2004-10-15 19:08:26 +02:00
|
|
|
event = "UPDATE";
|
|
|
|
hv_store(hv, "old", 3,
|
|
|
|
newRV((SV *)plperl_hash_from_tuple(tdata->tg_trigtuple,
|
|
|
|
tupdesc)),
|
|
|
|
0);
|
|
|
|
hv_store(hv, "new", 3,
|
|
|
|
newRV((SV *)plperl_hash_from_tuple(tdata->tg_newtuple,
|
|
|
|
tupdesc)),
|
|
|
|
0);
|
|
|
|
}
|
|
|
|
else {
|
|
|
|
event = "UNKNOWN";
|
2004-07-01 22:50:22 +02:00
|
|
|
}
|
|
|
|
|
2004-10-15 19:08:26 +02:00
|
|
|
hv_store(hv, "event", 5, newSVpv(event, 0), 0);
|
|
|
|
hv_store(hv, "argc", 4, newSViv(tdata->tg_trigger->tgnargs), 0);
|
2004-07-01 22:50:22 +02:00
|
|
|
|
|
|
|
if (tdata->tg_trigger->tgnargs != 0)
|
|
|
|
{
|
2004-10-15 19:08:26 +02:00
|
|
|
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((SV *)av), 0);
|
2004-07-01 22:50:22 +02:00
|
|
|
}
|
2004-10-15 19:08:26 +02:00
|
|
|
|
|
|
|
hv_store(hv, "relname", 7,
|
|
|
|
newSVpv(SPI_getrelname(tdata->tg_relation), 0), 0);
|
2004-07-01 22:50:22 +02:00
|
|
|
|
|
|
|
if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
|
2004-10-15 19:08:26 +02:00
|
|
|
when = "BEFORE";
|
2004-07-01 22:50:22 +02:00
|
|
|
else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
|
2004-10-15 19:08:26 +02:00
|
|
|
when = "AFTER";
|
2004-07-01 22:50:22 +02:00
|
|
|
else
|
2004-10-15 19:08:26 +02:00
|
|
|
when = "UNKNOWN";
|
|
|
|
hv_store(hv, "when", 4, newSVpv(when, 0), 0);
|
2004-07-01 22:50:22 +02:00
|
|
|
|
|
|
|
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
|
2004-10-15 19:08:26 +02:00
|
|
|
level = "ROW";
|
2004-07-01 22:50:22 +02:00
|
|
|
else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
|
2004-10-15 19:08:26 +02:00
|
|
|
level = "STATEMENT";
|
2004-07-01 22:50:22 +02:00
|
|
|
else
|
2004-10-15 19:08:26 +02:00
|
|
|
level = "UNKNOWN";
|
|
|
|
hv_store(hv, "level", 5, newSVpv(level, 0), 0);
|
2004-07-01 22:50:22 +02:00
|
|
|
|
2004-10-15 19:08:26 +02:00
|
|
|
return newRV((SV*)hv);
|
2004-07-01 22:50:22 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/**********************************************************************
|
|
|
|
* check return value from plperl function
|
|
|
|
**********************************************************************/
|
|
|
|
static int
|
2004-08-30 04:54:42 +02:00
|
|
|
plperl_is_set(SV *sv)
|
2004-07-01 22:50:22 +02:00
|
|
|
{
|
|
|
|
int i = 0;
|
|
|
|
int len = 0;
|
|
|
|
int set = 0;
|
|
|
|
int other = 0;
|
|
|
|
AV *input_av;
|
|
|
|
SV **val;
|
|
|
|
|
|
|
|
if (SvTYPE(sv) != SVt_RV)
|
|
|
|
return 0;
|
|
|
|
|
|
|
|
if (SvTYPE(SvRV(sv)) == SVt_PVHV)
|
|
|
|
return 0;
|
|
|
|
|
|
|
|
if (SvTYPE(SvRV(sv)) == SVt_PVAV)
|
|
|
|
{
|
|
|
|
input_av = (AV *) SvRV(sv);
|
|
|
|
len = av_len(input_av) + 1;
|
|
|
|
|
|
|
|
for (i = 0; i < len; i++)
|
|
|
|
{
|
|
|
|
val = av_fetch(input_av, i, FALSE);
|
|
|
|
if (SvTYPE(*val) == SVt_RV)
|
|
|
|
set = 1;
|
|
|
|
else
|
|
|
|
other = 1;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
if (len == 0)
|
|
|
|
return 1;
|
|
|
|
if (set && !other)
|
|
|
|
return 1;
|
|
|
|
if (!set && other)
|
|
|
|
return 0;
|
|
|
|
if (set && other)
|
|
|
|
elog(ERROR, "plperl: check your return value structure");
|
|
|
|
if (!set && !other)
|
|
|
|
elog(ERROR, "plperl: check your return value structure");
|
|
|
|
|
|
|
|
return 0; /* for compiler */
|
|
|
|
}
|
|
|
|
|
|
|
|
/**********************************************************************
|
|
|
|
* extract a list of keys from a hash
|
|
|
|
**********************************************************************/
|
2004-08-29 07:07:03 +02:00
|
|
|
static AV *
|
2004-08-30 04:54:42 +02:00
|
|
|
plperl_get_keys(HV *hv)
|
2004-07-01 22:50:22 +02:00
|
|
|
{
|
|
|
|
AV *ret;
|
|
|
|
SV *val;
|
|
|
|
char *key;
|
|
|
|
I32 klen;
|
|
|
|
|
|
|
|
ret = newAV();
|
|
|
|
|
|
|
|
hv_iterinit(hv);
|
2004-09-13 22:10:13 +02:00
|
|
|
while ((val = hv_iternextsv(hv, (char **) &key, &klen)))
|
2004-10-15 19:08:26 +02:00
|
|
|
av_push(ret, newSVpv(key, 0));
|
2004-07-01 22:50:22 +02:00
|
|
|
hv_iterinit(hv);
|
2004-10-15 19:08:26 +02:00
|
|
|
|
2004-07-01 22:50:22 +02:00
|
|
|
return ret;
|
|
|
|
}
|
|
|
|
|
|
|
|
/**********************************************************************
|
|
|
|
* extract a given key (by index) from a list of keys
|
|
|
|
**********************************************************************/
|
|
|
|
static char *
|
2004-08-30 04:54:42 +02:00
|
|
|
plperl_get_key(AV *keys, int index)
|
2004-07-01 22:50:22 +02:00
|
|
|
{
|
|
|
|
SV **svp;
|
|
|
|
int len;
|
|
|
|
|
|
|
|
len = av_len(keys) + 1;
|
|
|
|
if (index < len)
|
|
|
|
svp = av_fetch(keys, index, FALSE);
|
|
|
|
else
|
|
|
|
return NULL;
|
|
|
|
return SvPV(*svp, PL_na);
|
|
|
|
}
|
|
|
|
|
|
|
|
/**********************************************************************
|
|
|
|
* extract a value for a given key from a hash
|
|
|
|
*
|
|
|
|
* return NULL on error or if we got an undef
|
|
|
|
*
|
|
|
|
**********************************************************************/
|
|
|
|
static char *
|
2004-08-30 04:54:42 +02:00
|
|
|
plperl_get_elem(HV *hash, char *key)
|
2004-07-01 22:50:22 +02:00
|
|
|
{
|
2004-10-15 19:08:26 +02:00
|
|
|
SV **svp = hv_fetch(hash, key, strlen(key), FALSE);
|
|
|
|
if (!svp)
|
2004-07-01 22:50:22 +02:00
|
|
|
{
|
|
|
|
elog(ERROR, "plperl: key '%s' not found", key);
|
|
|
|
return NULL;
|
|
|
|
}
|
|
|
|
return SvTYPE(*svp) == SVt_NULL ? NULL : SvPV(*svp, PL_na);
|
|
|
|
}
|
|
|
|
|
|
|
|
/**********************************************************************
|
|
|
|
* set up the new tuple returned from a trigger
|
|
|
|
**********************************************************************/
|
|
|
|
static HeapTuple
|
2004-08-30 04:54:42 +02:00
|
|
|
plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup, Oid fn_oid)
|
2004-07-01 22:50:22 +02:00
|
|
|
{
|
|
|
|
SV **svp;
|
|
|
|
HV *hvNew;
|
|
|
|
AV *plkeys;
|
|
|
|
char *platt;
|
|
|
|
char *plval;
|
|
|
|
HeapTuple rtup;
|
|
|
|
int natts,
|
|
|
|
i,
|
|
|
|
attn,
|
|
|
|
atti;
|
|
|
|
int *volatile modattrs = NULL;
|
|
|
|
Datum *volatile modvalues = NULL;
|
|
|
|
char *volatile modnulls = NULL;
|
|
|
|
TupleDesc tupdesc;
|
|
|
|
HeapTuple typetup;
|
|
|
|
|
|
|
|
tupdesc = tdata->tg_relation->rd_att;
|
|
|
|
|
|
|
|
svp = hv_fetch(hvTD, "new", 3, FALSE);
|
|
|
|
hvNew = (HV *) SvRV(*svp);
|
|
|
|
|
|
|
|
if (SvTYPE(hvNew) != SVt_PVHV)
|
|
|
|
elog(ERROR, "plperl: $_TD->{new} is not a hash");
|
|
|
|
|
|
|
|
plkeys = plperl_get_keys(hvNew);
|
2004-08-29 07:07:03 +02:00
|
|
|
natts = av_len(plkeys) + 1;
|
|
|
|
if (natts != tupdesc->natts)
|
|
|
|
elog(ERROR, "plperl: $_TD->{new} has an incorrect number of keys.");
|
2004-07-01 22:50:22 +02:00
|
|
|
|
|
|
|
modattrs = palloc0(natts * sizeof(int));
|
|
|
|
modvalues = palloc0(natts * sizeof(Datum));
|
|
|
|
modnulls = palloc0(natts * sizeof(char));
|
|
|
|
|
|
|
|
for (i = 0; i < natts; i++)
|
|
|
|
{
|
|
|
|
FmgrInfo finfo;
|
|
|
|
Oid typinput;
|
|
|
|
Oid typelem;
|
|
|
|
|
|
|
|
platt = plperl_get_key(plkeys, i);
|
|
|
|
|
|
|
|
attn = modattrs[i] = SPI_fnumber(tupdesc, platt);
|
|
|
|
|
|
|
|
if (attn == SPI_ERROR_NOATTRIBUTE)
|
|
|
|
elog(ERROR, "plperl: invalid attribute `%s' in tuple.", platt);
|
|
|
|
atti = attn - 1;
|
|
|
|
|
|
|
|
plval = plperl_get_elem(hvNew, platt);
|
|
|
|
|
|
|
|
typetup = SearchSysCache(TYPEOID, ObjectIdGetDatum(tupdesc->attrs[atti]->atttypid), 0, 0, 0);
|
|
|
|
typinput = ((Form_pg_type) GETSTRUCT(typetup))->typinput;
|
|
|
|
typelem = ((Form_pg_type) GETSTRUCT(typetup))->typelem;
|
|
|
|
ReleaseSysCache(typetup);
|
|
|
|
fmgr_info(typinput, &finfo);
|
|
|
|
|
|
|
|
if (plval)
|
|
|
|
{
|
|
|
|
modvalues[i] = FunctionCall3(&finfo,
|
|
|
|
CStringGetDatum(plval),
|
|
|
|
ObjectIdGetDatum(typelem),
|
2004-08-29 07:07:03 +02:00
|
|
|
Int32GetDatum(tupdesc->attrs[atti]->atttypmod));
|
2004-07-01 22:50:22 +02:00
|
|
|
modnulls[i] = ' ';
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
modvalues[i] = (Datum) 0;
|
|
|
|
modnulls[i] = 'n';
|
|
|
|
}
|
|
|
|
}
|
|
|
|
rtup = SPI_modifytuple(tdata->tg_relation, otup, natts, modattrs, modvalues, modnulls);
|
|
|
|
|
|
|
|
pfree(modattrs);
|
|
|
|
pfree(modvalues);
|
|
|
|
pfree(modnulls);
|
|
|
|
if (rtup == NULL)
|
|
|
|
elog(ERROR, "plperl: SPI_modifytuple failed -- error: %d", SPI_result);
|
|
|
|
|
|
|
|
return rtup;
|
|
|
|
}
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/**********************************************************************
|
|
|
|
* plperl_call_handler - This is the only visible function
|
|
|
|
* of the PL interpreter. The PostgreSQL
|
|
|
|
* function manager and trigger manager
|
|
|
|
* call this function for execution of
|
|
|
|
* perl procedures.
|
|
|
|
**********************************************************************/
|
2000-11-20 21:36:57 +01:00
|
|
|
PG_FUNCTION_INFO_V1(plperl_call_handler);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/* keep non-static */
|
|
|
|
Datum
|
2000-05-28 19:56:29 +02:00
|
|
|
plperl_call_handler(PG_FUNCTION_ARGS)
|
2000-01-20 06:08:58 +01:00
|
|
|
{
|
|
|
|
Datum retval;
|
2004-09-13 22:10:13 +02:00
|
|
|
plperl_proc_desc *save_prodesc;
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2004-09-13 22:10:13 +02:00
|
|
|
/*
|
|
|
|
* Initialize interpreter if first time through
|
|
|
|
*/
|
2003-07-31 20:36:46 +02:00
|
|
|
plperl_init_all();
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2004-09-13 22:10:13 +02:00
|
|
|
/*
|
|
|
|
* Ensure that static pointers are saved/restored properly
|
|
|
|
*/
|
|
|
|
save_prodesc = plperl_current_prodesc;
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2004-09-13 22:10:13 +02:00
|
|
|
PG_TRY();
|
|
|
|
{
|
|
|
|
/************************************************************
|
|
|
|
* Connect to SPI manager
|
|
|
|
************************************************************/
|
|
|
|
if (SPI_connect() != SPI_OK_CONNECT)
|
|
|
|
elog(ERROR, "could not connect to SPI manager");
|
|
|
|
|
|
|
|
/************************************************************
|
|
|
|
* Determine if called as function or trigger and
|
|
|
|
* call appropriate subhandler
|
|
|
|
************************************************************/
|
|
|
|
if (CALLED_AS_TRIGGER(fcinfo))
|
|
|
|
retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
|
|
|
|
else
|
|
|
|
retval = plperl_func_handler(fcinfo);
|
|
|
|
}
|
|
|
|
PG_CATCH();
|
|
|
|
{
|
|
|
|
plperl_current_prodesc = save_prodesc;
|
|
|
|
PG_RE_THROW();
|
|
|
|
}
|
|
|
|
PG_END_TRY();
|
|
|
|
|
|
|
|
plperl_current_prodesc = save_prodesc;
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
return retval;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/**********************************************************************
|
|
|
|
* plperl_create_sub() - calls the perl interpreter to
|
2000-04-12 19:17:23 +02:00
|
|
|
* create the anonymous subroutine whose text is in the SV.
|
|
|
|
* Returns the SV containing the RV to the closure.
|
2000-01-20 06:08:58 +01:00
|
|
|
**********************************************************************/
|
2003-08-04 02:43:34 +02:00
|
|
|
static SV *
|
Well, after persuading cvsup and cvs that it _is_ possible to have local
modifiable repositories, I have a clean untrusted plperl patch to offer
you :)
Highlights:
* There's one perl interpreter used for both trusted and untrusted
procedures. I do think its unnecessary to keep two perl
interpreters around. If someone can break out from trusted "Safe" perl
mode, well, they can do what they want already. If someone disagrees, I
can change this.
* Opcode is not statically loaded anymore. Instead, we load Dynaloader,
which then can grab Opcode (and anything else you can 'use') on its own.
* Checked to work on FreeBSD 4.3 + perl 5.5.3 , OpenBSD 2.8 + perl5.6.1,
RedHat 6.2 + perl 5.5.3
* Uses ExtUtils::Embed to find what options are necessary to link with
perl shared libraries
* createlang is also updated, it can create untrusted perl using 'plperlu'
* Example script (assuming you have Mail::Sendmail installed):
create function foo() returns text as '
use Mail::Sendmail;
%mail = ( To => q(you@yourname.com),
From => q(me@here.com),
Message => "This is a very short message"
);
sendmail(%mail) or die $Mail::Sendmail::error;
return "OK. Log says:\n", $Mail::Sendmail::log;
' language 'plperlu';
Alex Pilosov
2001-06-18 23:40:06 +02:00
|
|
|
plperl_create_sub(char *s, bool trusted)
|
2000-04-12 19:17:23 +02:00
|
|
|
{
|
2000-01-20 06:08:58 +01:00
|
|
|
dSP;
|
2003-04-20 23:15:34 +02:00
|
|
|
SV *subref;
|
2001-03-22 05:01:46 +01:00
|
|
|
int count;
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
if (trusted && !plperl_safe_init_done)
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
plperl_safe_init();
|
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
ENTER;
|
|
|
|
SAVETMPS;
|
|
|
|
PUSHMARK(SP);
|
2004-07-01 22:50:22 +02:00
|
|
|
XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
|
2001-03-22 05:01:46 +01:00
|
|
|
XPUSHs(sv_2mortal(newSVpv(s, 0)));
|
2000-04-18 17:04:02 +02:00
|
|
|
PUTBACK;
|
2003-08-04 02:43:34 +02:00
|
|
|
|
2003-04-20 23:15:34 +02:00
|
|
|
/*
|
|
|
|
* G_KEEPERR seems to be needed here, else we don't recognize compile
|
2003-08-04 02:43:34 +02:00
|
|
|
* errors properly. Perhaps it's because there's another level of
|
|
|
|
* eval inside mksafefunc?
|
2003-04-20 23:15:34 +02:00
|
|
|
*/
|
2001-10-25 07:50:21 +02:00
|
|
|
count = perl_call_pv((trusted ? "mksafefunc" : "mkunsafefunc"),
|
|
|
|
G_SCALAR | G_EVAL | G_KEEPERR);
|
2000-01-20 06:08:58 +01:00
|
|
|
SPAGAIN;
|
|
|
|
|
2003-04-20 23:15:34 +02:00
|
|
|
if (count != 1)
|
|
|
|
{
|
|
|
|
PUTBACK;
|
|
|
|
FREETMPS;
|
|
|
|
LEAVE;
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "didn't get a return item from mksafefunc");
|
2003-04-20 23:15:34 +02:00
|
|
|
}
|
|
|
|
|
2000-09-12 06:28:30 +02:00
|
|
|
if (SvTRUE(ERRSV))
|
2000-04-12 19:17:23 +02:00
|
|
|
{
|
2000-01-20 06:08:58 +01:00
|
|
|
POPs;
|
|
|
|
PUTBACK;
|
|
|
|
FREETMPS;
|
|
|
|
LEAVE;
|
2000-10-24 19:01:06 +02:00
|
|
|
elog(ERROR, "creation of function failed: %s", SvPV(ERRSV, PL_na));
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
/*
|
2000-04-12 19:17:23 +02:00
|
|
|
* need to make a deep copy of the return. it comes off the stack as a
|
|
|
|
* temporary.
|
2000-01-20 06:08:58 +01:00
|
|
|
*/
|
|
|
|
subref = newSVsv(POPs);
|
|
|
|
|
2000-04-12 19:17:23 +02:00
|
|
|
if (!SvROK(subref))
|
|
|
|
{
|
2000-01-20 06:08:58 +01:00
|
|
|
PUTBACK;
|
|
|
|
FREETMPS;
|
|
|
|
LEAVE;
|
2000-04-12 19:17:23 +02:00
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
/*
|
|
|
|
* subref is our responsibility because it is not mortal
|
|
|
|
*/
|
|
|
|
SvREFCNT_dec(subref);
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "didn't get a code ref");
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
PUTBACK;
|
|
|
|
FREETMPS;
|
|
|
|
LEAVE;
|
2003-04-20 23:15:34 +02:00
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
return subref;
|
|
|
|
}
|
|
|
|
|
|
|
|
/**********************************************************************
|
2000-04-12 19:17:23 +02:00
|
|
|
* plperl_init_shared_libs() -
|
2000-01-20 06:08:58 +01:00
|
|
|
*
|
|
|
|
* We cannot use the DynaLoader directly to get at the Opcode
|
|
|
|
* module (used by Safe.pm). So, we link Opcode into ourselves
|
|
|
|
* and do the initialization behind perl's back.
|
2000-04-12 19:17:23 +02:00
|
|
|
*
|
2000-01-20 06:08:58 +01:00
|
|
|
**********************************************************************/
|
|
|
|
|
2004-08-30 04:54:42 +02:00
|
|
|
EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
|
|
|
|
EXTERN_C void boot_SPI(pTHX_ CV *cv);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2000-02-19 19:58:37 +01:00
|
|
|
static void
|
2002-01-24 22:40:44 +01:00
|
|
|
plperl_init_shared_libs(pTHX)
|
2000-01-20 06:08:58 +01:00
|
|
|
{
|
2000-04-12 19:17:23 +02:00
|
|
|
char *file = __FILE__;
|
|
|
|
|
2001-10-25 07:50:21 +02:00
|
|
|
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
|
2000-01-29 02:58:50 +01:00
|
|
|
newXS("SPI::bootstrap", boot_SPI, file);
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
/**********************************************************************
|
|
|
|
* plperl_call_perl_func() - calls a perl function through the RV
|
|
|
|
* stored in the prodesc structure. massages the input parms properly
|
|
|
|
**********************************************************************/
|
2003-08-04 02:43:34 +02:00
|
|
|
static SV *
|
2004-08-30 04:54:42 +02:00
|
|
|
plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
|
2000-01-20 06:08:58 +01:00
|
|
|
{
|
|
|
|
dSP;
|
2000-04-12 19:17:23 +02:00
|
|
|
SV *retval;
|
|
|
|
int i;
|
|
|
|
int count;
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
ENTER;
|
|
|
|
SAVETMPS;
|
|
|
|
|
2003-04-20 23:15:34 +02:00
|
|
|
PUSHMARK(SP);
|
2004-07-01 22:50:22 +02:00
|
|
|
XPUSHs(sv_2mortal(newSVpv("undef", 0)));
|
2000-04-12 19:17:23 +02:00
|
|
|
for (i = 0; i < desc->nargs; i++)
|
|
|
|
{
|
2004-04-01 23:28:47 +02:00
|
|
|
if (desc->arg_is_rowtype[i])
|
2000-04-12 19:17:23 +02:00
|
|
|
{
|
2004-04-01 23:28:47 +02:00
|
|
|
if (fcinfo->argnull[i])
|
|
|
|
XPUSHs(&PL_sv_undef);
|
|
|
|
else
|
|
|
|
{
|
|
|
|
HeapTupleHeader td;
|
|
|
|
Oid tupType;
|
|
|
|
int32 tupTypmod;
|
|
|
|
TupleDesc tupdesc;
|
|
|
|
HeapTupleData tmptup;
|
|
|
|
SV *hashref;
|
|
|
|
|
|
|
|
td = DatumGetHeapTupleHeader(fcinfo->arg[i]);
|
|
|
|
/* Extract rowtype info and find a tupdesc */
|
|
|
|
tupType = HeapTupleHeaderGetTypeId(td);
|
|
|
|
tupTypmod = HeapTupleHeaderGetTypMod(td);
|
|
|
|
tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
|
|
|
|
/* Build a temporary HeapTuple control structure */
|
|
|
|
tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
|
|
|
|
tmptup.t_data = td;
|
|
|
|
|
|
|
|
/*
|
|
|
|
* plperl_build_tuple_argument better return a mortal SV.
|
|
|
|
*/
|
|
|
|
hashref = plperl_build_tuple_argument(&tmptup, tupdesc);
|
|
|
|
XPUSHs(hashref);
|
|
|
|
}
|
2000-04-12 19:17:23 +02:00
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
2000-05-28 19:56:29 +02:00
|
|
|
if (fcinfo->argnull[i])
|
|
|
|
XPUSHs(&PL_sv_undef);
|
|
|
|
else
|
|
|
|
{
|
|
|
|
char *tmp;
|
|
|
|
|
2000-05-30 06:25:00 +02:00
|
|
|
tmp = DatumGetCString(FunctionCall3(&(desc->arg_out_func[i]),
|
2001-03-22 05:01:46 +01:00
|
|
|
fcinfo->arg[i],
|
2004-08-29 07:07:03 +02:00
|
|
|
ObjectIdGetDatum(desc->arg_typioparam[i]),
|
2001-10-20 00:43:49 +02:00
|
|
|
Int32GetDatum(-1)));
|
2000-05-28 19:56:29 +02:00
|
|
|
XPUSHs(sv_2mortal(newSVpv(tmp, 0)));
|
|
|
|
pfree(tmp);
|
|
|
|
}
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
|
|
|
}
|
|
|
|
PUTBACK;
|
2003-04-20 23:15:34 +02:00
|
|
|
|
|
|
|
/* Do NOT use G_KEEPERR here */
|
|
|
|
count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
SPAGAIN;
|
|
|
|
|
2000-04-12 19:17:23 +02:00
|
|
|
if (count != 1)
|
|
|
|
{
|
|
|
|
PUTBACK;
|
|
|
|
FREETMPS;
|
2000-01-20 06:08:58 +01:00
|
|
|
LEAVE;
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "didn't get a return item from function");
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
|
|
|
|
2000-09-12 06:28:30 +02:00
|
|
|
if (SvTRUE(ERRSV))
|
2000-04-12 19:17:23 +02:00
|
|
|
{
|
2000-01-20 06:08:58 +01:00
|
|
|
POPs;
|
2000-04-12 19:17:23 +02:00
|
|
|
PUTBACK;
|
|
|
|
FREETMPS;
|
2000-01-20 06:08:58 +01:00
|
|
|
LEAVE;
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "error from function: %s", SvPV(ERRSV, PL_na));
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
retval = newSVsv(POPs);
|
|
|
|
|
2000-04-12 19:17:23 +02:00
|
|
|
PUTBACK;
|
|
|
|
FREETMPS;
|
|
|
|
LEAVE;
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
return retval;
|
|
|
|
}
|
|
|
|
|
2004-07-01 22:50:22 +02:00
|
|
|
/**********************************************************************
|
|
|
|
* plperl_call_perl_trigger_func() - calls a perl function affected by trigger
|
|
|
|
* through the RV stored in the prodesc structure. massages the input parms properly
|
|
|
|
**********************************************************************/
|
|
|
|
static SV *
|
2004-08-30 04:54:42 +02:00
|
|
|
plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, SV *td)
|
2004-07-01 22:50:22 +02:00
|
|
|
{
|
|
|
|
dSP;
|
|
|
|
SV *retval;
|
|
|
|
int i;
|
|
|
|
int count;
|
|
|
|
|
|
|
|
ENTER;
|
|
|
|
SAVETMPS;
|
|
|
|
|
|
|
|
PUSHMARK(sp);
|
|
|
|
XPUSHs(td);
|
|
|
|
for (i = 0; i < ((TriggerData *) fcinfo->context)->tg_trigger->tgnargs; i++)
|
|
|
|
XPUSHs(sv_2mortal(newSVpv(((TriggerData *) fcinfo->context)->tg_trigger->tgargs[i], 0)));
|
|
|
|
PUTBACK;
|
|
|
|
|
|
|
|
count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL | G_KEEPERR);
|
|
|
|
|
|
|
|
SPAGAIN;
|
|
|
|
|
|
|
|
if (count != 1)
|
|
|
|
{
|
|
|
|
PUTBACK;
|
|
|
|
FREETMPS;
|
|
|
|
LEAVE;
|
|
|
|
elog(ERROR, "plperl: didn't get a return item from function");
|
|
|
|
}
|
|
|
|
|
|
|
|
if (SvTRUE(ERRSV))
|
|
|
|
{
|
|
|
|
POPs;
|
|
|
|
PUTBACK;
|
|
|
|
FREETMPS;
|
|
|
|
LEAVE;
|
|
|
|
elog(ERROR, "plperl: error from function: %s", SvPV(ERRSV, PL_na));
|
|
|
|
}
|
|
|
|
|
|
|
|
retval = newSVsv(POPs);
|
|
|
|
|
|
|
|
PUTBACK;
|
|
|
|
FREETMPS;
|
|
|
|
LEAVE;
|
|
|
|
|
|
|
|
return retval;
|
|
|
|
}
|
2003-04-20 23:15:34 +02:00
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
/**********************************************************************
|
|
|
|
* plperl_func_handler() - Handler for regular function calls
|
|
|
|
**********************************************************************/
|
|
|
|
static Datum
|
2000-05-28 19:56:29 +02:00
|
|
|
plperl_func_handler(PG_FUNCTION_ARGS)
|
2000-01-20 06:08:58 +01:00
|
|
|
{
|
|
|
|
plperl_proc_desc *prodesc;
|
2000-04-12 19:17:23 +02:00
|
|
|
SV *perlret;
|
|
|
|
Datum retval;
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2001-10-20 00:43:49 +02:00
|
|
|
/* Find or compile the function */
|
|
|
|
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
|
2004-09-13 22:10:13 +02:00
|
|
|
|
|
|
|
plperl_current_prodesc = prodesc;
|
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
/************************************************************
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
* Call the Perl function if not returning set
|
2000-01-20 06:08:58 +01:00
|
|
|
************************************************************/
|
2004-08-29 07:07:03 +02:00
|
|
|
if (!prodesc->fn_retisset)
|
|
|
|
perlret = plperl_call_perl_func(prodesc, fcinfo);
|
|
|
|
else
|
2004-07-01 22:50:22 +02:00
|
|
|
{
|
2004-08-29 07:07:03 +02:00
|
|
|
if (SRF_IS_FIRSTCALL()) /* call function only once */
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
srf_perlret = plperl_call_perl_func(prodesc, fcinfo);
|
|
|
|
perlret = srf_perlret;
|
2004-08-29 07:07:03 +02:00
|
|
|
}
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
if (prodesc->fn_retisset && SRF_IS_FIRSTCALL())
|
|
|
|
{
|
2004-07-21 22:45:54 +02:00
|
|
|
if (prodesc->fn_retistuple)
|
|
|
|
g_column_keys = newAV();
|
2004-07-01 22:50:22 +02:00
|
|
|
if (SvTYPE(perlret) != SVt_RV)
|
2004-08-29 07:07:03 +02:00
|
|
|
elog(ERROR, "plperl: set-returning function must return reference");
|
2004-07-01 22:50:22 +02:00
|
|
|
}
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/************************************************************
|
|
|
|
* Disconnect from SPI manager and then create the return
|
|
|
|
* values datum (if the input function does a palloc for it
|
|
|
|
* this must not be allocated in the SPI memory context
|
|
|
|
* because SPI_finish would free it).
|
|
|
|
************************************************************/
|
|
|
|
if (SPI_finish() != SPI_OK_FINISH)
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "SPI_finish() failed");
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
if (!(perlret && SvOK(perlret) && SvTYPE(perlret) != SVt_NULL))
|
2000-05-28 19:56:29 +02:00
|
|
|
{
|
2002-01-24 17:53:42 +01:00
|
|
|
/* return NULL if Perl code returned undef */
|
2000-05-28 19:56:29 +02:00
|
|
|
retval = (Datum) 0;
|
|
|
|
fcinfo->isnull = true;
|
|
|
|
}
|
2004-07-01 22:50:22 +02:00
|
|
|
|
2004-07-21 22:45:54 +02:00
|
|
|
if (prodesc->fn_retisset && !(perlret && SvTYPE(SvRV(perlret)) == SVt_PVAV))
|
|
|
|
elog(ERROR, "plperl: set-returning function must return reference to array");
|
|
|
|
|
|
|
|
if (prodesc->fn_retistuple && perlret && SvTYPE(perlret) != SVt_RV)
|
|
|
|
elog(ERROR, "plperl: composite-returning function must return a reference");
|
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
if (prodesc->fn_retistuple && fcinfo->resultinfo) /* set of tuples */
|
2004-07-01 22:50:22 +02:00
|
|
|
{
|
|
|
|
/* SRF support */
|
|
|
|
HV *ret_hv;
|
|
|
|
AV *ret_av;
|
|
|
|
|
|
|
|
FuncCallContext *funcctx;
|
|
|
|
int call_cntr;
|
|
|
|
int max_calls;
|
|
|
|
TupleDesc tupdesc;
|
|
|
|
TupleTableSlot *slot;
|
|
|
|
AttInMetadata *attinmeta;
|
|
|
|
bool isset = 0;
|
|
|
|
char **values = NULL;
|
2004-08-29 07:07:03 +02:00
|
|
|
ReturnSetInfo *rsinfo = (ReturnSetInfo *) fcinfo->resultinfo;
|
2004-07-01 22:50:22 +02:00
|
|
|
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
if (prodesc->fn_retisset && !rsinfo)
|
2004-07-01 22:50:22 +02:00
|
|
|
ereport(ERROR,
|
|
|
|
(errcode(ERRCODE_SYNTAX_ERROR),
|
2004-08-29 07:07:03 +02:00
|
|
|
errmsg("returning a composite type is not allowed in this context"),
|
|
|
|
errhint("This function is intended for use in the FROM clause.")));
|
2004-07-01 22:50:22 +02:00
|
|
|
|
|
|
|
|
|
|
|
isset = plperl_is_set(perlret);
|
|
|
|
|
|
|
|
if (SvTYPE(SvRV(perlret)) == SVt_PVHV)
|
|
|
|
ret_hv = (HV *) SvRV(perlret);
|
|
|
|
else
|
|
|
|
ret_av = (AV *) SvRV(perlret);
|
|
|
|
|
|
|
|
if (SRF_IS_FIRSTCALL())
|
|
|
|
{
|
|
|
|
MemoryContext oldcontext;
|
|
|
|
int i;
|
|
|
|
|
|
|
|
funcctx = SRF_FIRSTCALL_INIT();
|
|
|
|
|
|
|
|
oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx);
|
|
|
|
|
|
|
|
if (SvTYPE(SvRV(perlret)) == SVt_PVHV)
|
|
|
|
{
|
|
|
|
if (isset)
|
|
|
|
funcctx->max_calls = hv_iterinit(ret_hv);
|
|
|
|
else
|
|
|
|
funcctx->max_calls = 1;
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
if (isset)
|
|
|
|
funcctx->max_calls = av_len(ret_av) + 1;
|
|
|
|
else
|
|
|
|
funcctx->max_calls = 1;
|
|
|
|
}
|
|
|
|
|
|
|
|
tupdesc = CreateTupleDescCopy(rsinfo->expectedDesc);
|
|
|
|
|
|
|
|
g_attr_num = tupdesc->natts;
|
|
|
|
|
|
|
|
for (i = 0; i < tupdesc->natts; i++)
|
2004-10-15 19:08:26 +02:00
|
|
|
av_store(g_column_keys, i + 1,
|
|
|
|
newSVpv(SPI_fname(tupdesc, i+1), 0));
|
2004-07-01 22:50:22 +02:00
|
|
|
|
|
|
|
slot = TupleDescGetSlot(tupdesc);
|
|
|
|
funcctx->slot = slot;
|
|
|
|
attinmeta = TupleDescGetAttInMetadata(tupdesc);
|
|
|
|
funcctx->attinmeta = attinmeta;
|
|
|
|
MemoryContextSwitchTo(oldcontext);
|
|
|
|
}
|
|
|
|
|
|
|
|
funcctx = SRF_PERCALL_SETUP();
|
|
|
|
call_cntr = funcctx->call_cntr;
|
|
|
|
max_calls = funcctx->max_calls;
|
|
|
|
slot = funcctx->slot;
|
|
|
|
attinmeta = funcctx->attinmeta;
|
|
|
|
|
|
|
|
if (call_cntr < max_calls)
|
|
|
|
{
|
|
|
|
HeapTuple tuple;
|
|
|
|
Datum result;
|
|
|
|
int i;
|
|
|
|
char *column_key;
|
|
|
|
char *elem;
|
|
|
|
|
|
|
|
if (isset)
|
|
|
|
{
|
|
|
|
HV *row_hv;
|
|
|
|
SV **svp;
|
|
|
|
|
|
|
|
svp = av_fetch(ret_av, call_cntr, FALSE);
|
|
|
|
|
|
|
|
row_hv = (HV *) SvRV(*svp);
|
|
|
|
|
|
|
|
values = (char **) palloc(g_attr_num * sizeof(char *));
|
|
|
|
|
|
|
|
for (i = 0; i < g_attr_num; i++)
|
|
|
|
{
|
|
|
|
column_key = plperl_get_key(g_column_keys, i + 1);
|
|
|
|
elem = plperl_get_elem(row_hv, column_key);
|
|
|
|
if (elem)
|
|
|
|
values[i] = elem;
|
|
|
|
else
|
|
|
|
values[i] = NULL;
|
|
|
|
}
|
|
|
|
}
|
2004-08-29 07:07:03 +02:00
|
|
|
else
|
|
|
|
{
|
2004-07-01 22:50:22 +02:00
|
|
|
int i;
|
|
|
|
|
|
|
|
values = (char **) palloc(g_attr_num * sizeof(char *));
|
|
|
|
for (i = 0; i < g_attr_num; i++)
|
|
|
|
{
|
|
|
|
column_key = SPI_fname(tupdesc, i + 1);
|
|
|
|
elem = plperl_get_elem(ret_hv, column_key);
|
|
|
|
if (elem)
|
|
|
|
values[i] = elem;
|
|
|
|
else
|
|
|
|
values[i] = NULL;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
tuple = BuildTupleFromCStrings(attinmeta, values);
|
|
|
|
result = TupleGetDatum(slot, tuple);
|
|
|
|
SRF_RETURN_NEXT(funcctx, result);
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
SvREFCNT_dec(perlret);
|
|
|
|
SRF_RETURN_DONE(funcctx);
|
|
|
|
}
|
|
|
|
}
|
2004-08-29 07:07:03 +02:00
|
|
|
else if (prodesc->fn_retisset) /* set of non-tuples */
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
{
|
2004-08-29 07:07:03 +02:00
|
|
|
FuncCallContext *funcctx;
|
|
|
|
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
if (SRF_IS_FIRSTCALL())
|
|
|
|
{
|
|
|
|
MemoryContext oldcontext;
|
|
|
|
|
|
|
|
funcctx = SRF_FIRSTCALL_INIT();
|
|
|
|
oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx);
|
|
|
|
|
2004-07-21 22:45:54 +02:00
|
|
|
funcctx->max_calls = av_len((AV *) SvRV(perlret)) + 1;
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
}
|
2004-08-29 07:07:03 +02:00
|
|
|
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
funcctx = SRF_PERCALL_SETUP();
|
2004-08-29 07:07:03 +02:00
|
|
|
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
if (funcctx->call_cntr < funcctx->max_calls)
|
|
|
|
{
|
|
|
|
Datum result;
|
2004-08-29 07:07:03 +02:00
|
|
|
AV *array;
|
|
|
|
SV **svp;
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
array = (AV *) SvRV(perlret);
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
svp = av_fetch(array, funcctx->call_cntr, FALSE);
|
|
|
|
|
|
|
|
if (SvTYPE(*svp) != SVt_NULL)
|
|
|
|
result = FunctionCall3(&prodesc->result_in_func,
|
2004-08-29 07:07:03 +02:00
|
|
|
PointerGetDatum(SvPV(*svp, PL_na)),
|
|
|
|
ObjectIdGetDatum(prodesc->result_typioparam),
|
|
|
|
Int32GetDatum(-1));
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
else
|
|
|
|
{
|
|
|
|
fcinfo->isnull = true;
|
|
|
|
result = (Datum) 0;
|
|
|
|
}
|
|
|
|
SRF_RETURN_NEXT(funcctx, result);
|
|
|
|
fcinfo->isnull = false;
|
2004-08-29 07:07:03 +02:00
|
|
|
}
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
else
|
|
|
|
{
|
2004-07-21 22:45:54 +02:00
|
|
|
if (perlret)
|
|
|
|
SvREFCNT_dec(perlret);
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
SRF_RETURN_DONE(funcctx);
|
|
|
|
}
|
2004-08-29 07:07:03 +02:00
|
|
|
}
|
|
|
|
else if (!fcinfo->isnull) /* non-null singleton */
|
2000-05-28 19:56:29 +02:00
|
|
|
{
|
2004-07-21 22:45:54 +02:00
|
|
|
|
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
if (prodesc->fn_retistuple) /* singleton perl hash to Datum */
|
2004-07-21 22:45:54 +02:00
|
|
|
{
|
2004-08-29 07:07:03 +02:00
|
|
|
TupleDesc td = lookup_rowtype_tupdesc(prodesc->ret_oid, (int32) -1);
|
|
|
|
HV *perlhash = (HV *) SvRV(perlret);
|
|
|
|
int i;
|
|
|
|
char **values;
|
|
|
|
char *key,
|
|
|
|
*val;
|
2004-07-21 22:45:54 +02:00
|
|
|
AttInMetadata *attinmeta;
|
2004-08-29 07:07:03 +02:00
|
|
|
HeapTuple tup;
|
2004-07-21 22:45:54 +02:00
|
|
|
|
|
|
|
if (!td)
|
|
|
|
ereport(ERROR,
|
|
|
|
(errcode(ERRCODE_SYNTAX_ERROR),
|
|
|
|
errmsg("no TupleDesc info available")));
|
|
|
|
|
|
|
|
values = (char **) palloc(td->natts * sizeof(char *));
|
|
|
|
for (i = 0; i < td->natts; i++)
|
|
|
|
{
|
|
|
|
|
2004-08-29 07:07:03 +02:00
|
|
|
key = SPI_fname(td, i + 1);
|
2004-07-21 22:45:54 +02:00
|
|
|
val = plperl_get_elem(perlhash, key);
|
|
|
|
if (val)
|
|
|
|
values[i] = val;
|
|
|
|
else
|
|
|
|
values[i] = NULL;
|
|
|
|
}
|
|
|
|
attinmeta = TupleDescGetAttInMetadata(td);
|
|
|
|
tup = BuildTupleFromCStrings(attinmeta, values);
|
|
|
|
retval = HeapTupleGetDatum(tup);
|
2004-08-29 07:07:03 +02:00
|
|
|
|
2004-07-21 22:45:54 +02:00
|
|
|
}
|
2004-08-29 07:07:03 +02:00
|
|
|
else
|
2004-10-07 17:21:58 +02:00
|
|
|
/* perl string to Datum */
|
2004-08-29 07:07:03 +02:00
|
|
|
retval = FunctionCall3(&prodesc->result_in_func,
|
|
|
|
PointerGetDatum(SvPV(perlret, PL_na)),
|
|
|
|
ObjectIdGetDatum(prodesc->result_typioparam),
|
|
|
|
Int32GetDatum(-1));
|
2004-07-21 22:45:54 +02:00
|
|
|
|
2000-05-28 19:56:29 +02:00
|
|
|
}
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
SvREFCNT_dec(perlret);
|
|
|
|
return retval;
|
|
|
|
}
|
|
|
|
|
2004-07-01 22:50:22 +02:00
|
|
|
/**********************************************************************
|
|
|
|
* plperl_trigger_handler() - Handler for trigger function calls
|
|
|
|
**********************************************************************/
|
|
|
|
static Datum
|
|
|
|
plperl_trigger_handler(PG_FUNCTION_ARGS)
|
|
|
|
{
|
|
|
|
plperl_proc_desc *prodesc;
|
|
|
|
SV *perlret;
|
|
|
|
Datum retval;
|
|
|
|
char *tmp;
|
|
|
|
SV *svTD;
|
|
|
|
HV *hvTD;
|
|
|
|
|
|
|
|
/* Find or compile the function */
|
|
|
|
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
|
|
|
|
|
2004-09-13 22:10:13 +02:00
|
|
|
plperl_current_prodesc = prodesc;
|
|
|
|
|
2004-07-01 22:50:22 +02:00
|
|
|
/************************************************************
|
|
|
|
* Call the Perl function
|
|
|
|
************************************************************/
|
2004-08-29 07:07:03 +02:00
|
|
|
|
2004-07-01 22:50:22 +02:00
|
|
|
/*
|
2004-08-29 07:07:03 +02:00
|
|
|
* call perl trigger function and build TD hash
|
|
|
|
*/
|
2004-07-01 22:50:22 +02:00
|
|
|
svTD = plperl_trigger_build_args(fcinfo);
|
|
|
|
perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
|
|
|
|
|
|
|
|
hvTD = (HV *) SvRV(svTD); /* convert SV TD structure to Perl Hash
|
|
|
|
* structure */
|
|
|
|
|
|
|
|
tmp = SvPV(perlret, PL_na);
|
|
|
|
|
|
|
|
/************************************************************
|
|
|
|
* Disconnect from SPI manager and then create the return
|
|
|
|
* values datum (if the input function does a palloc for it
|
|
|
|
* this must not be allocated in the SPI memory context
|
|
|
|
* because SPI_finish would free it).
|
|
|
|
************************************************************/
|
|
|
|
if (SPI_finish() != SPI_OK_FINISH)
|
|
|
|
elog(ERROR, "plperl: SPI_finish() failed");
|
|
|
|
|
|
|
|
if (!(perlret && SvOK(perlret)))
|
|
|
|
{
|
|
|
|
TriggerData *trigdata = ((TriggerData *) fcinfo->context);
|
|
|
|
|
|
|
|
if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
|
|
|
|
retval = (Datum) trigdata->tg_trigtuple;
|
|
|
|
else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
|
|
|
|
retval = (Datum) trigdata->tg_newtuple;
|
|
|
|
else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
|
|
|
|
retval = (Datum) trigdata->tg_trigtuple;
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
if (!fcinfo->isnull)
|
|
|
|
{
|
|
|
|
|
|
|
|
HeapTuple trv;
|
|
|
|
|
|
|
|
if (strcasecmp(tmp, "SKIP") == 0)
|
|
|
|
trv = NULL;
|
|
|
|
else if (strcasecmp(tmp, "MODIFY") == 0)
|
|
|
|
{
|
|
|
|
TriggerData *trigdata = (TriggerData *) fcinfo->context;
|
|
|
|
|
|
|
|
if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
|
|
|
|
trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_trigtuple, fcinfo->flinfo->fn_oid);
|
|
|
|
else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
|
|
|
|
trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_newtuple, fcinfo->flinfo->fn_oid);
|
|
|
|
else
|
|
|
|
{
|
|
|
|
trv = NULL;
|
|
|
|
elog(WARNING, "plperl: Ignoring modified tuple in DELETE trigger");
|
|
|
|
}
|
|
|
|
}
|
|
|
|
else if (strcasecmp(tmp, "OK"))
|
|
|
|
{
|
|
|
|
trv = NULL;
|
|
|
|
elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'");
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
trv = NULL;
|
|
|
|
elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'");
|
|
|
|
}
|
|
|
|
retval = PointerGetDatum(trv);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
SvREFCNT_dec(perlret);
|
|
|
|
|
|
|
|
fcinfo->isnull = false;
|
|
|
|
return retval;
|
|
|
|
}
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/**********************************************************************
|
2001-10-20 00:43:49 +02:00
|
|
|
* compile_plperl_function - compile (or hopefully just look up) function
|
2000-01-20 06:08:58 +01:00
|
|
|
**********************************************************************/
|
2001-10-20 00:43:49 +02:00
|
|
|
static plperl_proc_desc *
|
|
|
|
compile_plperl_function(Oid fn_oid, bool is_trigger)
|
2000-01-20 06:08:58 +01:00
|
|
|
{
|
2001-10-20 00:43:49 +02:00
|
|
|
HeapTuple procTup;
|
|
|
|
Form_pg_proc procStruct;
|
|
|
|
char internal_proname[64];
|
|
|
|
int proname_len;
|
|
|
|
plperl_proc_desc *prodesc = NULL;
|
2000-01-20 06:08:58 +01:00
|
|
|
int i;
|
2004-10-15 19:08:26 +02:00
|
|
|
SV **svp;
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2001-10-20 00:43:49 +02:00
|
|
|
/* We'll need the pg_proc tuple in any case... */
|
|
|
|
procTup = SearchSysCache(PROCOID,
|
|
|
|
ObjectIdGetDatum(fn_oid),
|
|
|
|
0, 0, 0);
|
|
|
|
if (!HeapTupleIsValid(procTup))
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "cache lookup failed for function %u", fn_oid);
|
2001-10-20 00:43:49 +02:00
|
|
|
procStruct = (Form_pg_proc) GETSTRUCT(procTup);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/************************************************************
|
|
|
|
* Build our internal proc name from the functions Oid
|
|
|
|
************************************************************/
|
2001-10-20 00:43:49 +02:00
|
|
|
if (!is_trigger)
|
|
|
|
sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
|
|
|
|
else
|
|
|
|
sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
|
2004-07-01 22:50:22 +02:00
|
|
|
|
2001-10-20 00:43:49 +02:00
|
|
|
proname_len = strlen(internal_proname);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/************************************************************
|
|
|
|
* Lookup the internal proc name in the hashtable
|
|
|
|
************************************************************/
|
2004-10-15 19:08:26 +02:00
|
|
|
svp = hv_fetch(plperl_proc_hash, internal_proname, proname_len, FALSE);
|
|
|
|
if (svp)
|
2000-01-20 06:08:58 +01:00
|
|
|
{
|
2001-10-20 00:43:49 +02:00
|
|
|
bool uptodate;
|
|
|
|
|
2004-10-15 19:08:26 +02:00
|
|
|
prodesc = (plperl_proc_desc *) SvIV(*svp);
|
2001-10-20 00:43:49 +02:00
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
/************************************************************
|
2001-10-20 00:43:49 +02:00
|
|
|
* If it's present, must check whether it's still up to date.
|
|
|
|
* This is needed because CREATE OR REPLACE FUNCTION can modify the
|
|
|
|
* function's pg_proc entry without changing its OID.
|
2000-01-20 06:08:58 +01:00
|
|
|
************************************************************/
|
2002-06-15 21:54:24 +02:00
|
|
|
uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) &&
|
2002-09-04 22:31:48 +02:00
|
|
|
prodesc->fn_cmin == HeapTupleHeaderGetCmin(procTup->t_data));
|
2001-10-20 00:43:49 +02:00
|
|
|
|
|
|
|
if (!uptodate)
|
|
|
|
{
|
|
|
|
/* need we delete old entry? */
|
|
|
|
prodesc = NULL;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
/************************************************************
|
|
|
|
* If we haven't found it in the hashtable, we analyze
|
|
|
|
* the functions arguments and returntype and store
|
|
|
|
* the in-/out-functions in the prodesc block and create
|
|
|
|
* a new hashtable entry for it.
|
|
|
|
*
|
|
|
|
* Then we load the procedure into the Perl interpreter.
|
|
|
|
************************************************************/
|
|
|
|
if (prodesc == NULL)
|
|
|
|
{
|
|
|
|
HeapTuple langTup;
|
|
|
|
HeapTuple typeTup;
|
|
|
|
Form_pg_language langStruct;
|
|
|
|
Form_pg_type typeStruct;
|
2004-01-07 00:55:19 +01:00
|
|
|
Datum prosrcdatum;
|
|
|
|
bool isnull;
|
2000-01-20 06:08:58 +01:00
|
|
|
char *proc_source;
|
|
|
|
|
|
|
|
/************************************************************
|
|
|
|
* Allocate a new procedure description block
|
|
|
|
************************************************************/
|
|
|
|
prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
|
2001-10-20 00:43:49 +02:00
|
|
|
if (prodesc == NULL)
|
2003-07-26 01:37:31 +02:00
|
|
|
ereport(ERROR,
|
|
|
|
(errcode(ERRCODE_OUT_OF_MEMORY),
|
|
|
|
errmsg("out of memory")));
|
2001-10-20 00:43:49 +02:00
|
|
|
MemSet(prodesc, 0, sizeof(plperl_proc_desc));
|
|
|
|
prodesc->proname = strdup(internal_proname);
|
2002-06-15 21:54:24 +02:00
|
|
|
prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
|
|
|
|
prodesc->fn_cmin = HeapTupleHeaderGetCmin(procTup->t_data);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2004-09-13 22:10:13 +02:00
|
|
|
/* Remember if function is STABLE/IMMUTABLE */
|
|
|
|
prodesc->fn_readonly =
|
|
|
|
(procStruct->provolatile != PROVOLATILE_VOLATILE);
|
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
/************************************************************
|
2001-10-20 00:43:49 +02:00
|
|
|
* Lookup the pg_language tuple by Oid
|
2000-01-20 06:08:58 +01:00
|
|
|
************************************************************/
|
2001-10-20 00:43:49 +02:00
|
|
|
langTup = SearchSysCache(LANGOID,
|
|
|
|
ObjectIdGetDatum(procStruct->prolang),
|
2000-11-16 23:30:52 +01:00
|
|
|
0, 0, 0);
|
2001-10-20 00:43:49 +02:00
|
|
|
if (!HeapTupleIsValid(langTup))
|
2000-01-20 06:08:58 +01:00
|
|
|
{
|
|
|
|
free(prodesc->proname);
|
|
|
|
free(prodesc);
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "cache lookup failed for language %u",
|
2001-10-20 00:43:49 +02:00
|
|
|
procStruct->prolang);
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
2001-10-20 00:43:49 +02:00
|
|
|
langStruct = (Form_pg_language) GETSTRUCT(langTup);
|
|
|
|
prodesc->lanpltrusted = langStruct->lanpltrusted;
|
|
|
|
ReleaseSysCache(langTup);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/************************************************************
|
2001-10-20 00:43:49 +02:00
|
|
|
* Get the required information for input conversion of the
|
|
|
|
* return value.
|
2000-01-20 06:08:58 +01:00
|
|
|
************************************************************/
|
2001-10-20 00:43:49 +02:00
|
|
|
if (!is_trigger)
|
|
|
|
{
|
|
|
|
typeTup = SearchSysCache(TYPEOID,
|
2001-10-25 07:50:21 +02:00
|
|
|
ObjectIdGetDatum(procStruct->prorettype),
|
2001-10-20 00:43:49 +02:00
|
|
|
0, 0, 0);
|
|
|
|
if (!HeapTupleIsValid(typeTup))
|
|
|
|
{
|
|
|
|
free(prodesc->proname);
|
|
|
|
free(prodesc);
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "cache lookup failed for type %u",
|
2002-08-22 02:01:51 +02:00
|
|
|
procStruct->prorettype);
|
2001-10-20 00:43:49 +02:00
|
|
|
}
|
|
|
|
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
|
|
|
|
|
2004-07-01 22:50:22 +02:00
|
|
|
/* Disallow pseudotype result, except VOID or RECORD */
|
2002-08-22 02:01:51 +02:00
|
|
|
if (typeStruct->typtype == 'p')
|
|
|
|
{
|
2004-07-01 22:50:22 +02:00
|
|
|
if (procStruct->prorettype == VOIDOID ||
|
|
|
|
procStruct->prorettype == RECORDOID)
|
2002-09-04 22:31:48 +02:00
|
|
|
/* okay */ ;
|
2002-09-21 20:39:26 +02:00
|
|
|
else if (procStruct->prorettype == TRIGGEROID)
|
2002-08-22 02:01:51 +02:00
|
|
|
{
|
|
|
|
free(prodesc->proname);
|
|
|
|
free(prodesc);
|
2003-07-26 01:37:31 +02:00
|
|
|
ereport(ERROR,
|
|
|
|
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
|
|
|
|
errmsg("trigger functions may only be called as triggers")));
|
2002-08-22 02:01:51 +02:00
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
free(prodesc->proname);
|
|
|
|
free(prodesc);
|
2003-07-26 01:37:31 +02:00
|
|
|
ereport(ERROR,
|
|
|
|
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
|
2003-08-04 02:43:34 +02:00
|
|
|
errmsg("plperl functions cannot return type %s",
|
|
|
|
format_type_be(procStruct->prorettype))));
|
2002-08-22 02:01:51 +02:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2004-07-21 22:45:54 +02:00
|
|
|
prodesc->fn_retisset = procStruct->proretset; /* true, if function
|
|
|
|
* returns set */
|
The attached patch, which incorporates the previous one sent and
currently unapplied regarding spi_internal.c, makes some additional
fixes relating to return types, and also contains the fix for
preventing the use of insecure versions of Safe.pm.
There is one remaing return case that does not appear to work, namely
return of a composite directly in a select, i.e. if foo returns some
composite type, 'select * from foo()' works but 'select foo()' doesn't.
We will either fix that or document it as a limitation.
The function plperl_func_handler is a mess - I will try to get it
cleaned up (and split up) in a subsequent patch, time permitting.
Also, reiterating previous advice - this changes slightly the API for
spi_exec_query - the returned object has either 2 or 3 members: 'status'
(string) and 'proceesed' (int,- number of rows) and, if rows are
returned, 'rows' (array of tuple hashes).
Andrew Dunstan
2004-07-12 16:31:04 +02:00
|
|
|
|
2004-07-01 22:50:22 +02:00
|
|
|
if (typeStruct->typtype == 'c' || procStruct->prorettype == RECORDOID)
|
2001-10-20 00:43:49 +02:00
|
|
|
{
|
2004-07-01 22:50:22 +02:00
|
|
|
prodesc->fn_retistuple = true;
|
2004-08-29 07:07:03 +02:00
|
|
|
prodesc->ret_oid =
|
|
|
|
procStruct->prorettype == RECORDOID ?
|
|
|
|
typeStruct->typrelid :
|
2004-07-21 22:45:54 +02:00
|
|
|
procStruct->prorettype;
|
2001-10-20 00:43:49 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
|
2004-06-06 02:41:28 +02:00
|
|
|
prodesc->result_typioparam = getTypeIOParam(typeTup);
|
2001-10-20 00:43:49 +02:00
|
|
|
|
|
|
|
ReleaseSysCache(typeTup);
|
|
|
|
}
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/************************************************************
|
2001-10-20 00:43:49 +02:00
|
|
|
* Get the required information for output conversion
|
|
|
|
* of all procedure arguments
|
2000-01-20 06:08:58 +01:00
|
|
|
************************************************************/
|
2001-10-20 00:43:49 +02:00
|
|
|
if (!is_trigger)
|
|
|
|
{
|
|
|
|
prodesc->nargs = procStruct->pronargs;
|
|
|
|
for (i = 0; i < prodesc->nargs; i++)
|
|
|
|
{
|
|
|
|
typeTup = SearchSysCache(TYPEOID,
|
2001-10-25 07:50:21 +02:00
|
|
|
ObjectIdGetDatum(procStruct->proargtypes[i]),
|
2001-10-20 00:43:49 +02:00
|
|
|
0, 0, 0);
|
|
|
|
if (!HeapTupleIsValid(typeTup))
|
|
|
|
{
|
|
|
|
free(prodesc->proname);
|
|
|
|
free(prodesc);
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "cache lookup failed for type %u",
|
2002-08-22 02:01:51 +02:00
|
|
|
procStruct->proargtypes[i]);
|
2001-10-20 00:43:49 +02:00
|
|
|
}
|
|
|
|
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
|
|
|
|
|
2002-08-22 02:01:51 +02:00
|
|
|
/* Disallow pseudotype argument */
|
|
|
|
if (typeStruct->typtype == 'p')
|
|
|
|
{
|
|
|
|
free(prodesc->proname);
|
|
|
|
free(prodesc);
|
2003-07-26 01:37:31 +02:00
|
|
|
ereport(ERROR,
|
|
|
|
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
|
2003-08-04 02:43:34 +02:00
|
|
|
errmsg("plperl functions cannot take type %s",
|
|
|
|
format_type_be(procStruct->proargtypes[i]))));
|
2002-08-22 02:01:51 +02:00
|
|
|
}
|
|
|
|
|
2004-04-01 23:28:47 +02:00
|
|
|
if (typeStruct->typtype == 'c')
|
|
|
|
prodesc->arg_is_rowtype[i] = true;
|
2001-10-20 00:43:49 +02:00
|
|
|
else
|
2004-04-01 23:28:47 +02:00
|
|
|
{
|
|
|
|
prodesc->arg_is_rowtype[i] = false;
|
|
|
|
perm_fmgr_info(typeStruct->typoutput,
|
|
|
|
&(prodesc->arg_out_func[i]));
|
2004-06-06 02:41:28 +02:00
|
|
|
prodesc->arg_typioparam[i] = getTypeIOParam(typeTup);
|
2004-04-01 23:28:47 +02:00
|
|
|
}
|
2001-10-20 00:43:49 +02:00
|
|
|
|
|
|
|
ReleaseSysCache(typeTup);
|
|
|
|
}
|
|
|
|
}
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2001-10-20 00:43:49 +02:00
|
|
|
/************************************************************
|
|
|
|
* create the text of the anonymous subroutine.
|
|
|
|
* we do not use a named subroutine so that we can call directly
|
|
|
|
* through the reference.
|
|
|
|
*
|
|
|
|
************************************************************/
|
2004-01-07 00:55:19 +01:00
|
|
|
prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
|
|
|
|
Anum_pg_proc_prosrc, &isnull);
|
|
|
|
if (isnull)
|
|
|
|
elog(ERROR, "null prosrc");
|
2000-07-06 01:12:09 +02:00
|
|
|
proc_source = DatumGetCString(DirectFunctionCall1(textout,
|
2004-01-07 00:55:19 +01:00
|
|
|
prosrcdatum));
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/************************************************************
|
2001-10-20 00:43:49 +02:00
|
|
|
* Create the procedure in the interpreter
|
2000-01-20 06:08:58 +01:00
|
|
|
************************************************************/
|
2001-10-20 00:43:49 +02:00
|
|
|
prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted);
|
|
|
|
pfree(proc_source);
|
|
|
|
if (!prodesc->reference)
|
2000-01-20 06:08:58 +01:00
|
|
|
{
|
|
|
|
free(prodesc->proname);
|
|
|
|
free(prodesc);
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "could not create internal procedure \"%s\"",
|
2001-10-20 00:43:49 +02:00
|
|
|
internal_proname);
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
/************************************************************
|
|
|
|
* Add the proc description block to the hashtable
|
|
|
|
************************************************************/
|
2001-10-20 00:43:49 +02:00
|
|
|
hv_store(plperl_proc_hash, internal_proname, proname_len,
|
|
|
|
newSViv((IV) prodesc), 0);
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
|
|
|
|
2001-10-20 00:43:49 +02:00
|
|
|
ReleaseSysCache(procTup);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2001-10-20 00:43:49 +02:00
|
|
|
return prodesc;
|
|
|
|
}
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
|
|
|
|
/**********************************************************************
|
|
|
|
* plperl_build_tuple_argument() - Build a string for a ref to a hash
|
|
|
|
* from all attributes of a given tuple
|
|
|
|
**********************************************************************/
|
2003-08-04 02:43:34 +02:00
|
|
|
static SV *
|
2000-01-20 06:08:58 +01:00
|
|
|
plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
|
|
|
|
{
|
|
|
|
int i;
|
2004-10-15 19:08:26 +02:00
|
|
|
HV *hv;
|
2000-01-20 06:08:58 +01:00
|
|
|
Datum attr;
|
|
|
|
bool isnull;
|
|
|
|
char *attname;
|
2000-04-12 19:17:23 +02:00
|
|
|
char *outputstr;
|
2000-01-20 06:08:58 +01:00
|
|
|
HeapTuple typeTup;
|
|
|
|
Oid typoutput;
|
2004-06-06 02:41:28 +02:00
|
|
|
Oid typioparam;
|
2004-10-15 19:08:26 +02:00
|
|
|
int namelen;
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2004-10-15 19:08:26 +02:00
|
|
|
hv = newHV();
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
for (i = 0; i < tupdesc->natts; i++)
|
|
|
|
{
|
2003-09-04 17:16:39 +02:00
|
|
|
if (tupdesc->attrs[i]->attisdropped)
|
|
|
|
continue;
|
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
attname = tupdesc->attrs[i]->attname.data;
|
2004-10-15 19:08:26 +02:00
|
|
|
namelen = strlen(attname);
|
2000-01-20 06:08:58 +01:00
|
|
|
attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
|
|
|
|
|
2004-10-15 19:08:26 +02:00
|
|
|
if (isnull) {
|
|
|
|
/* Store (attname => undef) and move on. */
|
|
|
|
hv_store(hv, attname, namelen, newSV(0), 0);
|
2001-10-20 00:43:49 +02:00
|
|
|
continue;
|
|
|
|
}
|
|
|
|
|
2000-01-20 06:08:58 +01:00
|
|
|
/************************************************************
|
|
|
|
* Lookup the attribute type in the syscache
|
|
|
|
* for the output function
|
|
|
|
************************************************************/
|
2000-11-16 23:30:52 +01:00
|
|
|
typeTup = SearchSysCache(TYPEOID,
|
2000-01-20 06:08:58 +01:00
|
|
|
ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
|
2000-11-16 23:30:52 +01:00
|
|
|
0, 0, 0);
|
2000-01-20 06:08:58 +01:00
|
|
|
if (!HeapTupleIsValid(typeTup))
|
2003-07-26 01:37:31 +02:00
|
|
|
elog(ERROR, "cache lookup failed for type %u",
|
|
|
|
tupdesc->attrs[i]->atttypid);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
2001-10-20 00:43:49 +02:00
|
|
|
typoutput = ((Form_pg_type) GETSTRUCT(typeTup))->typoutput;
|
2004-06-06 02:41:28 +02:00
|
|
|
typioparam = getTypeIOParam(typeTup);
|
2000-11-16 23:30:52 +01:00
|
|
|
ReleaseSysCache(typeTup);
|
2000-01-20 06:08:58 +01:00
|
|
|
|
|
|
|
/************************************************************
|
2001-10-20 00:43:49 +02:00
|
|
|
* Append the attribute name and the value to the list.
|
2000-01-20 06:08:58 +01:00
|
|
|
************************************************************/
|
2001-10-20 00:43:49 +02:00
|
|
|
outputstr = DatumGetCString(OidFunctionCall3(typoutput,
|
|
|
|
attr,
|
2004-08-29 07:07:03 +02:00
|
|
|
ObjectIdGetDatum(typioparam),
|
2001-10-25 07:50:21 +02:00
|
|
|
Int32GetDatum(tupdesc->attrs[i]->atttypmod)));
|
2004-10-15 19:08:26 +02:00
|
|
|
|
|
|
|
hv_store(hv, attname, namelen, newSVpv(outputstr, 0), 0);
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
2001-10-20 00:43:49 +02:00
|
|
|
|
2004-10-15 19:08:26 +02:00
|
|
|
return sv_2mortal(newRV((SV *)hv));
|
2000-01-20 06:08:58 +01:00
|
|
|
}
|
2004-09-13 22:10:13 +02:00
|
|
|
|
|
|
|
|
|
|
|
HV *
|
|
|
|
plperl_spi_exec(char *query, int limit)
|
|
|
|
{
|
|
|
|
HV *ret_hv;
|
|
|
|
int spi_rv;
|
|
|
|
|
|
|
|
spi_rv = SPI_execute(query, plperl_current_prodesc->fn_readonly, limit);
|
|
|
|
ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed, spi_rv);
|
|
|
|
|
|
|
|
return ret_hv;
|
|
|
|
}
|
|
|
|
|
|
|
|
static HV *
|
|
|
|
plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed, int status)
|
|
|
|
{
|
|
|
|
HV *result;
|
|
|
|
|
|
|
|
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);
|
|
|
|
|
|
|
|
if (status == SPI_OK_SELECT)
|
|
|
|
{
|
|
|
|
if (processed)
|
|
|
|
{
|
|
|
|
AV *rows;
|
|
|
|
HV *row;
|
|
|
|
int i;
|
|
|
|
|
|
|
|
rows = newAV();
|
|
|
|
for (i = 0; i < processed; i++)
|
|
|
|
{
|
|
|
|
row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
|
2004-10-15 19:08:26 +02:00
|
|
|
av_push(rows, newRV_noinc((SV *)row));
|
2004-09-13 22:10:13 +02:00
|
|
|
}
|
|
|
|
hv_store(result, "rows", strlen("rows"),
|
|
|
|
newRV_noinc((SV *) rows), 0);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
SPI_freetuptable(tuptable);
|
|
|
|
|
|
|
|
return result;
|
|
|
|
}
|