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