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.2 1999/02/28 17:46:31 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 extern char **environ;
  32 static char **requestEnviron = NULL;
  33
  34 #ifdef USE_SFIO
  35 typedef struct
  36 {
  37     Sfdisc_t    disc;
  38     FCGX_Stream *stream;
  39 } FCGI_Disc;
  40
  41 static ssize_t
  42 sffcgiread(f, buf, n, disc)
  43 Sfio_t*         f;      /* stream involved */
  44 Void_t*         buf;    /* buffer to read into */
  45 size_t          n;      /* number of bytes to read */
  46 Sfdisc_t*       disc;   /* discipline */
  47 {
  48     return FCGX_GetStr(buf, n, ((FCGI_Disc *)disc)->stream);
  49 }
  50
  51 static ssize_t
  52 sffcgiwrite(f, buf, n, disc)
  53 Sfio_t*         f;      /* stream involved */
  54 const Void_t*   buf;    /* buffer to read into */
  55 size_t          n;      /* number of bytes to read */
  56 Sfdisc_t*       disc;   /* discipline */
  57 {
  58     n = FCGX_PutStr(buf, n, ((FCGI_Disc *)disc)->stream);
  59     FCGX_FFlush(((FCGI_Disc *)disc)->stream);
  60     return n;
  61 }
  62
  63 Sfdisc_t *
  64 sfdcnewfcgi(stream)
  65         FCGX_Stream *stream;
  66 {
  67     FCGI_Disc*  disc;
  68
  69     New(1000,disc,1,FCGI_Disc);
  70     if (!disc) return (Sfdisc_t *)disc;
  71
  72     disc->disc.exceptf = (Sfexcept_f)NULL;
  73     disc->disc.seekf = (Sfseek_f)NULL;
  74     disc->disc.readf = sffcgiread;
  75     disc->disc.writef = sffcgiwrite;
  76     disc->stream = stream;
  77     return (Sfdisc_t *)disc;
  78 }
  79
  80 Sfdisc_t *
  81 sfdcdelfcgi(disc)
  82     Sfdisc_t*   disc;
  83 {
  84     Safefree(disc);
  85     return 0;
  86 }
  87 #endif
  88
  89 static int acceptCalled = FALSE;
  90 static int finishCalled = FALSE;
  91 static int isCGI = FALSE;
  92 static FCGX_Stream *in = NULL;
  93 static SV *svout = NULL, *svin, *sverr;
  94
  95 static int
  96 FCGI_Flush(void)
  97 {
  98     if(!acceptCalled || isCGI) {
  99         return;
 100     }
 101 #ifdef USE_SFIO
 102     sfsync(PerlIO_stdout());
 103     sfsync(PerlIO_stderr());
 104 #else
 105     FCGX_FFlush((FCGX_Stream *) SvIV((SV*) SvRV(svout)));
 106     FCGX_FFlush((FCGX_Stream *) SvIV((SV*) SvRV(sverr)));
 107 #endif
 108 }
 109
 110 static int
 111 FCGI_Accept(void)
 112 {
 113     if(!acceptCalled) {
 114         /*
 115          * First call to FCGI_Accept.  Is application running
 116          * as FastCGI or as CGI?
 117          */
 118         isCGI = FCGX_IsCGI();
 119     } else if(isCGI) {
 120         /*
 121          * Not first call to FCGI_Accept and running as CGI means
 122          * application is done.
 123          */
 124         return(EOF);
 125     } else {
 126         if(!finishCalled) {
 127 #ifdef USE_SFIO
 128             sfdcdelfcgi(sfdisc(PerlIO_stdin(), SF_POPDISC));
 129             sfdcdelfcgi(sfdisc(PerlIO_stdout(), SF_POPDISC));
 130             sfdcdelfcgi(sfdisc(PerlIO_stderr(), SF_POPDISC));
 131 #else
 132             FCGI_Flush();
 133 #endif
 134         }
 135     }
 136     if(!isCGI) {
 137         FCGX_ParamArray envp;
 138         FCGX_Stream *out, *error;
 139         int acceptResult = FCGX_Accept(&in, &out, &error, &envp);
 140         if(acceptResult < 0) {
 141             return acceptResult;
 142         }
 143 #ifdef USE_SFIO
 144         sfdisc(PerlIO_stdin(), sfdcnewfcgi(in));
 145         sfdisc(PerlIO_stdout(), sfdcnewfcgi(out));
 146         sfdisc(PerlIO_stderr(), sfdcnewfcgi(error));
 147 #else
 148         if (!svout) {
 149             newSVrv(svout = newSV(0), "FCGI");
 150             sv_magic((SV *)gv_fetchpv("STDOUT",TRUE, SVt_PVIO),
 151                         svout, 'q', Nullch, 0);
 152             newSVrv(sverr = newSV(0), "FCGI");
 153             sv_magic((SV *)gv_fetchpv("STDERR",TRUE, SVt_PVIO),
 154                         sverr, 'q', Nullch, 0);
 155             newSVrv(svin = newSV(0), "FCGI");
 156             sv_magic((SV *)gv_fetchpv("STDIN",TRUE, SVt_PVIO),
 157                         svin, 'q', Nullch, 0);
 158         }
 159         sv_setiv(SvRV(svout), (IV) out);
 160         sv_setiv(SvRV(sverr), (IV) error);
 161         sv_setiv(SvRV(svin), (IV) in);
 162         if (!SvTRUEx(perl_get_sv("FCGI::no_warn_redirection", FALSE)))
 163         {
 164             if (PL_warnhook) SvREFCNT_dec(PL_warnhook);
 165             PL_warnhook = SvREFCNT_inc(GvCV(gv_fetchmethod(Nullhv, "FCGI::WARN")));
 166         }
 167         if (!SvTRUEx(perl_get_sv("FCGI::no_die_redirection", FALSE)))
 168         {
 169             if (PL_diehook) SvREFCNT_dec(PL_diehook);
 170             PL_diehook = SvREFCNT_inc(GvCV(gv_fetchmethod(Nullhv, "FCGI::DIE")));
 171         }
 172 #endif
 173         finishCalled = FALSE;
 174         environ = envp;
 175     }
 176     acceptCalled = TRUE;
 177     return 0;
 178 }
 179
 180 static void
 181 FCGI_Finish(void)
 182 {
 183     if(!acceptCalled || isCGI) {
 184         return;
 185     }
 186 #ifdef USE_SFIO
 187     sfdcdelfcgi(sfdisc(PerlIO_stdin(), SF_POPDISC));
 188     sfdcdelfcgi(sfdisc(PerlIO_stdout(), SF_POPDISC));
 189     sfdcdelfcgi(sfdisc(PerlIO_stderr(), SF_POPDISC));
 190 #else
 191     FCGI_Flush();
 192 #endif
 193     in = NULL;
 194     FCGX_Finish();
 195     /*
 196     environ = NULL;
 197     */
 198     finishCalled = TRUE;
 199 #ifndef USE_SFIO
 200     if (!SvTRUEx(perl_get_sv("FCGI::no_warn_redirection", FALSE)) &&
 201             PL_warnhook == (SV*)GvCV(gv_fetchmethod(Nullhv, "FCGI::WARN"))) {
 202         SvREFCNT_dec(PL_warnhook);
 203         PL_warnhook = Nullsv;
 204     }
 205     if (!SvTRUEx(perl_get_sv("FCGI::no_die_redirection", FALSE)) &&
 206             PL_diehook == (SV*)GvCV(gv_fetchmethod(Nullhv, "FCGI::DIE"))) {
 207         SvREFCNT_dec(PL_diehook);
 208         PL_diehook = Nullsv;
 209     }
 210 #endif
 211 }
 212
 213 static int
 214 FCGI_StartFilterData(void)
 215 {
 216     return in ? FCGX_StartFilterData(in) : -1;
 217 }
 218
 219 static void
 220 FCGI_SetExitStatus(int status)
 221 {
 222     if (in) FCGX_SetExitStatus(status, in);
 223 }
 224
 225 /*
 226  * For each variable in the array envp, either set or unset it
 227  * in the global hash %ENV.
 228  */
 229 static void
 230 DoPerlEnv(envp, set)
 231 char **envp;
 232 int set;
 233 {
 234     int i;
 235     char *p, *p1;
 236     HV   *hv;
 237     SV   *sv;
 238     hv = perl_get_hv("ENV", TRUE);
 239
 240     if (!set)
 241         perl_eval_pv("%ENV = %FCGI::ENV", 0);
 242     else {
 243         perl_eval_pv("%FCGI::ENV = %ENV", 0);
 244         for(i = 0; ; i++) {
 245             if((p = envp[i]) == NULL) {
 246                 break;
 247             }
 248             p1 = strchr(p, '=');
 249             assert(p1 != NULL);
 250             *p1 = '\0';
 251             sv = newSVpv(p1 + 1, 0);
 252             /* call magic for this value ourselves */
 253             hv_store(hv, p, p1 - p, sv, 0);
 254             SvSETMAGIC(sv);
 255             *p1 = '=';
 256         }
 257     }
 258 }
 259
 260
 261 typedef FCGX_Stream *   FCGI;
 262
 263 MODULE = FCGI           PACKAGE = FCGI
 264
 265 #ifndef USE_SFIO
 266 void
 267 DIE(msg)
 268         char *  msg;
 269
 270         CODE:
 271         if (!PL_in_eval)
 272             FCGX_PutS(msg, (FCGX_Stream *) SvIV((SV*) SvRV(sverr)));
 273
 274 void
 275 WARN(msg)
 276         char *  msg;
 277
 278         CODE:
 279         FCGX_PutS(msg, (FCGX_Stream *) SvIV((SV*) SvRV(sverr)));
 280
 281 void
 282 PRINT(stream, ...)
 283         FCGI    stream;
 284
 285         PREINIT:
 286         int     n;
 287
 288         CODE:
 289         for (n = 1; n < items; ++n) {
 290             STRLEN len;
 291             register char *tmps = (char *)SvPV(ST(n),len);
 292             FCGX_PutStr(tmps, len, stream);
 293         }
 294         if (SvTRUEx(perl_get_sv("|", FALSE)))
 295             FCGX_FFlush(stream);
 296
 297 int
 298 WRITE(stream, bufsv, len, ...)
 299         FCGI    stream;
 300         SV *    bufsv;
 301         int     len;
 302
 303         PREINIT:
 304         int     offset;
 305         char *  buf;
 306         STRLEN  blen;
 307         int     n;
 308
 309         CODE:
 310         offset = (items == 4) ? (int)SvIV(ST(3)) : 0;
 311         buf = SvPV(bufsv, blen);
 312         if (offset < 0) offset += blen;
 313         if (len > blen - offset)
 314             len = blen - offset;
 315         if (offset < 0 || offset >= blen ||
 316                 (n = FCGX_PutStr(buf+offset, len, stream)) < 0)
 317             ST(0) = &PL_sv_undef;
 318         else {
 319             ST(0) = sv_newmortal();
 320             sv_setpvf(ST(0), "%c", n);
 321         }
 322
 323 int
 324 READ(stream, bufsv, len, ...)
 325         FCGI    stream;
 326         SV *    bufsv;
 327         int     len;
 328
 329         PREINIT:
 330         int     offset;
 331         char *  buf;
 332
 333         CODE:
 334         offset = (items == 4) ? (int)SvIV(ST(3)) : 0;
 335         if (! SvOK(bufsv))
 336             sv_setpvn(bufsv, "", 0);
 337         buf = SvGROW(bufsv, len+offset+1);
 338         len = FCGX_GetStr(buf+offset, len, stream);
 339         SvCUR_set(bufsv, len+offset);
 340         *SvEND(bufsv) = '\0';
 341         (void)SvPOK_only(bufsv);
 342         SvSETMAGIC(bufsv);
 343         RETVAL = len;
 344
 345         OUTPUT:
 346         RETVAL
 347
 348 SV *
 349 GETC(stream)
 350         FCGI    stream;
 351
 352         PREINIT:
 353         int     retval;
 354
 355         CODE:
 356         if ((retval = FCGX_GetChar(stream)) != -1) {
 357             ST(0) = sv_newmortal();
 358             sv_setpvf(ST(0), "%c", retval);
 359         } else ST(0) = &PL_sv_undef;
 360
 361 bool
 362 CLOSE(stream)
 363         FCGI    stream;
 364
 365         ALIAS:
 366         DESTROY = 1
 367
 368         CODE:
 369         RETVAL = FCGX_FClose(stream) != -1;
 370
 371         OUTPUT:
 372         RETVAL
 373
 374 #endif
 375
 376 int
 377 accept()
 378
 379     PROTOTYPE:
 380     CODE:
 381     {
 382         char **savedEnviron;
 383         int acceptStatus;
 384         /*
 385          * Unmake Perl variable settings for the request just completed.
 386          */
 387         if(requestEnviron != NULL) {
 388             DoPerlEnv(requestEnviron, FALSE);
 389             requestEnviron = NULL;
 390         }
 391         /*
 392          * Call FCGI_Accept but preserve environ.
 393          */
 394         savedEnviron = environ;
 395         acceptStatus = FCGI_Accept();
 396         requestEnviron = environ;
 397         environ = savedEnviron;
 398         /*
 399          * Make Perl variable settings for the new request.
 400          */
 401         if(acceptStatus >= 0 && !FCGX_IsCGI()) {
 402             DoPerlEnv(requestEnviron, TRUE);
 403         } else {
 404             requestEnviron = NULL;
 405         }
 406         RETVAL = acceptStatus;
 407     }
 408     OUTPUT:
 409     RETVAL
 410
 411
 412 void
 413 finish()
 414
 415     PROTOTYPE:
 416     CODE:
 417     {
 418         /*
 419          * Unmake Perl variable settings for the completed request.
 420          */
 421         if(requestEnviron != NULL) {
 422             DoPerlEnv(requestEnviron, FALSE);
 423             requestEnviron = NULL;
 424         }
 425         /*
 426          * Finish the request.
 427          */
 428         FCGI_Finish();
 429     }
 430
 431
 432 void
 433 flush()
 434
 435     PROTOTYPE:
 436     CODE:
 437     FCGI_Flush();
 438
 439 void
 440 set_exit_status(status)
 441
 442     int status;
 443
 444     PROTOTYPE: $
 445     CODE:
 446     FCGI_SetExitStatus(status);
 447
 448 int
 449 start_filter_data()
 450
 451     PROTOTYPE:
 452     CODE:
 453     RETVAL = FCGI_StartFilterData();
 454
 455     OUTPUT:
 456     RETVAL