perl/FCGI.PL

   1 use Config;
   2 use ExtUtils::MakeMaker;
   3
   4 do 'FCGI.cfg' or die "no FCGI.cfg";
   5
   6 open OUT, ">FCGI.pm";
   7
   8 print "Generating FCGI.pm\n";
   9 print OUT <<'EOP';
  10 # $Id: FCGI.PL,v 1.36 2002/12/15 20:01:46 skimo Exp $
  11
  12 package FCGI;
  13
  14 require Exporter;
  15 require DynaLoader;
  16
  17 @ISA = qw(Exporter DynaLoader);
  18 # Items to export into callers namespace by default. Note: do not export
  19 # names by default without a very good reason. Use EXPORT_OK instead.
  20 # Do not simply export all your public functions/methods/constants.
  21 @EXPORT = qw(
  22
  23 );
  24
  25 EOP
  26
  27 print OUT '$VERSION = '.MM->parse_version('version.pm').";\n\n";
  28
  29 print OUT "bootstrap FCGI;\n" unless ($pure);
  30
  31 print OUT <<'EOP' if ($pure);
  32 use Symbol;
  33 use POSIX 'ENOTCONN';
  34
  35 use constant VERSION_1 => 1;
  36
  37 use constant BEGIN_REQUEST => 1;
  38 use constant PARAMS => 4;
  39 use constant FCGI_STDIN => 5;
  40 use constant FCGI_STDOUT => 6;
  41 use constant FCGI_STDERR => 7;
  42
  43 use constant RESPONDER => 1;
  44 use constant AUTHORIZER => 2;
  45 use constant FILTER => 3;
  46
  47 %FCGI::rolenames = (RESPONDER, "RESPONDER",
  48                       AUTHORIZER, "AUTHORIZER",
  49                       FILTER, "FILTER",
  50                      );
  51
  52 # This only works on Unix; anyone familiar with Windows is welcome
  53 # to give a hand here
  54 sub IsFastCGI {
  55     my ($req) = @_;
  56     $req->{isfastcgi} =
  57         (!defined getpeername shift->{listen_sock}) && $! == ENOTCONN
  58         unless exists $req->{isfastcgi};
  59     return $req->{isfastcgi};
  60 }
  61
  62 sub GetEnvironment {
  63     return shift->{'env'};
  64 }
  65
  66 sub read_nv_len {
  67     my ($stream) = @_;
  68     my $buf;
  69     return undef unless read $stream, $buf, 1, 0;
  70     my ($len) = unpack("C", $buf);
  71     if ($len & 0x80) {
  72         $buf = pack("C", $len & 0x7F);
  73         return undef unless read $stream, $buf, 3, 1;
  74         $len = unpack("N", $buf);
  75     }
  76     $len;
  77 }
  78
  79 sub RequestX {
  80     my $self = {
  81         in => shift,
  82         out => shift,
  83         err => shift,
  84         env => shift,
  85         socket => shift,
  86         flags => shift,
  87         last => 0,
  88     };
  89     open $self->{listen_sock}, "<&=0";
  90     bless $self, "FCGI";
  91 }
  92
  93 my $run_once = 0;
  94
  95 sub Accept {
  96     my ($req) = @_;
  97
  98     unless ($req->IsFastCGI()) {
  99         return -1 if $run_once;
 100
 101         $run_once = 1;
 102         return 0;
 103     }
 104     $req->Finish();
 105     $req->{socket} = gensym();
 106     if ($req->{last} || !accept($req->{socket}, $req->{listen_sock})) {
 107         $req->{error} = "accept";
 108         return -1;
 109     }
 110     my ($type, $id, $body) = $req->read_record();
 111     if ($type != BEGIN_REQUEST) {
 112         $req->{error} = "begin request";
 113         return -1;
 114     }
 115     my ($role, $flags) = unpack("nC", $body);
 116     $req->{role} = $role;
 117     $req->{flags} = $flags;
 118     $req->{id} = $id;
 119
 120     %{$req->{env}} = ();
 121     $req->{env}{FCGI_ROLE} = $FCGI::rolenames{$req->{role}};
 122     my $param = FCGI::Stream->new($req, PARAMS);
 123     my ($nlen, $vlen);
 124     while (defined($nlen = read_nv_len($param)) &&
 125            defined($vlen = read_nv_len($param))) {
 126         my ($name, $val);
 127         read $param, $name, $nlen;
 128         read $param, $val, $vlen;
 129         $req->{env}{$name} = $val;
 130     }
 131     $req->Bind;
 132     $req->{accepted} = 1;
 133
 134     return 0;
 135 }
 136
 137 sub UndoBindings {
 138     my ($req) = @_;
 139     untie ${$req->{in}};
 140     untie ${$req->{out}};
 141     untie ${$req->{err}};
 142     $req->{bound} = 0;
 143 }
 144
 145 sub Bind {
 146     my ($req) = @_;
 147     tie ${$req->{in}}, 'FCGI::Stream', $req, FCGI_STDIN;
 148     tie ${$req->{out}}, 'FCGI::Stream', $req, FCGI_STDOUT;
 149     tie ${$req->{err}}, 'FCGI::Stream', $req, FCGI_STDERR;
 150     $req->{bound} = 1;
 151 }
 152
 153 sub Attach {
 154     my ($req) = @_;
 155     $req->Bind() if ($req->{accepted} && !$req->{bound});
 156 }
 157
 158 sub Detach {
 159     my ($req) = @_;
 160     $req->UndoBindings() if ($req->{accepted} && $req->{bound});
 161 }
 162
 163 sub Finish {
 164     my ($req) = @_;
 165     return unless $req->{accepted};
 166     if ($req->{bound}) {
 167         $req->UndoBindings();
 168         close ${$req->{out}};
 169         close ${$req->{err}};
 170     }
 171     $req->{accepted} = 0;
 172 }
 173
 174 sub LastCall {
 175     shift->{last} = 1;
 176 }
 177
 178 sub DESTROY {
 179     shift->Finish();
 180 }
 181
 182 sub read_record {
 183     my ($self) = @_;
 184     my ($header, $body);
 185
 186     read($self->{socket}, $header, 8);
 187     my ($version, $type, $id, $clen, $plen) = unpack("CCnnC", $header);
 188     read($self->{socket}, $body, $clen+$plen);
 189     $body = undef if $clen == 0;
 190     ($type, $id, $body);
 191 }
 192
 193 sub read {
 194     my ($self, $rtype, $len) = @_;
 195     while (length $self->{buf} < $len) {
 196         my ($type, $id, $buf) = $self->read_record();
 197         return undef unless defined $buf;
 198         if ($type != $rtype) {
 199             $self->{error} = "unexpected stream type";
 200             return 0;
 201         }
 202         $self->{buf} .= $buf;
 203     }
 204     my ($newbuf, $result) = (substr($self->{buf}, $len),
 205                              substr($self->{buf}, 0, $len));
 206     $self->{buf} = $newbuf;
 207     $result;
 208 }
 209
 210 sub Flush {
 211     my ($req) = @_;
 212 }
 213
 214 sub write {
 215     my ($self, $type, $content, $len) = @_;
 216     return unless $len > 0;
 217     $self->write_record($type, $content, $len);
 218 }
 219
 220 sub write_record {
 221     my ($self, $type, $content, $length) = @_;
 222     my $offset = 0;
 223     while ($length > 0) {
 224         my $len = $length > 32*1024 ? 32*1024 : $length;
 225         my $padlen = (8 - ($len % 8)) % 8;
 226         my $templ = "CCnnCxa${len}x$padlen";
 227         my $data = pack($templ,
 228                         VERSION_1, $type, $self->{id}, $len, $padlen,
 229                         substr($content, $offset, $len));
 230         syswrite $self->{socket}, $data;
 231         $length -= $len;
 232         $offset += $len;
 233     }
 234 }
 235
 236 { package FCGI::Stream;
 237
 238 sub new {
 239     my ($class, $src, $type) = @_;
 240     my $handle = do { \local *FH };
 241     tie($$handle, $class, $src, $type);
 242     $handle;
 243 }
 244
 245 sub TIEHANDLE {
 246     my ($class, $src, $type) = @_;
 247     bless { src => $src, type => $type }, $class;
 248 }
 249
 250 sub READ {
 251     my ($stream, undef, $len, $offset) = @_;
 252     my ($ref) = \$_[1];
 253     my $buf = $stream->{src}->read($stream->{type}, $len);
 254     return undef unless defined $buf;
 255     substr($$ref, $offset, 0, $buf);
 256     length $buf;
 257 }
 258
 259 sub PRINT {
 260     my ($stream) = shift;
 261     for (@_) {
 262         $stream->{src}->write($stream->{type}, $_, length($_));
 263     }
 264 }
 265
 266 sub CLOSE {
 267     my ($stream) = @_;
 268     $stream->{src}->write_record($stream->{type}, undef, 0);
 269 }
 270
 271 }
 272
 273 EOP
 274 print OUT while <DATA>;
 275 close OUT;
 276 __END__
 277
 278 # Preloaded methods go here.
 279
 280 # Autoload methods go after __END__, and are processed by the autosplit program.
 281
 282 *FAIL_ACCEPT_ON_INTR = sub() { 1 };
 283
 284 sub Request(;***$*$) {
 285     my @defaults = (\*STDIN, \*STDOUT, \*STDERR, \%ENV, 0, 0);
 286     $_[4] = fileno($_[4]) if defined($_[4]) && defined(fileno($_[4]));
 287     splice @defaults,0,@_,@_;
 288     RequestX(@defaults);
 289 }
 290
 291 sub accept() {
 292     warn "accept called as a method; you probably wanted to call Accept" if @_;
 293     if (defined %FCGI::ENV) {
 294         %ENV = %FCGI::ENV;
 295     } else {
 296         %FCGI::ENV = %ENV;
 297     }
 298     my $rc = Accept($global_request);
 299     for (keys %FCGI::ENV) {
 300         $ENV{$_} = $FCGI::ENV{$_} unless exists $ENV{$_};
 301     }
 302
 303     # not SFIO
 304     $SIG{__WARN__} = $warn_handler if (tied (*STDIN));
 305     $SIG{__DIE__} = $die_handler if (tied (*STDIN));
 306
 307     return $rc;
 308 }
 309
 310 sub finish() {
 311     warn "finish called as a method; you probably wanted to call Finish" if @_;
 312     %ENV = %FCGI::ENV if (defined %FCGI::ENV);
 313
 314     # not SFIO
 315     if (tied (*STDIN)) {
 316         delete $SIG{__WARN__} if ($SIG{__WARN__} == $warn_handler);
 317         delete $SIG{__DIE__} if ($SIG{__DIE__} == $die_handler);
 318     }
 319
 320     Finish ($global_request);
 321 }
 322
 323 sub flush() {
 324     warn "flush called as a method; you probably wanted to call Flush" if @_;
 325     Flush($global_request);
 326 }
 327
 328 sub detach() {
 329     warn "detach called as a method; you probably wanted to call Detach" if @_;
 330     Detach($global_request);
 331 }
 332
 333 sub attach() {
 334     warn "attach called as a method; you probably wanted to call Attach" if @_;
 335     Attach($global_request);
 336 }
 337
 338 # deprecated
 339 sub set_exit_status {
 340 }
 341
 342 sub start_filter_data() {
 343     StartFilterData($global_request);
 344 }
 345
 346 $global_request = Request();
 347 $warn_handler = sub { print STDERR @_ };
 348 $die_handler = sub { print STDERR @_ unless $^S };
 349
 350 package FCGI::Stream;
 351
 352 sub PRINTF {
 353   shift->PRINT(sprintf(shift, @_));
 354 }
 355
 356 sub BINMODE {
 357 }
 358
 359 sub READLINE {
 360     my $stream = shift;
 361     my ($s, $c);
 362     my $rs = $/ eq '' ? "\n\n" : $/;
 363     my $l = substr $rs, -1;
 364     my $len = length $rs;
 365
 366     $c = $stream->GETC();
 367     if ($/ eq '') {
 368         while ($c eq "\n") {
 369             $c = $stream->GETC();
 370         }
 371     }
 372     while (defined $c) {
 373         $s .= $c;
 374         last if $c eq $l and substr($s, -$len) eq $rs;
 375         $c = $stream->GETC();
 376     }
 377     $s;
 378 }
 379
 380 sub OPEN {
 381     $_[0]->CLOSE;
 382     if (@_ == 2) {
 383         return open($_[0], $_[1]);
 384     } else {
 385         my $rc;
 386         eval("$rc = open($_[0], $_[1], $_[2])");
 387         die $@ if $@;
 388         return $rc;
 389     }
 390 }
 391
 392 # Apparently some use fileno to determine if a filehandle is open,
 393 # so we might want to return a defined, but meaningless value.
 394 # An alternative would be to return the fcgi stream fd.
 395 # sub FILENO { -2 }
 396
 397 1;
 398
 399 =pod
 400
 401 =head1 NAME
 402
 403 FCGI - Fast CGI module
 404
 405 =head1 SYNOPSIS
 406
 407     use FCGI;
 408
 409     my $count = 0;
 410     my $request = FCGI::Request();
 411
 412     while($request->Accept() >= 0) {
 413         print("Content-type: text/html\r\n\r\n", ++$count);
 414     }
 415
 416 =head1 DESCRIPTION
 417
 418 Functions:
 419
 420 =over 4
 421
 422 =item FCGI::Request
 423
 424 Creates a request handle. It has the following optional parameters:
 425
 426 =over 8
 427
 428 =item input perl file handle (default: \*STDIN)
 429
 430 =item output perl file handle (default: \*STDOUT)
 431
 432 =item error perl file handle (default: \*STDERR)
 433
 434 These filehandles will be setup to act as input/output/error
 435 on succesful Accept.
 436
 437 =item environment hash reference (default: \%ENV)
 438
 439 The hash will be populated with the environment.
 440
 441 =item socket (default: 0)
 442
 443 Socket to communicate with the server.
 444 Can be the result of the OpenSocket function.
 445 For the moment, it's the file descriptor of the socket
 446 that should be passed. This may change in the future.
 447
 448 You should only use your own socket if your program
 449 is not started by a process manager such as mod_fastcgi
 450 (except for the FastCgiExternalServer case) or cgi-fcgi.
 451 If you use the option, you have to let your FastCGI
 452 server know which port (and possibly server) your program
 453 is listening on.
 454 See remote.pl for an example.
 455
 456 =item flags (default: 0)
 457
 458 Possible values:
 459
 460 =over 12
 461
 462 =item FCGI::FAIL_ACCEPT_ON_INTR
 463
 464 If set, Accept will fail if interrupted.
 465 It not set, it will just keep on waiting.
 466
 467 =back
 468
 469 =back
 470
 471 Example usage:
 472     my $req = FCGI::Request;
 473
 474 or:
 475     my %env;
 476     my $in = new IO::Handle;
 477     my $out = new IO::Handle;
 478     my $err = new IO::Handle;
 479     my $req = FCGI::Request($in, $out, $err, \%env);
 480
 481 =item FCGI::OpenSocket(path, backlog)
 482
 483 Creates a socket suitable to use as an argument to Request.
 484
 485 =over 8
 486
 487 =item path
 488
 489 Pathname of socket or colon followed by local tcp port.
 490 Note that some systems take file permissions into account
 491 on Unix domain sockets, so you'll have to make sure that
 492 the server can write to the created file, by changing
 493 the umask before the call and/or changing permissions and/or
 494 group of the file afterwards.
 495
 496 =item backlog
 497
 498 Maximum length of the queue of pending connections.
 499 If a connection
 500 request arrives with the queue full the client may receive
 501 an  error  with  an  indication of ECONNREFUSED.
 502
 503 =back
 504
 505 =item FCGI::CloseSocket(socket)
 506
 507 Close a socket opened with OpenSocket.
 508
 509 =item $req->Accept()
 510
 511 Accepts a connection on $req, attaching the filehandles and
 512 populating the environment hash.
 513 Returns 0 on success.
 514 If a connection has been accepted before, the old
 515 one will be finished first.
 516
 517 Note that unlike with the old interface, no die and warn
 518 handlers are installed by default. This means that if
 519 you are not running an sfio enabled perl, any warn or
 520 die message will not end up in the server's log by default.
 521 It is advised you set up die and warn handlers yourself.
 522 FCGI.pm contains an example of die and warn handlers.
 523
 524 =item $req->Finish()
 525
 526 Finishes accepted connection.
 527 Also detaches filehandles.
 528
 529 =item $req->Flush()
 530
 531 Flushes accepted connection.
 532
 533 =item $req->Detach()
 534
 535 Temporarily detaches filehandles on an accepted connection.
 536
 537 =item $req->Attach()
 538
 539 Re-attaches filehandles on an accepted connection.
 540
 541 =item $req->LastCall()
 542
 543 Tells the library not to accept any more requests on this handle.
 544 It should be safe to call this method from signal handlers.
 545
 546 Note that this method is still experimental and everything
 547 about it, including its name, is subject to change.
 548
 549 =item $env = $req->GetEnvironment()
 550
 551 Returns the environment parameter passed to FCGI::Request.
 552
 553 =item ($in, $out, $err) = $req->GetHandles()
 554
 555 Returns the file handle parameters passed to FCGI::Request.
 556
 557 =item $isfcgi = $req->IsFastCGI()
 558
 559 Returns whether or not the program was run as a FastCGI.
 560
 561 =back
 562
 563 =head1 AUTHOR
 564
 565 Sven Verdoolaege <skimo@kotnet.org>
 566
 567 =cut
 568
 569 __END__