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.1 1999/02/13 05:26:42 roberts 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 (PL_warnhook) SvREFCNT_dec(PL_warnhook);
 163         PL_warnhook = SvREFCNT_inc(GvCV(gv_fetchmethod(Nullhv, "FCGI::WARN")));
 164         if (PL_diehook) SvREFCNT_dec(PL_diehook);
 165         PL_diehook = SvREFCNT_inc(GvCV(gv_fetchmethod(Nullhv, "FCGI::DIE")));
 166 #endif
 167         finishCalled = FALSE;
 168         environ = envp;
 169     }
 170     acceptCalled = TRUE;
 171     return 0;
 172 }
 173
 174 static void
 175 FCGI_Finish(void)
 176 {
 177     if(!acceptCalled || isCGI) {
 178         return;
 179     }
 180 #ifdef USE_SFIO
 181     sfdcdelfcgi(sfdisc(PerlIO_stdin(), SF_POPDISC));
 182     sfdcdelfcgi(sfdisc(PerlIO_stdout(), SF_POPDISC));
 183     sfdcdelfcgi(sfdisc(PerlIO_stderr(), SF_POPDISC));
 184 #else
 185     FCGI_Flush();
 186 #endif
 187     in = NULL;
 188     FCGX_Finish();
 189     /*
 190     environ = NULL;
 191     */
 192     finishCalled = TRUE;
 193 #ifndef USE_SFIO
 194     if (PL_warnhook) {
 195         SvREFCNT_dec(PL_warnhook);
 196         PL_warnhook = Nullsv;
 197     }
 198     if (PL_diehook) {
 199         SvREFCNT_dec(PL_diehook);
 200         PL_diehook = Nullsv;
 201     }
 202 #endif
 203 }
 204
 205 static int
 206 FCGI_StartFilterData(void)
 207 {
 208     return in ? FCGX_StartFilterData(in) : -1;
 209 }
 210
 211 static void
 212 FCGI_SetExitStatus(int status)
 213 {
 214     if (in) FCGX_SetExitStatus(status, in);
 215 }
 216
 217 /*
 218  * For each variable in the array envp, either set or unset it
 219  * in the global hash %ENV.
 220  */
 221 static void
 222 DoPerlEnv(envp, set)
 223 char **envp;
 224 int set;
 225 {
 226     int i;
 227     char *p, *p1;
 228     HV   *hv;
 229     SV   *sv;
 230     hv = perl_get_hv("ENV", TRUE);
 231
 232     if (!set)
 233         perl_eval_pv("%ENV = %FCGI::ENV", 0);
 234     else {
 235         perl_eval_pv("%FCGI::ENV = %ENV", 0);
 236         for(i = 0; ; i++) {
 237             if((p = envp[i]) == NULL) {
 238                 break;
 239             }
 240             p1 = strchr(p, '=');
 241             assert(p1 != NULL);
 242             *p1 = '\0';
 243             sv = newSVpv(p1 + 1, 0);
 244             /* call magic for this value ourselves */
 245             hv_store(hv, p, p1 - p, sv, 0);
 246             SvSETMAGIC(sv);
 247             *p1 = '=';
 248         }
 249     }
 250 }
 251
 252
 253 typedef FCGX_Stream *   FCGI;
 254
 255 MODULE = FCGI           PACKAGE = FCGI
 256
 257 #ifndef USE_SFIO
 258 void
 259 DIE(msg)
 260         char *  msg;
 261
 262         CODE:
 263         if (!PL_in_eval)
 264             FCGX_PutS(msg, (FCGX_Stream *) SvIV((SV*) SvRV(sverr)));
 265
 266 void
 267 WARN(msg)
 268         char *  msg;
 269
 270         CODE:
 271         FCGX_PutS(msg, (FCGX_Stream *) SvIV((SV*) SvRV(sverr)));
 272
 273 void
 274 PRINT(stream, ...)
 275         FCGI    stream;
 276
 277         PREINIT:
 278         int     n;
 279
 280         CODE:
 281         for (n = 1; n < items; ++n) {
 282             STRLEN len;
 283             register char *tmps = (char *)SvPV(ST(n),len);
 284             FCGX_PutStr(tmps, len, stream);
 285         }
 286         if (SvTRUEx(perl_get_sv("|", FALSE)))
 287             FCGX_FFlush(stream);
 288
 289 int
 290 WRITE(stream, bufsv, len, ...)
 291         FCGI    stream;
 292         SV *    bufsv;
 293         int     len;
 294
 295         PREINIT:
 296         int     offset;
 297         char *  buf;
 298         STRLEN  blen;
 299         int     n;
 300
 301         CODE:
 302         offset = (items == 4) ? (int)SvIV(ST(3)) : 0;
 303         buf = SvPV(bufsv, blen);
 304         if (offset < 0) offset += blen;
 305         if (len > blen - offset)
 306             len = blen - offset;
 307         if (offset < 0 || offset >= blen ||
 308                 (n = FCGX_PutStr(buf+offset, len, stream)) < 0)
 309             ST(0) = &PL_sv_undef;
 310         else {
 311             ST(0) = sv_newmortal();
 312             sv_setpvf(ST(0), "%c", n);
 313         }
 314
 315 int
 316 READ(stream, bufsv, len, ...)
 317         FCGI    stream;
 318         SV *    bufsv;
 319         int     len;
 320
 321         PREINIT:
 322         int     offset;
 323         char *  buf;
 324
 325         CODE:
 326         offset = (items == 4) ? (int)SvIV(ST(3)) : 0;
 327         if (! SvOK(bufsv))
 328             sv_setpvn(bufsv, "", 0);
 329         buf = SvGROW(bufsv, len+offset+1);
 330         len = FCGX_GetStr(buf+offset, len, stream);
 331         SvCUR_set(bufsv, len+offset);
 332         *SvEND(bufsv) = '\0';
 333         (void)SvPOK_only(bufsv);
 334         SvSETMAGIC(bufsv);
 335         RETVAL = len;
 336
 337         OUTPUT:
 338         RETVAL
 339
 340 SV *
 341 GETC(stream)
 342         FCGI    stream;
 343
 344         PREINIT:
 345         int     retval;
 346
 347         CODE:
 348         if ((retval = FCGX_GetChar(stream)) != -1) {
 349             ST(0) = sv_newmortal();
 350             sv_setpvf(ST(0), "%c", retval);
 351         } else ST(0) = &PL_sv_undef;
 352
 353 bool
 354 CLOSE(stream)
 355         FCGI    stream;
 356
 357         ALIAS:
 358         DESTROY = 1
 359
 360         CODE:
 361         RETVAL = FCGX_FClose(stream) != -1;
 362
 363         OUTPUT:
 364         RETVAL
 365
 366 #endif
 367
 368 int
 369 accept()
 370
 371     PROTOTYPE:
 372     CODE:
 373     {
 374         char **savedEnviron;
 375         int acceptStatus;
 376         /*
 377          * Unmake Perl variable settings for the request just completed.
 378          */
 379         if(requestEnviron != NULL) {
 380             DoPerlEnv(requestEnviron, FALSE);
 381             requestEnviron = NULL;
 382         }
 383         /*
 384          * Call FCGI_Accept but preserve environ.
 385          */
 386         savedEnviron = environ;
 387         acceptStatus = FCGI_Accept();
 388         requestEnviron = environ;
 389         environ = savedEnviron;
 390         /*
 391          * Make Perl variable settings for the new request.
 392          */
 393         if(acceptStatus >= 0 && !FCGX_IsCGI()) {
 394             DoPerlEnv(requestEnviron, TRUE);
 395         } else {
 396             requestEnviron = NULL;
 397         }
 398         RETVAL = acceptStatus;
 399     }
 400     OUTPUT:
 401     RETVAL
 402
 403
 404 void
 405 finish()
 406
 407     PROTOTYPE:
 408     CODE:
 409     {
 410         /*
 411          * Unmake Perl variable settings for the completed request.
 412          */
 413         if(requestEnviron != NULL) {
 414             DoPerlEnv(requestEnviron, FALSE);
 415             requestEnviron = NULL;
 416         }
 417         /*
 418          * Finish the request.
 419          */
 420         FCGI_Finish();
 421     }
 422
 423
 424 void
 425 flush()
 426
 427     PROTOTYPE:
 428     CODE:
 429     FCGI_Flush();
 430
 431 void
 432 set_exit_status(status)
 433
 434     int status;
 435
 436     PROTOTYPE: $
 437     CODE:
 438     FCGI_SetExitStatus(status);
 439
 440 int
 441 start_filter_data()
 442
 443     PROTOTYPE:
 444     CODE:
 445     RETVAL = FCGI_StartFilterData();
 446
 447     OUTPUT:
 448     RETVAL