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