pi3perl.cpp

mini http server,可以集成嵌入到程序中,实现简单的web功能

/*____________________________________________________________________________*\
 *

 Copyright (c) 1997-2003 John Roy, Holger Zimmermann. All rights reserved.

 These sources, libraries and applications are
 FREE FOR COMMERCIAL AND NON-COMMERCIAL USE
 as long as the following conditions are adhered to.

 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions
 are met:

 1. Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer. 

 2. Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution.

 3. The name of the author may not be used to endorse or promote products
    derived from this software without specific prior written permission. 

 THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
 WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
 OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
 IN NO EVENT SHALL THE AUTHORS OR ITS CONTRIBUTORS BE LIABLE FOR ANY
 DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
 GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
 STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
 OF THE POSSIBILITY OF SUCH DAMAGE.

 *____________________________________________________________________________*|
 *
 * $Source: /cvsroot/pi3web/Pi3Web_200/Source/Pi3Perl/Pi3Perl.cpp,v $
 * $Date: 2003/05/13 18:42:11 $
 *
 Description:
	Execute an ISAPI plugin.

\*____________________________________________________________________________*/
//$SourceTop:$

#define PITHREAD_H_
#include <iostream.h>
#include <stdio.h>
#include "HandBase.h"
#include "HTTPCore.h"
#include "HTTPUtil.h"
#include "PIStrStr.h"
#include "DeQuote.h"
#include "PiAPI.h"
#include <EXTERN.h>
#include <perl.h>

/*
** #define D { cerr << __FILE__ << ": " << __LINE__ << endl; }
*/
#define D

/*____________________________________________________________________________*\
 *
 Description:
\*____________________________________________________________________________*/
#define KEY_CONF_INIT				"Init"
#define KEY_CONF_DESTROY			"Destroy"
#define KEY_CONF_EXEC				"Execute"
#define KEY_CONF_FILE				"File"
#define KEY_CONF_DESTRUCTLEVEL		"DestructLevel"

/*____________________________________________________________________________*\
 *
 Description:
\*____________________________________________________________________________*/
#if 0
	/*
	** HTML documentation for this handler
	*/
/*___+++HTMLDOC_BEGIN+++___*/
Name:
	Pi3Perl

Description:
	Load and execute an Pi3Perl script extension.

Options:

<TABLE BORDER=1>
<TH>Option
<TH>Default
<TH>Values
<TH>Short Description
<TH>Example(s)

<TR>
<TD>Init
<TD>-
<TD>Any subroutine name in Pi3Perl file
<TD>Define a perl sub to be called for initialisation
<TD>Init=&quot;init&quot;

<TR>
<TD>Destroy
<TD>-
<TD>Any subroutine name in Pi3Perl file
<TD>Define a perl sub to be called for destruction
<TD>Destroy=&quot;destroy&quot;

<TR>
<TD>Excute
<TD>+
<TD>Any subroutine name in Pi3Perl file
<TD>Define a perl sub to be called for execution
<TD>Execute=&quot;exec&quot;

<TR>
<TD>File
<TD>+
<TD>Any valid (.pl) file name
<TD>Define a Pi3Perl script to be loaded and executed
<TD>File=&quot;../Pi3Perl/snoopdb.pl&quot;

<TR>
<TD>DestructLevel
<TD>-
<TD>0, 1
<TD>define destruction level for perl interpreters
<TD>DestructLevel 1

</TABLE>
<STRONG>-</STRONG> in the <IT>default</IT> indicates no default<BR>
<STRONG>+</STRONG> in the <IT>default</IT> indicates the field is mandatory<BR>

<H4>Description of Options</H4>
<H5>Init</H5>
After successful run of the perl parser during startup, the Init subroutine
is called. This is only done, if the optional Init parameter is set. The Init
sub will get the Pi3 object as a parameter from the perl stack. One scalar
return value is expected to get back by Pi3Web, either to contain PIAPI_COMPLETED
or PIAPI_ERROR.

<H5>Destroy</H5>
The Destroy subroutine is called during server shutdown for cleanup. This is only
done, if the optional Destroy parameter is set. The Destroy sub will get the Pi3
object as a parameter from the perl stack. One scalar return value is expected
to get back by Pi3Web, either to contain PIAPI_COMPLETED or PIAPI_ERROR.

<H5>Execute</H5>
During request, the perl subroutine, given as the value of this configuration key
is executed. The Execute sub will get the Pi3 object, the PIHTTP object and the
PIIOBuffer object as parameters from the perl stack. One scalar return value is
expected to get back by Pi3Web, either to contain PIAPI_COMPLETED or PIAPI_ERROR.

<H5>File</H5>
The given file will be loaded during Pi3Web startup. The file is parsed by perl
and the server will not start, if the parser fails.

<H5>DestructLevel</H5>
A value of 1 will force the explicite destruction of used perl interpreter
instances during server shutdown. This may currently cause server crashes.
A value of 0 (default, recommended) does nothing on shutdown.

Phase:
	HANDLE

Returns:
	PIAPI_COMPLETED or PIAPI_ERROR according to the status returned by the extension.

Note:
	For the PSP language specification refer to the respective Pi3-HOWTO page.

Example:
	<PRE>
	&lt;Object&gt;
		Name P3P
		Class FlexibleHandlerClass
		Condition &quot;&cmp(&dblookup(response,string,ObjectMap),PSP)&quot;
		CheckPath ReturnCode ReturnCode=COMPLETED
		CheckType ReturnCode ReturnCode=COMPLETED
		CheckAccess AccessByFile RequirePermissions=&quot;X&quot;
		Handle Pi3Perl File=&quot;../Pi3Perl/snoopdb.pl&quot; Pi3Perl Execute=&quot;execute&quot;
	&lt;/Object&gt;
	</PRE>

A Pi3Perl file to perform Http redirects:
<PRE>
	use strict;
	use Pi3;

	sub execute {
		my($obj) = shift;
		my($pihttp) = shift;
		my($iobuf) = shift;
		my($r) = Pi3::PIHTTP_getDB($pihttp, &Pi3::GETDB_RESPONSE);

		# Set the location header and the appropriate StatusCode (302 Found)
		my($l) = &quot;http://localhost&quot;.Pi3::PIDB_lookup($r,&Pi3::PIDBTYPE_STRING,&quot;PathInfo&quot;,&Pi3::PIDBFLAG_NONE);
		Pi3::PIDB_replace($r,&Pi3::PIDBTYPE_RFC822,&quot;Location&quot;,$l,&Pi3::PIDBFLAG_NONE);
		Pi3::HTTPUtil_doHTTPError($pihttp,&Pi3::ST_FOUND);

		# Send HTTP status line and response headers
		Pi3::HTTPCore_sendGeneralHeaders($pihttp);
		Pi3::HTTPCore_sendEntityHeaders($pihttp, $r);
		return &Pi3::PIAPI_COMPLETED;
	}
</PRE>

/*___+++HTMLDOC_END+++___*/
#endif

EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);

EXTERN_C void
 xs_init(pTHX)
 {
        char *file = __FILE__;
        /* DynaLoader is a special case */
        newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 }

/*____________________________________________________________________________*\
 *
 Class:
 Description:
\*____________________________________________________________________________*/
class Pi3Perl : public HandlerBasePi3Perl
{
private:
	PerlInterpreter *my_perl;
	int iDestructLevel;
	PIString sPerlFile;
	PIString sInit;
	PIString sDestroy;
	PIString sExecute;
	/* ---
	Configuration data
	--- */

int doInit(const char *pFnInit)
	{
	char *args[] = { NULL };
	PERL_SET_CONTEXT(my_perl);
	
	PIOStrStream os;
	os << "Pi3Perl: ";

	dSP;                            /* initialize stack pointer      */
	ENTER;                          /* everything created after here */
	SAVETMPS;                       /* ...is a temporary variable.   */
	PUSHMARK(SP);                   /* remember the stack pointer    */
	SV *ref = sv_setref_iv(newSViv(0), "const PIObjectPtr", (long)Object());
	XPUSHs(sv_2mortal(ref));
	PUTBACK;                        /* make local stack pointer global */
	if ( call_pv(pFnInit, G_SCALAR) != 1 )      /* call the function             */
		{
		os << "Perl subroutine  '" << pFnInit
			<< "()' returned wrong number of scalar arguments in file '"
			<< (const char *)sPerlFile
			<< "'." << ends;
		CONFIG_ERR( Object(), os.str() );
		return 0;
		};
	SPAGAIN;                        /* refresh stack pointer         */
	if ( POPi != PIAPI_COMPLETED )  /* pop the return value from stack */
		{
		os << "Perl subroutine '" << pFnInit
			<< "()' returned with error in file '"
			<< (const char *)sPerlFile
			<< "'." << ends;
		CONFIG_ERR( Object(), os.str() );
		return 0;
		};
	PUTBACK;
	FREETMPS;                       /* free that return value        */
	LEAVE;
	return 1;
	};

int doExec(const char *pFnExec, PIHTTP *pPIHTTP, PIIOBuffer *pBuffer)
	{
	char *args[] = { NULL };

	PERL_SET_CONTEXT(my_perl);
	dSP;                            /* initialize stack pointer      */
	ENTER;                          /* everything created after here */
	SAVETMPS;                       /* ...is a temporary variable.   */
	PUSHMARK(SP);                   /* remember the stack pointer    */
	SV *ref = sv_setref_iv(newSViv(0), "const PIObjectPtr", (long)Object());
	XPUSHs(sv_2mortal(ref));
	SV *ref1 = sv_setref_iv(newSViv(0), "PIHTTPPtr", (long)pPIHTTP);
	XPUSHs(sv_2mortal(ref1));
	SV *ref2 = sv_setref_iv(newSViv(0), "PIIOBufferPtr", (long)pBuffer);
	XPUSHs(sv_2mortal(ref2));
	PUTBACK;                        /* make local stack pointer global */
	if ( call_pv(pFnExec, G_SCALAR) != 1  )      /* call the function             */
		{
		/* --- an error occurred --- */
		HTTPCore_logError( pPIHTTP, "Pi3Perl: \
Perl subroutine '%s()' returned wrong number of arguments in file '%s'.",
			pFnExec, (const char *)sPerlFile);
		return HTTPUtil_doHTTPError( pPIHTTP, ST_INTERNALERROR );			
		};
	SPAGAIN;                        /* refresh stack pointer         */
	int iRet = POPi;                /* pop the return value from stack */
	PUTBACK;
	FREETMPS;                       /* free that return value        */
	LEAVE;
	if (iRet == PIAPI_ERROR)
		{
		HTTPCore_logError( pPIHTTP, "Pi3Perl: \
Perl subroutine '%s()' returned with PIAPI_ERROR in file '%s'.",
			pFnExec, (const char *)sPerlFile);
		return HTTPUtil_doHTTPError( pPIHTTP, ST_INTERNALERROR );
		}
	else 
		{
		return iRet;
		};
	};

int doDestroy(const char *pFnDestroy)
	{
	char *args[] = { NULL };
	PERL_SET_CONTEXT(my_perl);
	
	PIOStrStream os;
	os << "Pi3Perl: ";

	dSP;                            /* initialize stack pointer      */
	ENTER;                          /* everything created after here */
	SAVETMPS;                       /* ...is a temporary variable.   */
	PUSHMARK(SP);                   /* remember the stack pointer    */
	SV *ref = sv_setref_iv(newSViv(0), "const PIObjectPtr", (long)Object());
	XPUSHs(sv_2mortal(ref));
	PUTBACK;                        /* make local stack pointer global */
	if ( call_pv(pFnDestroy, G_SCALAR) != 1 )      /* call the function             */
		{
		os << "Perl subroutine  '" << pFnDestroy
			<< "()' returned wrong number of scalar arguments in file '"
			<< (const char *)sPerlFile
			<< "'." << ends;
		CONFIG_ERR( Object(), os.str() );
		return 0;
		};
	SPAGAIN;                        /* refresh stack pointer         */
	if ( POPi != PIAPI_COMPLETED )  /* pop the return value from stack */
		{
		os << "Perl subroutine '" << pFnDestroy
			<< "()' returned with error in file '"
			<< (const char *)sPerlFile
			<< "'." << ends;
		CONFIG_ERR( Object(), os.str() );
		return 0;
		};
	PUTBACK;
	FREETMPS;                       /* free that return value        */
	LEAVE;
	return 1;
	};

protected:
int Parameter( const char *pVariable, const char *pValue,
	const char *pWhere )
	{
		assert( pVariable && pValue );
		PIOStrStream os;
		os << pWhere << "Pi3Perl: ";
		if ( !PIUtil_stricmp( KEY_CONF_INIT, pVariable ) )
			{
			sInit = (const char *)DeQuote(pValue);
			}
		else if ( !PIUtil_stricmp( KEY_CONF_DESTROY, pVariable ) )
			{
			sDestroy = (const char *)DeQuote(pValue);
			}
		else if ( !PIUtil_stricmp( KEY_CONF_EXEC, pVariable ) )
			{
			sExecute = (const char *)DeQuote(pValue);
			}
		else if ( !PIUtil_stricmp( KEY_CONF_FILE, pVariable ) )
			{
			sPerlFile = (const char *)DeQuote( pValue );
			char *args[] = { "", NULL, NULL };
			args[1] = (char *)(const char *)sPerlFile;
			PERL_SET_CONTEXT(my_perl);
			if (int iRet = perl_parse(my_perl, xs_init, 2, args, NULL))
				{
				os << "Call to 'perl_parse' returned with error "
					<< iRet << " in file '"
					<< (const char *)sPerlFile
					<< "'." << ends;
				CONFIG_ERR( Object(), os.str() );
				return 0;
				};
			}
		else if ( !PIUtil_stricmp( KEY_CONF_DESTRUCTLEVEL, pVariable ) )
			{
			iDestructLevel = atoi( pValue );
			}
		else
			{
			// We add all unknown config variables to the Object DB
			PIDB_add(PIObject_getDB( Object()), PIDBTYPE_RFC822, pVariable,
				(void *)(const char *)DeQuote( pValue ), 0);
			};
		
		return 1;
	};

public:
	Pi3Perl( PIObject *pObject, int iArgc, const char *ppArgv[] )
	:	HandlerBasePi3Perl( pObject ),
		my_perl( perl_alloc() ),
		iDestructLevel( 0 )
		{
		PL_perl_destruct_level = 1;
		if ( my_perl ) {
			PERL_SET_CONTEXT(my_perl);
			perl_construct(my_perl);
		} else {
			SetOK(0);
		};

		ReadParameters( iArgc, ppArgv );

		if (IsOK() && sInit.Len() > 0)
			{
			SetOK( doInit((const char *)sInit));
			}
	};

~Pi3Perl()
	{
		PERL_SET_CONTEXT(my_perl);
		if (sDestroy.Len() > 0)
			doDestroy((const char *)sDestroy);
		if (iDestructLevel == 1) {
			perl_destruct(my_perl);
//			PERL_SET_CONTEXT(my_perl);
			perl_free(my_perl);
		};
		my_perl = 0;
	};

int Handle( int iPhase, PIHTTP &tPIHTTP, PIIOBuffer &tBuffer )
	{
		if ( sExecute.Len() > 0) {
			return doExec((const char *)sExecute, &tPIHTTP, &tBuffer);
		} else {
		HTTPCore_logError( &tPIHTTP, "Pi3Perl: \
No Perl subroutine 'execute' found in file '%s'", (const char *)sPerlFile);
		return HTTPUtil_doHTTPError( &tPIHTTP, ST_INTERNALERROR );
		};
	};

};


/*____________________________________________________________________________*\
 *
 Function:
 Synopsis:
 Description:
\*____________________________________________________________________________*/
PUBLIC_PIAPI int Pi3Perl_constructor( PIObject *pObj,
	int iArgc, const char *ppArgv[] )
{
	return HandlerBasePi3Perl_constructor( pObj, PI_NEW( Pi3Perl( pObj,
		iArgc, ppArgv ) ) );
}

#if 0
/*___+++CNF_BEGIN+++___*/
	<Class>
		Name Pi3PerlClass
		Type LogicExtension
		Library Pi3Perl
		OnClassLoad HandlerBasePi3Perl_onClassLoad
		Constructor Pi3Perl_constructor
		CopyConstructor HandlerBasePi3Perl_copyConstructor
		Destructor HandlerBasePi3Perl_destructor
		Execute HandlerBasePi3Perl_execute
	</Class>

	<Object>
		Name Pi3Perl
		Class Pi3PerlClass
	</Object>

/*___+++CNF_END+++___*/
#endif