plperl.c

PostgreSQL 8.1.4的源码 适用于Linux下的开源数据库系统

/**********************************************************************
 * plperl.c - perl as a procedural language for PostgreSQL
 *
 * IDENTIFICATION
 *
 *	  This software is copyrighted by Mark Hollomon
 *	  but is shameless cribbed from pltcl.c by Jan Wieck.
 *
 *	  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.
 *
 * IDENTIFICATION
 *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.94.2.5 2006/01/28 16:21:33 adunstan Exp $
 *
 **********************************************************************/

#include "postgres.h"
/* Defined by Perl */
#undef _

/* system stuff */
#include <ctype.h>
#include <fcntl.h>
#include <unistd.h>
#include <locale.h>

/* postgreSQL stuff */
#include "commands/trigger.h"
#include "executor/spi.h"
#include "funcapi.h"
#include "utils/lsyscache.h"
#include "utils/memutils.h"
#include "utils/typcache.h"
#include "miscadmin.h"
#include "mb/pg_wchar.h"

/* perl stuff */

/* stop perl from hijacking stdio and other stuff */
#ifdef WIN32
#define WIN32IO_IS_STDIO
#endif 

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
#include "spi_internal.h"

/* just in case these symbols aren't provided */
#ifndef pTHX_
#define pTHX_
#define pTHX void
#endif


/**********************************************************************
 * The information we cache about loaded procedures
 **********************************************************************/
typedef struct plperl_proc_desc
{
	char	   *proname;
	TransactionId fn_xmin;
	CommandId	fn_cmin;
	bool		fn_readonly;
	bool		lanpltrusted;
	bool		fn_retistuple;	/* true, if function returns tuple */
	bool		fn_retisset;	/* true, if function returns set */
	bool		fn_retisarray;	/* true if function returns array */
	Oid			result_oid;		/* Oid of result type */
	FmgrInfo	result_in_func; /* I/O function and arg for result type */
	Oid			result_typioparam;
	int			nargs;
	FmgrInfo	arg_out_func[FUNC_MAX_ARGS];
	bool		arg_is_rowtype[FUNC_MAX_ARGS];
	SV		   *reference;
} plperl_proc_desc;

/*
 * The information we cache for the duration of a single call to a
 * function.
 */
typedef struct plperl_call_data
{
	plperl_proc_desc *prodesc;
	FunctionCallInfo  fcinfo;
	Tuplestorestate  *tuple_store;
	TupleDesc		  ret_tdesc;
	AttInMetadata	 *attinmeta;
	MemoryContext	  tmp_cxt;
} plperl_call_data;


/**********************************************************************
 * Global data
 **********************************************************************/
static bool plperl_firstcall = true;
static bool plperl_safe_init_done = false;
static PerlInterpreter *plperl_interp = NULL;
static HV  *plperl_proc_hash = NULL;

static bool plperl_use_strict = false;

/* this is saved and restored by plperl_call_handler */
static plperl_call_data *current_call_data = NULL;

/**********************************************************************
 * Forward declarations
 **********************************************************************/
static void plperl_init_all(void);
static void plperl_init_interp(void);

Datum		plperl_call_handler(PG_FUNCTION_ARGS);
Datum		plperl_validator(PG_FUNCTION_ARGS);
void		plperl_init(void);

static Datum plperl_func_handler(PG_FUNCTION_ARGS);

static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);

static SV  *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
static void plperl_init_shared_libs(pTHX);
static HV  *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);

/*
 * 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,
 * 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.
 */
static void
perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
{
	fmgr_info_cxt(functionId, finfo, TopMemoryContext);
}


/* Perform initialization during postmaster startup. */

void
plperl_init(void)
{
	if (!plperl_firstcall)
		return;

	DefineCustomBoolVariable(
							 "plperl.use_strict",
	  "If true, will compile trusted and untrusted perl code in strict mode",
							 NULL,
							 &plperl_use_strict,
							 PGC_USERSET,
							 NULL, NULL);

	EmitWarningsOnPlaceholders("plperl");

	plperl_init_interp();
	plperl_firstcall = false;
}


/* Perform initialization during backend startup. */

static void
plperl_init_all(void)
{
	if (plperl_firstcall)
		plperl_init();

	/* We don't need to do anything yet when a new backend starts. */
}

/* Each of these macros must represent a single string literal */

#define PERLBOOT \
	"SPI::bootstrap(); use vars qw(%_SHARED);" \
	"sub ::plperl_warn { my $msg = shift; " \
	"       $msg =~ s/\\(eval \\d+\\) //g; &elog(&NOTICE, $msg); } " \
	"$SIG{__WARN__} = \\&::plperl_warn; " \
	"sub ::plperl_die { my $msg = shift; " \
	"       $msg =~ s/\\(eval \\d+\\) //g; die $msg; } " \
	"$SIG{__DIE__} = \\&::plperl_die; " \
	"sub ::mkunsafefunc {" \
	"      my $ret = eval(qq[ sub { $_[0] $_[1] } ]); " \
	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" \
	"use strict; " \
	"sub ::mk_strict_unsafefunc {" \
	"      my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]); " \
	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; } " \
	"sub ::_plperl_to_pg_array {" \
	"  my $arg = shift; ref $arg eq 'ARRAY' || return $arg; " \
	"  my $res = ''; my $first = 1; " \
	"  foreach my $elem (@$arg) " \
	"  { " \
	"    $res .= ', ' unless $first; $first = undef; " \
	"    if (ref $elem) " \
	"    { " \
	"      $res .= _plperl_to_pg_array($elem); " \
	"    } " \
	"    else " \
	"    { " \
	"      my $str = qq($elem); " \
	"      $str =~ s/([\"\\\\])/\\\\$1/g; " \
	"      $res .= qq(\"$str\"); " \
	"    } " \
	"  } " \
	"  return qq({$res}); " \
	"} "

#define SAFE_MODULE \
	"require Safe; $Safe::VERSION"

#define SAFE_OK \
	"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" \
	"$PLContainer->permit_only(':default');" \
	"$PLContainer->permit(qw[:base_math !:base_io sort time]);" \
	"$PLContainer->share(qw[&elog &spi_exec_query &return_next " \
	"&spi_query &spi_fetchrow " \
	"&_plperl_to_pg_array " \
	"&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);" \
	"sub ::mksafefunc {" \
	"      my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]); " \
	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" \
	"$PLContainer->permit('require'); $PLContainer->reval('use strict;');" \
	"$PLContainer->deny('require');" \
	"sub ::mk_strict_safefunc {" \
	"      my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]); " \
	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }"

#define SAFE_BAD \
	"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" \
	"$PLContainer->permit_only(':default');" \
	"$PLContainer->share(qw[&elog &ERROR ]);" \
	"sub ::mksafefunc { return $PLContainer->reval(qq[sub { " \
	"      elog(ERROR,'trusted Perl functions disabled - " \
	"      please upgrade Perl Safe module to version 2.09 or later');}]); }" \
	"sub ::mk_strict_safefunc { return $PLContainer->reval(qq[sub { " \
	"      elog(ERROR,'trusted Perl functions disabled - " \
	"      please upgrade Perl Safe module to version 2.09 or later');}]); }"


static void
plperl_init_interp(void)
{
	static char *embedding[3] = {
		"", "-e", PERLBOOT
	};

#ifdef WIN32

	/* 
	 * The perl library on startup does horrible things like call
	 * setlocale(LC_ALL,""). We have protected against that on most
	 * platforms by setting the environment appropriately. However, on
	 * Windows, setlocale() does not consult the environment, so we need
	 * to save the existing locale settings before perl has a chance to 
	 * mangle them and restore them after its dirty deeds are done.
	 *
	 * MSDN ref:
	 * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
	 *
	 * It appears that we only need to do this on interpreter startup, and
	 * subsequent calls to the interpreter don't mess with the locale
	 * settings.
	 *
	 * We restore them using Perl's POSIX::setlocale() function so that
	 * Perl doesn't have a different idea of the locale from Postgres.
	 *
	 */

	char *loc;
	char *save_collate, *save_ctype, *save_monetary, *save_numeric, *save_time;
	char buf[1024];

	loc = setlocale(LC_COLLATE,NULL);
	save_collate = loc ? pstrdup(loc) : NULL;
	loc = setlocale(LC_CTYPE,NULL);
	save_ctype = loc ? pstrdup(loc) : NULL;
	loc = setlocale(LC_MONETARY,NULL);
	save_monetary = loc ? pstrdup(loc) : NULL;
	loc = setlocale(LC_NUMERIC,NULL);
	save_numeric = loc ? pstrdup(loc) : NULL;
	loc = setlocale(LC_TIME,NULL);
	save_time = loc ? pstrdup(loc) : NULL;

#endif

	plperl_interp = perl_alloc();
	if (!plperl_interp)
		elog(ERROR, "could not allocate Perl interpreter");

	perl_construct(plperl_interp);
	perl_parse(plperl_interp, plperl_init_shared_libs, 3, embedding, NULL);
	perl_run(plperl_interp);

	plperl_proc_hash = newHV();

#ifdef WIN32

	eval_pv("use POSIX qw(locale_h);", TRUE); /* croak on failure */

	if (save_collate != NULL)
	{
		snprintf(buf, sizeof(buf),"setlocale(%s,'%s');",
				 "LC_COLLATE",save_collate);
		eval_pv(buf,TRUE);
		pfree(save_collate);
	}
	if (save_ctype != NULL)
	{
		snprintf(buf, sizeof(buf),"setlocale(%s,'%s');",
				 "LC_CTYPE",save_ctype);
		eval_pv(buf,TRUE);
		pfree(save_ctype);
	}
	if (save_monetary != NULL)
	{
		snprintf(buf, sizeof(buf),"setlocale(%s,'%s');",
				 "LC_MONETARY",save_monetary);
		eval_pv(buf,TRUE);
		pfree(save_monetary);
	}
	if (save_numeric != NULL)
	{
		snprintf(buf, sizeof(buf),"setlocale(%s,'%s');",
				 "LC_NUMERIC",save_numeric);
		eval_pv(buf,TRUE);
		pfree(save_numeric);
	}
	if (save_time != NULL)
	{
		snprintf(buf, sizeof(buf),"setlocale(%s,'%s');",
				 "LC_TIME",save_time);
		eval_pv(buf,TRUE);
		pfree(save_time);
	}

#endif

}


static void
plperl_safe_init(void)
{
	SV		   *res;
	double		safe_version;

	res = eval_pv(SAFE_MODULE, FALSE);	/* TRUE = croak if failure */

	safe_version = SvNV(res);

	/*
	 * We actually want to reject safe_version < 2.09, but it's risky to
	 * assume that floating-point comparisons are exact, so use a slightly
	 * smaller comparison value.
	 */
	if (safe_version < 2.0899)
	{
		/* not safe, so disallow all trusted funcs */
		eval_pv(SAFE_BAD, FALSE);
	}
	else
	{
		eval_pv(SAFE_OK, FALSE);
	}

	plperl_safe_init_done = true;
}

/*
 * Perl likes to put a newline after its error messages; clean up such
 */
static char *
strip_trailing_ws(const char *msg)
{
	char	   *res = pstrdup(msg);
	int			len = strlen(res);

	while (len > 0 && isspace((unsigned char) res[len - 1]))
		res[--len] = '\0';
	return res;
}


/* Build a tuple from a hash. */

static HeapTuple
plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
{
	TupleDesc	td = attinmeta->tupdesc;
	char	  **values;
	SV		   *val;
	char	   *key;
	I32			klen;
	HeapTuple	tup;

	values = (char **) palloc0(td->natts * sizeof(char *));

	hv_iterinit(perlhash);
	while ((val = hv_iternextsv(perlhash, &key, &klen)))
	{
		int			attn = SPI_fnumber(td, key);

		if (attn <= 0 || td->attrs[attn - 1]->attisdropped)
			ereport(ERROR,
					(errcode(ERRCODE_UNDEFINED_COLUMN),
					 errmsg("Perl hash contains nonexistent column \"%s\"",
							key)));
		if (SvOK(val) && SvTYPE(val) != SVt_NULL)
			values[attn - 1] = SvPV(val, PL_na);
	}
	hv_iterinit(perlhash);

	tup = BuildTupleFromCStrings(attinmeta, values);
	pfree(values);
	return tup;
}

/*
 * convert perl array to postgres string representation
 */
static SV  *
plperl_convert_to_pg_array(SV *src)
{
	SV		   *rv;
	int			count;

	dSP;

	PUSHMARK(SP);
	XPUSHs(src);
	PUTBACK;

	count = call_pv("::_plperl_to_pg_array", G_SCALAR);

	SPAGAIN;

	if (count != 1)
		elog(ERROR, "unexpected _plperl_to_pg_array failure");

	rv = POPs;

	PUTBACK;

	return rv;
}


/* Set up the arguments for a trigger call. */

static SV  *
plperl_trigger_build_args(FunctionCallInfo fcinfo)