perl/FCGI.PL

   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__
  15 /* $Id: FCGI.PL,v 1.4 1999/07/28 16:15:40 skimo Exp $ */
  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
  31 #ifdef WIN32
  32 #define environ _environ
  33 #endif
  34
  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
  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;
 110
 111 static int
 112 FCGI_Flush(FCGP_Request* request)
 113 {
 114     if(!request->compat || !request->acceptCalled || isCGI) {
 115         return;
 116     }
 117 #ifdef USE_SFIO
 118     sfsync(PerlIO_stdout());
 119     sfsync(PerlIO_stderr());
 120 #else
 121     FCGX_FFlush((FCGX_Stream *) SvIV((SV*) SvRV(request->svout)));
 122     FCGX_FFlush((FCGX_Stream *) SvIV((SV*) SvRV(request->sverr)));
 123 #endif
 124 }
 125
 126 static int
 127 FCGI_Accept(FCGP_Request* request)
 128 {
 129     if(isCGI == -1) {
 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 {
 142         if(request->compat && !request->finishCalled) {
 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
 148             FCGI_Flush(request);
 149 #endif
 150         }
 151     }
 152     if(!isCGI) {
 153         FCGX_ParamArray envp;
 154         FCGX_Stream *out, *error;
 155         int acceptResult = FCGX_Accept_r(&request->in, &out, &error, &envp,
 156                                          request->requestPtr);
 157         if(acceptResult < 0) {
 158             return acceptResult;
 159         }
 160 #ifdef USE_SFIO
 161         sfdisc(PerlIO_stdin(), sfdcnewfcgi(request->in));
 162         sfdisc(PerlIO_stdout(), sfdcnewfcgi(out));
 163         sfdisc(PerlIO_stderr(), sfdcnewfcgi(error));
 164 #else
 165         if (!request->svout) {
 166             newSVrv(request->svout = newSV(0), "FCGI");
 167             sv_magic((SV *)gv_fetchpv("STDOUT",TRUE, SVt_PVIO),
 168                         request->svout, 'q', Nullch, 0);
 169             newSVrv(request->sverr = newSV(0), "FCGI");
 170             sv_magic((SV *)gv_fetchpv("STDERR",TRUE, SVt_PVIO),
 171                         request->sverr, 'q', Nullch, 0);
 172             newSVrv(request->svin = newSV(0), "FCGI");
 173             sv_magic((SV *)gv_fetchpv("STDIN",TRUE, SVt_PVIO),
 174                         request->svin, 'q', Nullch, 0);
 175         }
 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;
 182             if (PL_warnhook) SvREFCNT_dec(PL_warnhook);
 183             PL_warnhook = SvREFCNT_inc(GvCV(gv_fetchmethod(Nullhv, "FCGI::WARN")));
 184             if (PL_diehook) SvREFCNT_dec(PL_diehook);
 185             PL_diehook = SvREFCNT_inc(GvCV(gv_fetchmethod(Nullhv, "FCGI::DIE")));
 186         }
 187 #endif
 188         request->finishCalled = FALSE;
 189         environ = envp;
 190     }
 191     request->acceptCalled = TRUE;
 192     return 0;
 193 }
 194
 195 static void
 196 FCGI_Finish(FCGP_Request* request)
 197 {
 198     if(!request->acceptCalled || isCGI) {
 199         return;
 200     }
 201     if (request->compat) {
 202 #ifdef USE_SFIO
 203         sfdcdelfcgi(sfdisc(PerlIO_stdin(), SF_POPDISC));
 204         sfdcdelfcgi(sfdisc(PerlIO_stdout(), SF_POPDISC));
 205         sfdcdelfcgi(sfdisc(PerlIO_stderr(), SF_POPDISC));
 206 #else
 207         FCGI_Flush(request);
 208 #endif
 209     }
 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         }
 223     }
 224 #endif
 225 }
 226
 227 static int
 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()
 241 {
 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;
 250 }
 251
 252 static void
 253 FCGI_Release_Request(FCGP_Request *req)
 254 {
 255     Safefree(req->requestPtr);
 256     Safefree(req);
 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;
 296 typedef FCGP_Request *  FCGI__Request;
 297
 298 MODULE = FCGI           PACKAGE = FCGI
 299
 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
 307 #ifndef USE_SFIO
 308 void
 309 DIE(msg)
 310         char *  msg;
 311
 312         CODE:
 313         if (!PL_in_eval)
 314             FCGX_PutS(msg, (FCGX_Stream *) SvIV((SV*) SvRV(global_sverr)));
 315
 316 void
 317 WARN(msg)
 318         char *  msg;
 319
 320         CODE:
 321         FCGX_PutS(msg, (FCGX_Stream *) SvIV((SV*) SvRV(global_sverr)));
 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
 418 SV *
 419 request()
 420
 421     PROTOTYPE:
 422     CODE:
 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     }
 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;
 465         acceptStatus = FCGI_Accept(request);
 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
 483 finish(...)
 484
 485     PROTOTYPE: ;$
 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          */
 498         FCGI_Finish(&global_request);
 499     }
 500
 501
 502 void
 503 flush(...)
 504
 505     PROTOTYPE: ;$
 506     CODE:
 507     FCGI_Flush(&global_request);
 508
 509 void
 510 set_exit_status(status,...)
 511
 512     int status;
 513
 514     PROTOTYPE: $;$
 515     CODE:
 516     FCGI_SetExitStatus(&global_request, status);
 517
 518 int
 519 start_filter_data(...)
 520
 521     PROTOTYPE: ;$
 522     CODE:
 523     RETVAL = FCGI_StartFilterData(&global_request);
 524
 525     OUTPUT:
 526     RETVAL
 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);