[catagits/fcgi2.git] / perl / FCGI.PL

use Config;

open OUT, ">FCGI.xs";

print "Generating FCGI.xs for Perl version $]\n";
#unless (exists $Config{apiversion} && $Config{apiversion} >= 5.005) 
unless ($] >= 5.005) {
    for (qw(sv_undef diehook warnhook in_eval)) {
	print OUT "#define PL_$_ $_\n" 
    }
}
print OUT while <DATA>;
close OUT;
__END__
/* $Id: FCGI.PL,v 1.4 1999/07/28 16:15:40 skimo Exp $ */

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

#include "fcgiapp.h"

#ifndef FALSE
#define FALSE (0)
#endif

#ifndef TRUE
#define TRUE  (1)
#endif

#ifdef WIN32
#define environ _environ
#endif

extern char **environ;
static char **requestEnviron = NULL;

#ifdef USE_SFIO
typedef struct
{
    Sfdisc_t	disc;
    FCGX_Stream	*stream;
} FCGI_Disc;

static ssize_t
sffcgiread(f, buf, n, disc)
Sfio_t*		f;      /* stream involved */
Void_t*		buf;    /* buffer to read into */
size_t		n;      /* number of bytes to read */
Sfdisc_t*	disc;   /* discipline */
{
    return FCGX_GetStr(buf, n, ((FCGI_Disc *)disc)->stream);
}

static ssize_t
sffcgiwrite(f, buf, n, disc)
Sfio_t*		f;      /* stream involved */
const Void_t*	buf;    /* buffer to read into */
size_t		n;      /* number of bytes to read */
Sfdisc_t*	disc;   /* discipline */
{
    n = FCGX_PutStr(buf, n, ((FCGI_Disc *)disc)->stream);
    FCGX_FFlush(((FCGI_Disc *)disc)->stream);
    return n;
}

Sfdisc_t *
sfdcnewfcgi(stream)
	FCGX_Stream *stream;
{
    FCGI_Disc*	disc;

    New(1000,disc,1,FCGI_Disc);
    if (!disc) return (Sfdisc_t *)disc;

    disc->disc.exceptf = (Sfexcept_f)NULL;
    disc->disc.seekf = (Sfseek_f)NULL;
    disc->disc.readf = sffcgiread;
    disc->disc.writef = sffcgiwrite;
    disc->stream = stream;
    return (Sfdisc_t *)disc;
}

Sfdisc_t *
sfdcdelfcgi(disc)
    Sfdisc_t*	disc;
{
    Safefree(disc);
    return 0;
}
#endif

static int isCGI = -1; /* -1: not checked; 0: FCGI; 1: FCGI */

static FCGX_Request global_fcgx_request;

typedef struct FCGP_Request {
    int		    compat;
    int		    acceptCalled;
    int		    finishCalled;
    SV*		    svin;
    SV*		    svout;
    SV*		    sverr;
    FCGX_Stream*    in;
    FCGX_Request*   requestPtr;
} FCGP_Request;

static FCGP_Request global_request;
static SV*	    global_sverr;

static int 
FCGI_Flush(FCGP_Request* request)
{
    if(!request->compat || !request->acceptCalled || isCGI) {
	return;
    }
#ifdef USE_SFIO
    sfsync(PerlIO_stdout());
    sfsync(PerlIO_stderr());
#else
    FCGX_FFlush((FCGX_Stream *) SvIV((SV*) SvRV(request->svout)));
    FCGX_FFlush((FCGX_Stream *) SvIV((SV*) SvRV(request->sverr)));
#endif
}

static int 
FCGI_Accept(FCGP_Request* request)
{
    if(isCGI == -1) {
        /*
         * First call to FCGI_Accept.  Is application running
         * as FastCGI or as CGI?
         */
        isCGI = FCGX_IsCGI();
    } else if(isCGI) {
        /*
         * Not first call to FCGI_Accept and running as CGI means
         * application is done.
         */
        return(EOF);
    } else {
	if(request->compat && !request->finishCalled) {
#ifdef USE_SFIO
            sfdcdelfcgi(sfdisc(PerlIO_stdin(), SF_POPDISC));
            sfdcdelfcgi(sfdisc(PerlIO_stdout(), SF_POPDISC));
            sfdcdelfcgi(sfdisc(PerlIO_stderr(), SF_POPDISC));
#else
	    FCGI_Flush(request);
#endif
	}
    }
    if(!isCGI) {
        FCGX_ParamArray envp;
	FCGX_Stream *out, *error;
        int acceptResult = FCGX_Accept_r(&request->in, &out, &error, &envp,
				         request->requestPtr);
        if(acceptResult < 0) {
            return acceptResult;
        }
#ifdef USE_SFIO
        sfdisc(PerlIO_stdin(), sfdcnewfcgi(request->in));
        sfdisc(PerlIO_stdout(), sfdcnewfcgi(out));
        sfdisc(PerlIO_stderr(), sfdcnewfcgi(error));
#else
	if (!request->svout) {
	    newSVrv(request->svout = newSV(0), "FCGI");
	    sv_magic((SV *)gv_fetchpv("STDOUT",TRUE, SVt_PVIO), 
			request->svout, 'q', Nullch, 0);
	    newSVrv(request->sverr = newSV(0), "FCGI");
	    sv_magic((SV *)gv_fetchpv("STDERR",TRUE, SVt_PVIO), 
			request->sverr, 'q', Nullch, 0);
	    newSVrv(request->svin = newSV(0), "FCGI");
	    sv_magic((SV *)gv_fetchpv("STDIN",TRUE, SVt_PVIO), 
			request->svin, 'q', Nullch, 0);
	}
	sv_setiv(SvRV(request->svout), (IV) out);
	sv_setiv(SvRV(request->sverr), (IV) error);
	sv_setiv(SvRV(request->svin), (IV) request->in);

	if (request->compat) {
	    global_sverr = request->sverr;
	    if (PL_warnhook) SvREFCNT_dec(PL_warnhook);
	    PL_warnhook = SvREFCNT_inc(GvCV(gv_fetchmethod(Nullhv, "FCGI::WARN")));
	    if (PL_diehook) SvREFCNT_dec(PL_diehook);
	    PL_diehook = SvREFCNT_inc(GvCV(gv_fetchmethod(Nullhv, "FCGI::DIE")));
	}
#endif
	request->finishCalled = FALSE;
        environ = envp;
    }
    request->acceptCalled = TRUE;
    return 0;
}

static void 
FCGI_Finish(FCGP_Request* request)
{
    if(!request->acceptCalled || isCGI) {
	return;
    }
    if (request->compat) {
#ifdef USE_SFIO
	sfdcdelfcgi(sfdisc(PerlIO_stdin(), SF_POPDISC));
	sfdcdelfcgi(sfdisc(PerlIO_stdout(), SF_POPDISC));
	sfdcdelfcgi(sfdisc(PerlIO_stderr(), SF_POPDISC));
#else
	FCGI_Flush(request);
#endif
    }
    request->in = NULL;
    FCGX_Finish_r(request->requestPtr);
    request->finishCalled = TRUE;
#ifndef USE_SFIO
    if (request->compat) {
	if (PL_warnhook == (SV*)GvCV(gv_fetchmethod(Nullhv, "FCGI::WARN"))) {
	    SvREFCNT_dec(PL_warnhook);
	    PL_warnhook = Nullsv;
	}
	if (PL_diehook == (SV*)GvCV(gv_fetchmethod(Nullhv, "FCGI::DIE"))) {
	    SvREFCNT_dec(PL_diehook);
	    PL_diehook = Nullsv;
	}
    }
#endif
}

static int 
FCGI_StartFilterData(FCGP_Request* request)
{
    return request->in ? FCGX_StartFilterData(request->in) : -1;
}

static void
FCGI_SetExitStatus(FCGP_Request* request, int status)
{
    if (request->in) FCGX_SetExitStatus(status, request->in);
}

static FCGP_Request *
FCGI_Request()
{
    FCGX_Request* fcgx_req;
    FCGP_Request* req;

    Newz(551, fcgx_req, 1, FCGX_Request);
    Newz(551, req, 1, FCGP_Request);
    req->requestPtr = fcgx_req;

    return req;
}

static void
FCGI_Release_Request(FCGP_Request *req)
{
    Safefree(req->requestPtr);
    Safefree(req);
}

/*
 * For each variable in the array envp, either set or unset it
 * in the global hash %ENV.
 */
static void
DoPerlEnv(envp, set)
char **envp;
int set;
{
    int i;
    char *p, *p1;
    HV   *hv;
    SV   *sv;
    hv = perl_get_hv("ENV", TRUE);

    if (!set)
	perl_eval_pv("%ENV = %FCGI::ENV", 0);
    else {
	perl_eval_pv("%FCGI::ENV = %ENV", 0);
	for(i = 0; ; i++) {
	    if((p = envp[i]) == NULL) {
		break;
	    }
	    p1 = strchr(p, '=');
	    assert(p1 != NULL);
	    *p1 = '\0';
	    sv = newSVpv(p1 + 1, 0);
	    /* call magic for this value ourselves */
	    hv_store(hv, p, p1 - p, sv, 0);
	    SvSETMAGIC(sv);
	    *p1 = '=';
	}
    }
}


typedef FCGX_Stream *	FCGI;
typedef FCGP_Request *	FCGI__Request;

MODULE = FCGI		PACKAGE = FCGI

BOOT:
    FCGX_Init();
    FCGX_InitRequest(&global_fcgx_request);
    memset(&global_request, 0, sizeof(global_request));
    global_request.compat = 1;
    global_request.requestPtr = &global_fcgx_request;

#ifndef USE_SFIO
void
DIE(msg)
	char *	msg;

	CODE:
	if (!PL_in_eval)
	    FCGX_PutS(msg, (FCGX_Stream *) SvIV((SV*) SvRV(global_sverr)));

void
WARN(msg)
	char *	msg;

	CODE:
	FCGX_PutS(msg, (FCGX_Stream *) SvIV((SV*) SvRV(global_sverr)));

void
PRINT(stream, ...)
	FCGI	stream;

	PREINIT:
	int	n;

	CODE:
	for (n = 1; n < items; ++n) {
            STRLEN len;
            register char *tmps = (char *)SvPV(ST(n),len);
            FCGX_PutStr(tmps, len, stream);
	}
	if (SvTRUEx(perl_get_sv("|", FALSE))) 
	    FCGX_FFlush(stream);

int
WRITE(stream, bufsv, len, ...)
	FCGI	stream;
	SV *	bufsv;
	int	len;

	PREINIT:
	int	offset;
	char *	buf;
	STRLEN	blen;
	int	n;

	CODE:
	offset = (items == 4) ? (int)SvIV(ST(3)) : 0;
	buf = SvPV(bufsv, blen);
	if (offset < 0) offset += blen;
	if (len > blen - offset)
	    len = blen - offset;
	if (offset < 0 || offset >= blen ||
		(n = FCGX_PutStr(buf+offset, len, stream)) < 0) 
	    ST(0) = &PL_sv_undef;
	else {
	    ST(0) = sv_newmortal();
	    sv_setpvf(ST(0), "%c", n);
	}

int
READ(stream, bufsv, len, ...)
	FCGI	stream;
	SV *	bufsv;
	int	len;

	PREINIT:
	int	offset;
	char *	buf;

	CODE:
	offset = (items == 4) ? (int)SvIV(ST(3)) : 0;
	if (! SvOK(bufsv))
	    sv_setpvn(bufsv, "", 0);
	buf = SvGROW(bufsv, len+offset+1);
	len = FCGX_GetStr(buf+offset, len, stream);
	SvCUR_set(bufsv, len+offset);
	*SvEND(bufsv) = '\0';
	(void)SvPOK_only(bufsv);
	SvSETMAGIC(bufsv);
	RETVAL = len;

	OUTPUT:
	RETVAL

SV *
GETC(stream)
	FCGI	stream;

	PREINIT:
	int	retval;

	CODE:
	if ((retval = FCGX_GetChar(stream)) != -1) {
	    ST(0) = sv_newmortal();
	    sv_setpvf(ST(0), "%c", retval);
	} else ST(0) = &PL_sv_undef;

bool
CLOSE(stream)
	FCGI	stream;

	ALIAS:
	DESTROY = 1

	CODE:
	RETVAL = FCGX_FClose(stream) != -1;

	OUTPUT:
	RETVAL

#endif

SV *
request()

    PROTOTYPE:
    CODE:
    RETVAL = Perl_sv_setref_pv(Perl_newSV(0), "FCGI::Request", FCGI_Request());

    OUTPUT:
    RETVAL


int
accept(...)

    PROTOTYPE: ;$***$

    PREINIT:
    FCGP_Request* request = &global_request;
    SV * sv;

    CODE:
    if (items != 0 && items != 5)
	croak("Usage: FCGI::accept() or "
	      "FCGI::accept(request, IN, OUT, ERR, env)");
    if (items) {
	if (sv_isa(ST(0), "FCGI::Request")) {
	    request = (FCGP_Request*) SvIV((SV*)SvRV(ST(0)));
	} else
	    croak("request is not of type FCGI::Request");
	if (SvROK(ST(1)) && isGV(SvRV(ST(1)))) {
	} else
	    croak("IN is not a GLOB reference");
    }
    {
        char **savedEnviron;
        int acceptStatus;
        /*
         * Unmake Perl variable settings for the request just completed.
         */
        if(requestEnviron != NULL) {
            DoPerlEnv(requestEnviron, FALSE);
            requestEnviron = NULL;
        }
        /*
         * Call FCGI_Accept but preserve environ.
         */
        savedEnviron = environ;
        acceptStatus = FCGI_Accept(request);
        requestEnviron = environ;
        environ = savedEnviron;
        /*
         * Make Perl variable settings for the new request.
         */
        if(acceptStatus >= 0 && !FCGX_IsCGI()) {
            DoPerlEnv(requestEnviron, TRUE);
        } else {
            requestEnviron = NULL;
        }
        RETVAL = acceptStatus;
    }
    OUTPUT:
    RETVAL


void
finish(...)

    PROTOTYPE: ;$
    CODE:
    {
        /*
         * Unmake Perl variable settings for the completed request.
         */
        if(requestEnviron != NULL) {
            DoPerlEnv(requestEnviron, FALSE);
            requestEnviron = NULL;
        }
        /*
         * Finish the request.
         */
        FCGI_Finish(&global_request);
    }


void
flush(...)

    PROTOTYPE: ;$
    CODE:
    FCGI_Flush(&global_request);

void
set_exit_status(status,...)

    int status;

    PROTOTYPE: $;$
    CODE:
    FCGI_SetExitStatus(&global_request, status);

int
start_filter_data(...)

    PROTOTYPE: ;$
    CODE:
    RETVAL = FCGI_StartFilterData(&global_request);

    OUTPUT:
    RETVAL

MODULE = FCGI		PACKAGE = FCGI::Request

void
DESTROY(request)
    FCGI::Request   request;

    CODE:
    FCGI_Release_Request(request);
Commit	Line	Data
1b64d24d	1	use Config;
	2
	3	open OUT, ">FCGI.xs";
	4
	5	print "Generating FCGI.xs for Perl version $]\n";
	6	#unless (exists $Config{apiversion} && $Config{apiversion} >= 5.005)
	7	unless ($] >= 5.005) {
	8	for (qw(sv_undef diehook warnhook in_eval)) {
	9	print OUT "#define PL_$_ $_\n"
	10	}
	11	}
	12	print OUT while <DATA>;
	13	close OUT;
	14	__END__
90a18d65	15	/* $Id: FCGI.PL,v 1.4 1999/07/28 16:15:40 skimo Exp $ */
1b64d24d	16
	17	#include "EXTERN.h"
	18	#include "perl.h"
	19	#include "XSUB.h"
	20
	21	#include "fcgiapp.h"
	22
	23	#ifndef FALSE
	24	#define FALSE (0)
	25	#endif
	26
	27	#ifndef TRUE
	28	#define TRUE (1)
	29	#endif
	30
0074e702	31	#ifdef WIN32
	32	#define environ _environ
	33	#endif
	34
1b64d24d	35	extern char **environ;
	36	static char **requestEnviron = NULL;
	37
	38	#ifdef USE_SFIO
	39	typedef struct
	40	{
	41	Sfdisc_t disc;
	42	FCGX_Stream *stream;
	43	} FCGI_Disc;
	44
	45	static ssize_t
	46	sffcgiread(f, buf, n, disc)
	47	Sfio_t* f; /* stream involved */
	48	Void_t* buf; /* buffer to read into */
	49	size_t n; /* number of bytes to read */
	50	Sfdisc_t* disc; /* discipline */
	51	{
	52	return FCGX_GetStr(buf, n, ((FCGI_Disc *)disc)->stream);
	53	}
	54
	55	static ssize_t
	56	sffcgiwrite(f, buf, n, disc)
	57	Sfio_t* f; /* stream involved */
	58	const Void_t* buf; /* buffer to read into */
	59	size_t n; /* number of bytes to read */
	60	Sfdisc_t* disc; /* discipline */
	61	{
	62	n = FCGX_PutStr(buf, n, ((FCGI_Disc *)disc)->stream);
	63	FCGX_FFlush(((FCGI_Disc *)disc)->stream);
	64	return n;
	65	}
	66
	67	Sfdisc_t *
	68	sfdcnewfcgi(stream)
	69	FCGX_Stream *stream;
	70	{
	71	FCGI_Disc* disc;
	72
	73	New(1000,disc,1,FCGI_Disc);
	74	if (!disc) return (Sfdisc_t *)disc;
	75
	76	disc->disc.exceptf = (Sfexcept_f)NULL;
	77	disc->disc.seekf = (Sfseek_f)NULL;
	78	disc->disc.readf = sffcgiread;
	79	disc->disc.writef = sffcgiwrite;
	80	disc->stream = stream;
	81	return (Sfdisc_t *)disc;
	82	}
	83
	84	Sfdisc_t *
	85	sfdcdelfcgi(disc)
	86	Sfdisc_t* disc;
	87	{
	88	Safefree(disc);
	89	return 0;
	90	}
	91	#endif
	92
90a18d65	93	static int isCGI = -1; /* -1: not checked; 0: FCGI; 1: FCGI */
	94
	95	static FCGX_Request global_fcgx_request;
	96
	97	typedef struct FCGP_Request {
	98	int compat;
	99	int acceptCalled;
	100	int finishCalled;
	101	SV* svin;
	102	SV* svout;
	103	SV* sverr;
	104	FCGX_Stream* in;
	105	FCGX_Request* requestPtr;
	106	} FCGP_Request;
	107
	108	static FCGP_Request global_request;
	109	static SV* global_sverr;
1b64d24d	110
1b64d24d	111	static int
90a18d65	112	FCGI_Flush(FCGP_Request* request)
1b64d24d	113	{
90a18d65	114	if(!request->compat \|\| !request->acceptCalled \|\| isCGI) {
1b64d24d	115	return;
	116	}
	117	#ifdef USE_SFIO
	118	sfsync(PerlIO_stdout());
	119	sfsync(PerlIO_stderr());
	120	#else
90a18d65	121	FCGX_FFlush((FCGX_Stream ) SvIV((SV) SvRV(request->svout)));
90a18d65	122	FCGX_FFlush((FCGX_Stream ) SvIV((SV) SvRV(request->sverr)));
1b64d24d	123	#endif
	124	}
	125
	126	static int
90a18d65	127	FCGI_Accept(FCGP_Request* request)
1b64d24d	128	{
90a18d65	129	if(isCGI == -1) {
1b64d24d	130	/*
	131	* First call to FCGI_Accept. Is application running
	132	* as FastCGI or as CGI?
	133	*/
	134	isCGI = FCGX_IsCGI();
	135	} else if(isCGI) {
	136	/*
	137	* Not first call to FCGI_Accept and running as CGI means
	138	* application is done.
	139	*/
	140	return(EOF);
	141	} else {
90a18d65	142	if(request->compat && !request->finishCalled) {
1b64d24d	143	#ifdef USE_SFIO
	144	sfdcdelfcgi(sfdisc(PerlIO_stdin(), SF_POPDISC));
	145	sfdcdelfcgi(sfdisc(PerlIO_stdout(), SF_POPDISC));
	146	sfdcdelfcgi(sfdisc(PerlIO_stderr(), SF_POPDISC));
	147	#else
90a18d65	148	FCGI_Flush(request);
1b64d24d	149	#endif
	150	}
	151	}
	152	if(!isCGI) {
	153	FCGX_ParamArray envp;
	154	FCGX_Stream out, error;
90a18d65	155	int acceptResult = FCGX_Accept_r(&request->in, &out, &error, &envp,
90a18d65	156	request->requestPtr);
1b64d24d	157	if(acceptResult < 0) {
	158	return acceptResult;
	159	}
	160	#ifdef USE_SFIO
90a18d65	161	sfdisc(PerlIO_stdin(), sfdcnewfcgi(request->in));
1b64d24d	162	sfdisc(PerlIO_stdout(), sfdcnewfcgi(out));
	163	sfdisc(PerlIO_stderr(), sfdcnewfcgi(error));
	164	#else
90a18d65	165	if (!request->svout) {
90a18d65	166	newSVrv(request->svout = newSV(0), "FCGI");
1b64d24d	167	sv_magic((SV *)gv_fetchpv("STDOUT",TRUE, SVt_PVIO),
90a18d65	168	request->svout, 'q', Nullch, 0);
90a18d65	169	newSVrv(request->sverr = newSV(0), "FCGI");
1b64d24d	170	sv_magic((SV *)gv_fetchpv("STDERR",TRUE, SVt_PVIO),
90a18d65	171	request->sverr, 'q', Nullch, 0);
90a18d65	172	newSVrv(request->svin = newSV(0), "FCGI");
1b64d24d	173	sv_magic((SV *)gv_fetchpv("STDIN",TRUE, SVt_PVIO),
90a18d65	174	request->svin, 'q', Nullch, 0);
1b64d24d	175	}
90a18d65	176	sv_setiv(SvRV(request->svout), (IV) out);
	177	sv_setiv(SvRV(request->sverr), (IV) error);
	178	sv_setiv(SvRV(request->svin), (IV) request->in);
	179
	180	if (request->compat) {
	181	global_sverr = request->sverr;
6ef7789b	182	if (PL_warnhook) SvREFCNT_dec(PL_warnhook);
6ef7789b	183	PL_warnhook = SvREFCNT_inc(GvCV(gv_fetchmethod(Nullhv, "FCGI::WARN")));
6ef7789b	184	if (PL_diehook) SvREFCNT_dec(PL_diehook);
	185	PL_diehook = SvREFCNT_inc(GvCV(gv_fetchmethod(Nullhv, "FCGI::DIE")));
	186	}
1b64d24d	187	#endif
90a18d65	188	request->finishCalled = FALSE;
1b64d24d	189	environ = envp;
1b64d24d	190	}
90a18d65	191	request->acceptCalled = TRUE;
1b64d24d	192	return 0;
	193	}
	194
	195	static void
90a18d65	196	FCGI_Finish(FCGP_Request* request)
1b64d24d	197	{
90a18d65	198	if(!request->acceptCalled \|\| isCGI) {
1b64d24d	199	return;
1b64d24d	200	}
90a18d65	201	if (request->compat) {
1b64d24d	202	#ifdef USE_SFIO
90a18d65	203	sfdcdelfcgi(sfdisc(PerlIO_stdin(), SF_POPDISC));
	204	sfdcdelfcgi(sfdisc(PerlIO_stdout(), SF_POPDISC));
	205	sfdcdelfcgi(sfdisc(PerlIO_stderr(), SF_POPDISC));
1b64d24d	206	#else
90a18d65	207	FCGI_Flush(request);
1b64d24d	208	#endif
1b64d24d	209	}
90a18d65	210	request->in = NULL;
	211	FCGX_Finish_r(request->requestPtr);
	212	request->finishCalled = TRUE;
	213	#ifndef USE_SFIO
	214	if (request->compat) {
	215	if (PL_warnhook == (SV*)GvCV(gv_fetchmethod(Nullhv, "FCGI::WARN"))) {
	216	SvREFCNT_dec(PL_warnhook);
	217	PL_warnhook = Nullsv;
	218	}
	219	if (PL_diehook == (SV*)GvCV(gv_fetchmethod(Nullhv, "FCGI::DIE"))) {
	220	SvREFCNT_dec(PL_diehook);
	221	PL_diehook = Nullsv;
	222	}
1b64d24d	223	}
	224	#endif
	225	}
	226
	227	static int
90a18d65	228	FCGI_StartFilterData(FCGP_Request* request)
	229	{
	230	return request->in ? FCGX_StartFilterData(request->in) : -1;
	231	}
	232
	233	static void
	234	FCGI_SetExitStatus(FCGP_Request* request, int status)
	235	{
	236	if (request->in) FCGX_SetExitStatus(status, request->in);
	237	}
	238
	239	static FCGP_Request *
	240	FCGI_Request()
1b64d24d	241	{
90a18d65	242	FCGX_Request* fcgx_req;
	243	FCGP_Request* req;
	244
	245	Newz(551, fcgx_req, 1, FCGX_Request);
	246	Newz(551, req, 1, FCGP_Request);
	247	req->requestPtr = fcgx_req;
	248
	249	return req;
1b64d24d	250	}
	251
	252	static void
90a18d65	253	FCGI_Release_Request(FCGP_Request *req)
1b64d24d	254	{
90a18d65	255	Safefree(req->requestPtr);
90a18d65	256	Safefree(req);
1b64d24d	257	}
	258
	259	/*
	260	* For each variable in the array envp, either set or unset it
	261	* in the global hash %ENV.
	262	*/
	263	static void
	264	DoPerlEnv(envp, set)
	265	char **envp;
	266	int set;
	267	{
	268	int i;
	269	char p, p1;
	270	HV *hv;
	271	SV *sv;
	272	hv = perl_get_hv("ENV", TRUE);
	273
	274	if (!set)
	275	perl_eval_pv("%ENV = %FCGI::ENV", 0);
	276	else {
	277	perl_eval_pv("%FCGI::ENV = %ENV", 0);
	278	for(i = 0; ; i++) {
	279	if((p = envp[i]) == NULL) {
	280	break;
	281	}
	282	p1 = strchr(p, '=');
	283	assert(p1 != NULL);
	284	*p1 = '\0';
	285	sv = newSVpv(p1 + 1, 0);
	286	/* call magic for this value ourselves */
	287	hv_store(hv, p, p1 - p, sv, 0);
	288	SvSETMAGIC(sv);
	289	*p1 = '=';
	290	}
	291	}
	292	}
	293
	294
	295	typedef FCGX_Stream * FCGI;
90a18d65	296	typedef FCGP_Request * FCGI__Request;
1b64d24d	297
	298	MODULE = FCGI PACKAGE = FCGI
	299
90a18d65	300	BOOT:
	301	FCGX_Init();
	302	FCGX_InitRequest(&global_fcgx_request);
	303	memset(&global_request, 0, sizeof(global_request));
	304	global_request.compat = 1;
	305	global_request.requestPtr = &global_fcgx_request;
	306
1b64d24d	307	#ifndef USE_SFIO
	308	void
	309	DIE(msg)
	310	char * msg;
	311
	312	CODE:
	313	if (!PL_in_eval)
90a18d65	314	FCGX_PutS(msg, (FCGX_Stream ) SvIV((SV) SvRV(global_sverr)));
1b64d24d	315
	316	void
	317	WARN(msg)
	318	char * msg;
	319
	320	CODE:
90a18d65	321	FCGX_PutS(msg, (FCGX_Stream ) SvIV((SV) SvRV(global_sverr)));
1b64d24d	322
	323	void
	324	PRINT(stream, ...)
	325	FCGI stream;
	326
	327	PREINIT:
	328	int n;
	329
	330	CODE:
	331	for (n = 1; n < items; ++n) {
	332	STRLEN len;
	333	register char tmps = (char )SvPV(ST(n),len);
	334	FCGX_PutStr(tmps, len, stream);
	335	}
	336	if (SvTRUEx(perl_get_sv("\|", FALSE)))
	337	FCGX_FFlush(stream);
	338
	339	int
	340	WRITE(stream, bufsv, len, ...)
	341	FCGI stream;
	342	SV * bufsv;
	343	int len;
	344
	345	PREINIT:
	346	int offset;
	347	char * buf;
	348	STRLEN blen;
	349	int n;
	350
	351	CODE:
	352	offset = (items == 4) ? (int)SvIV(ST(3)) : 0;
	353	buf = SvPV(bufsv, blen);
	354	if (offset < 0) offset += blen;
	355	if (len > blen - offset)
	356	len = blen - offset;
	357	if (offset < 0 \|\| offset >= blen \|\|
	358	(n = FCGX_PutStr(buf+offset, len, stream)) < 0)
	359	ST(0) = &PL_sv_undef;
	360	else {
	361	ST(0) = sv_newmortal();
	362	sv_setpvf(ST(0), "%c", n);
	363	}
	364
	365	int
	366	READ(stream, bufsv, len, ...)
	367	FCGI stream;
	368	SV * bufsv;
	369	int len;
	370
	371	PREINIT:
	372	int offset;
	373	char * buf;
	374
	375	CODE:
	376	offset = (items == 4) ? (int)SvIV(ST(3)) : 0;
	377	if (! SvOK(bufsv))
	378	sv_setpvn(bufsv, "", 0);
	379	buf = SvGROW(bufsv, len+offset+1);
	380	len = FCGX_GetStr(buf+offset, len, stream);
	381	SvCUR_set(bufsv, len+offset);
	382	*SvEND(bufsv) = '\0';
	383	(void)SvPOK_only(bufsv);
	384	SvSETMAGIC(bufsv);
	385	RETVAL = len;
386
387	OUTPUT:
388	RETVAL
389
390	SV *
391	GETC(stream)
392	FCGI stream;
393
394	PREINIT:
395	int retval;
396
397	CODE:
398	if ((retval = FCGX_GetChar(stream)) != -1) {
399	ST(0) = sv_newmortal();
400	sv_setpvf(ST(0), "%c", retval);
401	} else ST(0) = &PL_sv_undef;
402
403	bool
404	CLOSE(stream)
405	FCGI stream;
406
407	ALIAS:
408	DESTROY = 1
409
410	CODE:
411	RETVAL = FCGX_FClose(stream) != -1;
412
413	OUTPUT:
414	RETVAL
415
416	#endif
417
90a18d65	418	SV *
90a18d65	419	request()
1b64d24d	420
	421	PROTOTYPE:
	422	CODE:
90a18d65	423	RETVAL = Perl_sv_setref_pv(Perl_newSV(0), "FCGI::Request", FCGI_Request());
	424
	425	OUTPUT:
	426	RETVAL
	427
	428
	429	int
	430	accept(...)
	431
	432	PROTOTYPE: ;$***$
	433
	434	PREINIT:
	435	FCGP_Request* request = &global_request;
	436	SV * sv;
	437
	438	CODE:
	439	if (items != 0 && items != 5)
	440	croak("Usage: FCGI::accept() or "
	441	"FCGI::accept(request, IN, OUT, ERR, env)");
	442	if (items) {
	443	if (sv_isa(ST(0), "FCGI::Request")) {
	444	request = (FCGP_Request) SvIV((SV)SvRV(ST(0)));
	445	} else
	446	croak("request is not of type FCGI::Request");
	447	if (SvROK(ST(1)) && isGV(SvRV(ST(1)))) {
	448	} else
	449	croak("IN is not a GLOB reference");
	450	}
1b64d24d	451	{
	452	char **savedEnviron;
	453	int acceptStatus;
	454	/*
	455	* Unmake Perl variable settings for the request just completed.
	456	*/
	457	if(requestEnviron != NULL) {
	458	DoPerlEnv(requestEnviron, FALSE);
	459	requestEnviron = NULL;
	460	}
	461	/*
	462	* Call FCGI_Accept but preserve environ.
	463	*/
	464	savedEnviron = environ;
90a18d65	465	acceptStatus = FCGI_Accept(request);
1b64d24d	466	requestEnviron = environ;
	467	environ = savedEnviron;
	468	/*
	469	* Make Perl variable settings for the new request.
	470	*/
	471	if(acceptStatus >= 0 && !FCGX_IsCGI()) {
	472	DoPerlEnv(requestEnviron, TRUE);
	473	} else {
	474	requestEnviron = NULL;
	475	}
	476	RETVAL = acceptStatus;
	477	}
	478	OUTPUT:
	479	RETVAL
	480
	481
	482	void
90a18d65	483	finish(...)
1b64d24d	484
90a18d65	485	PROTOTYPE: ;$
1b64d24d	486	CODE:
	487	{
	488	/*
	489	* Unmake Perl variable settings for the completed request.
	490	*/
	491	if(requestEnviron != NULL) {
	492	DoPerlEnv(requestEnviron, FALSE);
	493	requestEnviron = NULL;
	494	}
	495	/*
	496	* Finish the request.
	497	*/
90a18d65	498	FCGI_Finish(&global_request);
1b64d24d	499	}
	500
	501
	502	void
90a18d65	503	flush(...)
1b64d24d	504
90a18d65	505	PROTOTYPE: ;$
1b64d24d	506	CODE:
90a18d65	507	FCGI_Flush(&global_request);
1b64d24d	508
1b64d24d	509	void
90a18d65	510	set_exit_status(status,...)
1b64d24d	511
	512	int status;
	513
90a18d65	514	PROTOTYPE: $;$
1b64d24d	515	CODE:
90a18d65	516	FCGI_SetExitStatus(&global_request, status);
1b64d24d	517
1b64d24d	518	int
90a18d65	519	start_filter_data(...)
1b64d24d	520
90a18d65	521	PROTOTYPE: ;$
1b64d24d	522	CODE:
90a18d65	523	RETVAL = FCGI_StartFilterData(&global_request);
1b64d24d	524
	525	OUTPUT:
	526	RETVAL
90a18d65	527
	528	MODULE = FCGI PACKAGE = FCGI::Request
	529
	530	void
	531	DESTROY(request)
	532	FCGI::Request request;
	533
	534	CODE:
	535	FCGI_Release_Request(request);