/*
 * This program is an embedded perl application intended to be invoked
 * by the wwwexec scriptserver in order to run scripts.  The starting point
 * for this program is the perlmain.c program produced by the perl distribution
 * make process.
 *
 * DCL symbol input:
 *    P1		HTTP method.
 *    P2		url path that invoked the script.
 *    P3		HTTP protocol version.
 *
 * Command line arguments:
 *   script-file	VMS filename of perl script to execute.
 *
 *
 * Author:	David Jones
 * Date:	10-JUL-2000
 * Revised:	29-JAN-2002	Fixup alt_getenv to supply dummy content_length
 *				and alt_input to allow zero-length reads.
 * Perl Version:  5.6.0
 */

#ifdef OEMVS
#pragma runopts(HEAP(1M,32K,ANYWHERE,KEEP,8K,4K))
#endif

#include "EXTERN.h"
#define PERL_IN_MINIPERLMAIN_C
#include "perl.h"

#include "serverapp.h"

#include "cgilib.h"

static void xs_init (pTHX);
static PerlInterpreter *my_perl;
/*
 * Make alternate routine for writing bytes to CGI output stream.
 * return value is number of bytes written.
 */
static int debug_alt = 0;
static char outbuf[1000];
static int outbuf_len;
static int alt_output ( char *buffer, int length )
{
    int i, seg, xfer;
    for ( i = 0; i < length; i += xfer ) {
	seg = sizeof(outbuf)-outbuf_len; 
	if ( seg > (length-i) ) seg = length - i;
	if ( (outbuf_len == 0) && (seg == sizeof(outbuf)) ) {
	    /* Optimized case, skip copying segment */
	    xfer = cgi_write ( &buffer[i], seg );
	} else {
	    /* Append to buffer and flush if full */
	    memcpy ( &outbuf[outbuf_len], &buffer[i], seg );
	    outbuf_len += seg;
	    xfer = seg;
	    if ( outbuf_len >= sizeof(outbuf) ) {
		seg = cgi_write ( outbuf, outbuf_len );
		outbuf_len = outbuf_len - seg;
		if ( outbuf_len > 0 ) {
		    /* scoot unwritten portion to start of buffer */
		    memmove ( &outbuf[sizeof(outbuf)-outbuf_len],
			outbuf, outbuf_len );
		}
	    }
	}
	if ( xfer < 0 ) break;
    }
    return i;
}
/*
 * Make alternate for getting input from posted content.  Note that
 * We return EOF (-1) on error or end-of-file.
 */
static int alt_input ( char *buffer, int bufsize )
{
    int length;
    length = cgi_read ( buffer, bufsize );
    if ( debug_alt ) printf("/alt_input/ Bufsize %d, length read: %d\n", 
		bufsize, length );
    if ( (length == 0) && (bufsize != 0) ) return EOF;
    return length;
}
/*
 * Make alternate getenv routine that searchs the CGI variable list.
 */
static char *alt_getenv ( const char *var, int sys_flag )
{
   char *result;

   result = cgi_info ( (char *) var );
   if ( !result && var ) {
	if ( strcmp ( var, "CONTENT_LENGTH" ) == 0 ) result = "0";
   } else if ( (*result == '\0') && var ) {
	if ( strcmp ( var, "CONTENT_LENGTH" ) == 0 ) result = "0";
   }
   if ( debug_alt ) printf("/alt_getenv/ cgi_info('%s') = %x (%s)\n", var, 
	result, result ? result : "" );
   return result;
}

int
main(int argc, char **argv, char **env)
{
    int exitstatus;
    int status, virt_argc, i,j, in_switches;
    char **virt_argv;
    static char **perl_argv[5];
#ifdef PERL_GLOBAL_STRUCT
#define PERLVAR(var,type) /**/
#define PERLVARA(var,type) /**/
#define PERLVARI(var,type,init) PL_Vars.var = init;
#define PERLVARIC(var,type,init) PL_Vars.var = init;
#include "perlvars.h"
#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
#endif
    /*
     * Setup CGI environment, which takes command line arguments that normally
     * are supplied by wwwexec as P1,P2,P3.
     */
    status = cgi_synthesize_argv ( argv[0], &virt_argc, &virt_argv );
    if ( (status&1) == 0 ) return status;
    status = cgi_init ( virt_argc, virt_argv );
    if ( (status&1) == 0 ) return status;
    /*
     * Initialize perl environment.
     */
    PERL_SYS_INIT3(&argc,&argv,&env);

    my_perl = perl_alloc();
    if (!my_perl) exit(1);
    perl_construct(my_perl);
    PL_perl_destruct_level = 0;
    /*
     * Redirect the standard I/O so it is handled by our callbacks.
     */
    debug_alt = 0;
    outbuf_len = 0;
    serverapp_hijack_std_streams ( alt_output, alt_input, alt_getenv );
    /*
     * Build a new argument vector to give to perl_parse that explicitly
     * load the ServerApp.pm module.  Insert after any other switches
     * so include directories speicifed by -I switches get are included
     * in module file search.
     */
    virt_argc = argc + 2;
    virt_argv = (char **) malloc ( virt_argc*sizeof(char *) );
    virt_argv[0] = argv[0];
    in_switches = 1;
    for ( i = j = 1; i < argc; i++ ) {
	if ( in_switches ) {
	    if ( argv[i][0] != '-' ) {
		in_switches = 0;
		virt_argv[j++] = "-mServerApp";
	    } else if ( argv[i][1] == 'w' ) {
		if ( strcmp ( argv[i], "-webperl_debug" ) == 0 ) {
		    /* Turn on debugging, remove from list */
		    debug_alt = 1;
		    continue;
		}
	    }
	}
	virt_argv[j++] = argv[i];
    }
    if ( j < virt_argc ) virt_argv[j] = (char *) 0;
    virt_argc = j;
    /*
     * Execute the script.
     */
    exitstatus = perl_parse( my_perl, xs_init, virt_argc, virt_argv, 
		(char **) NULL );
    if (!exitstatus) {
	/*
	 * Execute the parsed perl code.
	 */
	exitstatus = perl_run( my_perl );
    }
    /*
     * Cleanup, flush and rundown.
     */
    if ( outbuf_len > 0 ) cgi_write ( outbuf, outbuf_len );
    perl_destruct( my_perl );
    perl_free( my_perl );

    PERL_SYS_TERM();

    exit( exitstatus );
    return exitstatus;		/* in case exit fails ? */
}

/* Register any extra external extensions */

/* Do not delete this line--writemain depends on it */

static void
xs_init(pTHX)
{
    char *file = __FILE__;
extern void	boot_DynaLoader (pTHX_ CV* cv);
extern void	boot_Socket (pTHX_ CV* cv);
  dXSUB_SYS;
    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
    newXS("Socket::bootstrap", boot_Socket, file);
    newXS("ServerApp::bootstrap", boot_ServerApp, file);
}
