/*
 * This program is an HPSS application for running perl-based web scripts.
 * The perl interpreter is called directly by his program (embedded perl)
 * rather than by running the perl.exe image
 *
 * 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
 * Perl Version:  5.6.0
 *
 * Revised:	16-JUL-2000	Use serverapp extension.
 */

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

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

#include <jpidef.h>
int LIB$INIT_TIMER(), LIB$SHOW_TIMER(), LIB$GETJPI();
#include "serverapp.h"
#include "hpss_share.h"

static void xs_init (pTHX);
/*
 * Global variables.  param struct holds values from command line options
 */
static int my_hpss;			/* hpss context handle */
static int alt_output_state;
static struct {
    int show_stats;			/* Use timer if true */
    int show_connects;
    int destruct_level;			/* perl destruct level to use */
    int memory_limit;			/* max grown allowed */
} param = {
    0, 0, 0,				/* default to disabled */
    -1					/* no memory limit */
};
/*
 * Make alternate routine for writing bytes to CGI output stream.
 * return value is number of bytes written.
 */
static int alt_output ( char *buffer, int length )
{
    int i, seg, xfer, status;

    if ( alt_output_state == 0 ) alt_output_state = 1;	/* some output sent */

    if ( param.show_connects > 1 ) {
	printf ( "/alt_output/ length: %d\n", length );
    }
    status = hpss_write_c ( &my_hpss, buffer, length, 0 );
    if ( (status&1) == 0 ) {
	return -1;
    }
    return length;
}
/*
 * 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, status;
    status = hpss_read_c ( &my_hpss, buffer, bufsize, &length );
    if ( param.show_connects > 1 ) 
	printf("/alt_input/ Bufsize %d, length read: %d\n", 
		bufsize, length );
    if ( (status&1) == 0 ) length = 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;
   int status, length;
   static char value[8192];

   status = hpss_getenv_c ( &my_hpss, (char *) var, value, sizeof(value)-1,
	&length );
   if ( param.show_connects > 1 ) 
	printf("Fetched env '%s', status: %d\n", var, status );
   if ( (status&1) == 1 ) {
	result = value;
   } else {
	result = (char *) 0;
   }
   return result;
}
/***************************************************************************/
/* The execute_script function has the job of loading and executing a
 * perl source file specified by the caller.  The result of the execution
 * will send a CGI response to the currently open HPSS connection.
 *
 * Return value is a VMS-style condition code, 1 for success.
 */
static int execute_script ( PerlInterpreter *my_perl, char *script, char
	*errmsg )
{
    SV *code;
    HV *stash;
    int i, pos, status, tlen, talloc, seg, xfer, start;
    FILE *sf;
    char *text;
    char namespace_name[512];
    /*
     * Make sure specific script exists
     */
    sf = fopen ( script, "r" );
    if ( !sf ) {
	strcpy ( errmsg, "Error opening file\n" );
	return 44;
    }
    errmsg[0] = '\0';
    /*
     * Run the script in a private namespace.  Convert the script name
     * string into a legal space name.
     */
    strcpy ( namespace_name, "HPSS::NS::" );
    pos = strlen ( namespace_name );
    for (i = (script[0] == '/') ? 1 : 0; 
		script[i] && (pos < sizeof(namespace_name)-1); i++ ) {
	if ( script[i] == '/' ) {
	    namespace_name[pos++] = ':';
	    namespace_name[pos++] = ':';
	} else if ( script[i] == '.' ) {
	    namespace_name[pos++] = '_';
	} else namespace_name[pos++] = script[i];
    }
    namespace_name[pos] = '\0';
    status = 1;
    /*
     * read the script into temporary storage, putting a wrapper around
     * the contents so the script becomes a package.
     */
    talloc = 4000;
    text = malloc ( talloc );
    sprintf ( text, "package %s;\n#line 1 %s", namespace_name, script );
    start = strlen ( text );
    xfer = 1;
    for ( tlen = strlen(text); xfer > 0; tlen += xfer ) {
	/*
	 * Try to read to fill remaining space but leave 200 byte for
	 * putting trailer on end.
	 */
	seg = talloc - tlen;
	if ( seg <= 200 ) {
	    /*
	     * Buffer full, expand.
	     */
	    talloc += 20000;
	    text = realloc ( text, talloc );
	    seg = talloc - tlen;
	}
	xfer = fread ( &text[tlen], sizeof(char), seg-200, sf );
    }
    /*
     * Scan first line of the script second text line) for a comment 
     * containing a -w and append a $^W initializer (apache compatibility).
     */
    sprintf ( &text[tlen], "\n" ); tlen += strlen(&text[tlen]);
    if ( text[start] == '#' ) {
        for ( i = start; i < tlen; i++ ) if ( text[i] == '\n' ) {
	    text[i] = '\0';	/* temporarily terminate line */
	    if ( strstr (  &text[start], "-w" ) ) {
		strcpy ( &text[tlen], "BEGIN {$^W = 1;}; $^W = 1;\n" );
		tlen += strlen ( &text[tlen] );
	    }
	    text[i] = '\n';	/* restore original character */
	}
    }
    /* fwrite ( text, 1, tlen, stdout ); */
    /*
     * Make the script into a perl scalar and execute.
     */
    ENTER;
    SAVETMPS;
    code = newSV(0);
    sv_usepvn ( code, text, tlen );
    code = sv_2mortal ( code );		/* mark for delete */

    i = eval_sv ( code, G_DISCARD );
    /* Flush the namespace */
    stash = gv_stashpv ( namespace_name, FALSE );
    if ( stash ) hv_clear ( stash );
    else printf ( "  *** attempt to delete non-existent namespace '%s'\n",
	namespace_name );
    FREETMPS;
    LEAVE;
    return 1;
}
/***************************************************************************/
/* Parse command line and build param array.  Return argument vector for
 * feeding to perl interpreter.
 */
static int process_command_line ( int argc, char **argv, int *perl_argc,
	char ***perl_argv )
{
    int virt_argc, i;
    char **virt_argv;
    /*
     * Scan argv for switches.
     */
    virt_argv = malloc ( sizeof(char *) * (argc+8) );
    virt_argv[0] = argv[0];		/* image name */
    for ( virt_argc = i = 1; i < argc; i++ ) {
	if ( argv[i][0] != '-' ) {
	    /*
	     * Copy verbatim.
	     */
	    virt_argv[virt_argc++] = argv[i];

	} else if ( (strcmp(argv[i],"-pflag") == 0) && ((i+1)<argc) ) {
	    /*
	     * Next argument is perl flag to pass verbatim.
	     */
	    i++;
	    virt_argv[virt_argc++] = argv[i];

	} else if ( strcmp(argv[i],"-stats") == 0 ) {
	    param.show_stats = 1;
	} else if ( (strcmp(argv[i],"-trace") == 0) && ((i+1) < argc) ) {
	    i++;	/* skip to next argument */
	    param.show_connects = atoi(argv[i]);
	} else if ( (strcmp(argv[i],"-mlimit") == 0) && ((i+1) < argc) ) {
	    i++;	/* skip to next argument */
	    param.memory_limit = atoi(argv[i]);
	} else {
	    fprintf(stderr,"Usage: hpss_perl [flags]\n%s\n%s\n%s\n%s\n",
		"   -mlimit nnn  Limit to growth",
		"   -pflag opt   Perl option.",
		"   -stats       Set statistics monitoring.",
		"   -trace n     Set trace to level n" );
	    return 0;
	}
    }
    /*
     * Append perl switches load serverapp module and print startup banner.
     */
    virt_argv[virt_argc++] = "-e";
    virt_argv[virt_argc++] = malloc ( strlen(serverapp_module_def)+1 );
    strcpy ( virt_argv[virt_argc-1], serverapp_module_def );

    virt_argv[virt_argc++] = "-e";
    virt_argv[virt_argc++] = "print 'Perl Interpreter started\n'";
    virt_argv[virt_argc] = (char *) 0;
    /*
     * Return final result to caller.
     */
    *perl_argc = virt_argc;
    *perl_argv = virt_argv;
    return 1;
}
/***************************************************************************/
int main(int argc, char **argv, char **env)
{
    int status, pid, virt_argc, sn_len, exitstatus, i, count, jpi_code;
    char subfunc[32], script_name[256], value[256], symbol_list[1024];
    char errmsg[256];
    char *var, *p0_limit, *peak_high_p0, *high_p0, **virt_argv;
    PerlInterpreter *my_perl;
    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
    /*
     * Parse command line and produce argument list for setting perl options.
     */
    status = process_command_line ( argc, argv, &virt_argc, &virt_argv );
    if ( (status&1) == 0 ) return 44;
    /*
     * Declare ourselves an HPSS server and perform 1-time Perl initialization.
     */
    if ( param.show_stats ) LIB$INIT_TIMER();
    status = hpss_initialize_c ( "HPSS_SRV_PERL/POOL=WORKER", 0, &my_hpss );
    if ( (status&1) == 0 ) return status;

    if ( status&1 ) {
	/*
	 * Allocate and construct a perl interpreter object.  All scripts will
	 * live in the same interpreter environment - potentially unsafe but
	 * creating a new interpreter each time is too costly.
	 */
	PERL_SYS_INIT3(&virt_argc,&virt_argv,&env);
	my_perl = perl_alloc();
	if (!my_perl) exit(44);	/* fatal error */
	perl_construct(my_perl);
	PL_perl_destruct_level = param.destruct_level;
	/*
	 * Execute initial perl code to bootstrap the ServerApp module.
	 */
	exitstatus = perl_parse( my_perl, xs_init,
		virt_argc, virt_argv, (char **) NULL );
	if ( exitstatus == 0 ) exitstatus = perl_run ( my_perl );
	else {
	    printf ( "Command line parse failed: %d\n", exitstatus );
	    return exitstatus;
	}
	/*
	 * Redirect the standard I/O so it is handled by our callbacks.
	 */
	serverapp_hijack_std_streams (alt_output, alt_input, alt_getenv);
    }
    /*
     * Get current end of P0 virtual memory and set limit.
     */
    jpi_code = JPI$_FREP0VA;
    status = LIB$GETJPI ( &jpi_code, 0, 0, &high_p0, 0, 0 );
    peak_high_p0 = high_p0;
    if ( param.memory_limit > 0 ) p0_limit = &high_p0[param.memory_limit];
    /*
     * Main loop, service successive requests, no timeouts.
     */
    while ( status&1 ) {
	/*
	 * Check process resources for leaks.
	 */
	status = LIB$GETJPI ( &jpi_code, 0, 0, &high_p0, 0, 0 );
	if ( param.memory_limit > 0 ) if ( high_p0 > p0_limit ) {
	    fprintf(stderr, "Memory expansion exceeded %d, exiting\n",
		param.memory_limit);
	    break;
	}
	/*
         * Show execution stats, first time will show startup stats,
	 * subseqent passes will show request processing stats.
	 */
	if ( param.show_stats ) {
	    LIB$SHOW_TIMER();
	    if ( high_p0 > peak_high_p0 ) {
		printf ( " *** new peak highest non-stack address: %x\n",
			high_p0 );
		peak_high_p0 = high_p0;
	    }
	}
	/*
	 * Wait for next connection.
	 */
	status = hpss_accept_c ( &my_hpss, 0, &pid, subfunc, sizeof(subfunc) );
	if ( (status&1) == 1 ) {
	    char script_name[256];
	    /*
	     * Get the script name from the CGI variable list.
	     */
	    status = hpss_getenv_c ( &my_hpss, "SCRIPT_NAME", 
		script_name, sizeof(script_name)-1, &sn_len );
	    if ( (status&1) == 0 ) {
		status = hpss_printf_c ( &my_hpss, 
		    "%s\n%s\n\n%s, code: %d\n",
		    "Status: 400 HPSS error",
		    "Content-type: text/plain",
		    "Failure returned by getenv_c(SCRIPT_NAME)",
		    virt_argv[virt_argc-1], exitstatus );
		continue;
	    }
	    if ( param.show_connects ) 
		printf("New connection from %x, %s, script: %s\n", pid, subfunc,
		script_name );
	    if ( param.show_stats ) LIB$INIT_TIMER();
	    /*
	     * Execute the script target script as a perl program.  Assume 
	     * the SCRIPT_NAME CGI variable is a valid path to the script 
	     * (logical name should be defined for script_path pseudo-directory.
	     */
	    alt_output_state = 0;
	    exitstatus = execute_script ( my_perl, script_name, errmsg );

	    if ( (exitstatus &1) == 0 ) {
		/*
		 * Load failed, return error message to client.
		 */
		hpss_printf_c ( &my_hpss, "%s\n%s\n\n%s%s, code: %d\nmsg: %s\n",
		    "Status: 400 parse error",
		    "Content-type: text/plain",
		    "Failure returned by perl_parse, script ",
		    script_name, exitstatus, errmsg );
	    } else if ( alt_output_state == 0 ) {
		/*
		 * No errors reported, but no output generated.
		 */
		hpss_printf_c ( &my_hpss, "%s\n%s\n\n%s%s\n",
		    "Status: 400 script error",
		    "Content-type: text/plain",
		    "No output produced by script ", script_name );
	    }
	    /*
	     * Cleanup.  Close client connection first so client can continue
	     * while we are destroying perl interpreter.
	     */
	    hpss_disconnect ( &my_hpss );
	}
    }
    /*
     * Cleanup perl runtime and exit.
     */
    if ( param.show_stats ) LIB$SHOW_TIMER();
    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);
}
