perl/FCGI.PL

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