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.37 2002/12/15 20:02:48 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         # apparently these are harmful
 169         # close ${$req->{out}};
 170         # close ${$req->{err}};
 171     }
 172     $req->{accepted} = 0;
 173 }
 174
 175 sub LastCall {
 176     shift->{last} = 1;
 177 }
 178
 179 sub DESTROY {
 180     shift->Finish();
 181 }
 182
 183 sub read_record {
 184     my ($self) = @_;
 185     my ($header, $body);
 186
 187     read($self->{socket}, $header, 8);
 188     my ($version, $type, $id, $clen, $plen) = unpack("CCnnC", $header);
 189     read($self->{socket}, $body, $clen+$plen);
 190     $body = undef if $clen == 0;
 191     ($type, $id, $body);
 192 }
 193
 194 sub read {
 195     my ($self, $rtype, $len) = @_;
 196     while (length $self->{buf} < $len) {
 197         my ($type, $id, $buf) = $self->read_record();
 198         return undef unless defined $buf;
 199         if ($type != $rtype) {
 200             $self->{error} = "unexpected stream type";
 201             return 0;
 202         }
 203         $self->{buf} .= $buf;
 204     }
 205     my ($newbuf, $result) = (substr($self->{buf}, $len),
 206                              substr($self->{buf}, 0, $len));
 207     $self->{buf} = $newbuf;
 208     $result;
 209 }
 210
 211 sub Flush {
 212     my ($req) = @_;
 213 }
 214
 215 sub write {
 216     my ($self, $type, $content, $len) = @_;
 217     return unless $len > 0;
 218     $self->write_record($type, $content, $len);
 219 }
 220
 221 sub write_record {
 222     my ($self, $type, $content, $length) = @_;
 223     my $offset = 0;
 224     while ($length > 0) {
 225         my $len = $length > 32*1024 ? 32*1024 : $length;
 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,
 230                         substr($content, $offset, $len));
 231         syswrite $self->{socket}, $data;
 232         $length -= $len;
 233         $offset += $len;
 234     }
 235 }
 236
 237 { package FCGI::Stream;
 238
 239 sub new {
 240     my ($class, $src, $type) = @_;
 241     my $handle = do { \local *FH };
 242     tie($$handle, $class, $src, $type);
 243     $handle;
 244 }
 245
 246 sub TIEHANDLE {
 247     my ($class, $src, $type) = @_;
 248     bless { src => $src, type => $type }, $class;
 249 }
 250
 251 sub READ {
 252     my ($stream, undef, $len, $offset) = @_;
 253     my ($ref) = \$_[1];
 254     my $buf = $stream->{src}->read($stream->{type}, $len);
 255     return undef unless defined $buf;
 256     substr($$ref, $offset, 0, $buf);
 257     length $buf;
 258 }
 259
 260 sub PRINT {
 261     my ($stream) = shift;
 262     for (@_) {
 263         $stream->{src}->write($stream->{type}, $_, length($_));
 264     }
 265 }
 266
 267 sub CLOSE {
 268     my ($stream) = @_;
 269     $stream->{src}->write_record($stream->{type}, undef, 0);
 270 }
 271
 272 }
 273
 274 EOP
 275 print OUT while <DATA>;
 276 close OUT;
 277 __END__
 278
 279 # Preloaded methods go here.
 280
 281 # Autoload methods go after __END__, and are processed by the autosplit program.
 282
 283 *FAIL_ACCEPT_ON_INTR = sub() { 1 };
 284
 285 sub Request(;***$*$) {
 286     my @defaults = (\*STDIN, \*STDOUT, \*STDERR, \%ENV, 0, 0);
 287     $_[4] = fileno($_[4]) if defined($_[4]) && defined(fileno($_[4]));
 288     splice @defaults,0,@_,@_;
 289     RequestX(@defaults);
 290 }
 291
 292 sub accept() {
 293     warn "accept called as a method; you probably wanted to call Accept" if @_;
 294     if (defined %FCGI::ENV) {
 295         %ENV = %FCGI::ENV;
 296     } else {
 297         %FCGI::ENV = %ENV;
 298     }
 299     my $rc = Accept($global_request);
 300     for (keys %FCGI::ENV) {
 301         $ENV{$_} = $FCGI::ENV{$_} unless exists $ENV{$_};
 302     }
 303
 304     # not SFIO
 305     $SIG{__WARN__} = $warn_handler if (tied (*STDIN));
 306     $SIG{__DIE__} = $die_handler if (tied (*STDIN));
 307
 308     return $rc;
 309 }
 310
 311 sub finish() {
 312     warn "finish called as a method; you probably wanted to call Finish" if @_;
 313     %ENV = %FCGI::ENV if (defined %FCGI::ENV);
 314
 315     # not SFIO
 316     if (tied (*STDIN)) {
 317         delete $SIG{__WARN__} if ($SIG{__WARN__} == $warn_handler);
 318         delete $SIG{__DIE__} if ($SIG{__DIE__} == $die_handler);
 319     }
 320
 321     Finish ($global_request);
 322 }
 323
 324 sub flush() {
 325     warn "flush called as a method; you probably wanted to call Flush" if @_;
 326     Flush($global_request);
 327 }
 328
 329 sub detach() {
 330     warn "detach called as a method; you probably wanted to call Detach" if @_;
 331     Detach($global_request);
 332 }
 333
 334 sub attach() {
 335     warn "attach called as a method; you probably wanted to call Attach" if @_;
 336     Attach($global_request);
 337 }
 338
 339 # deprecated
 340 sub set_exit_status {
 341 }
 342
 343 sub start_filter_data() {
 344     StartFilterData($global_request);
 345 }
 346
 347 $global_request = Request();
 348 $warn_handler = sub { print STDERR @_ };
 349 $die_handler = sub { print STDERR @_ unless $^S };
 350
 351 package FCGI::Stream;
 352
 353 sub PRINTF {
 354   shift->PRINT(sprintf(shift, @_));
 355 }
 356
 357 sub BINMODE {
 358 }
 359
 360 sub READLINE {
 361     my $stream = shift;
 362     my ($s, $c);
 363     my $rs = $/ eq '' ? "\n\n" : $/;
 364     my $l = substr $rs, -1;
 365     my $len = length $rs;
 366
 367     $c = $stream->GETC();
 368     if ($/ eq '') {
 369         while ($c eq "\n") {
 370             $c = $stream->GETC();
 371         }
 372     }
 373     while (defined $c) {
 374         $s .= $c;
 375         last if $c eq $l and substr($s, -$len) eq $rs;
 376         $c = $stream->GETC();
 377     }
 378     $s;
 379 }
 380
 381 sub OPEN {
 382     $_[0]->CLOSE;
 383     if (@_ == 2) {
 384         return open($_[0], $_[1]);
 385     } else {
 386         my $rc;
 387         eval("$rc = open($_[0], $_[1], $_[2])");
 388         die $@ if $@;
 389         return $rc;
 390     }
 391 }
 392
 393 # Some things (e.g. IPC::Run) use fileno to determine if a filehandle is open,
 394 # so we return a defined, but meaningless value. (-1 being the error return
 395 # value from the syscall in c, meaning it can never be a valid fd no)
 396 # Probably a better alternative would be to return the fcgi stream fd.
 397 sub FILENO { -1 }
 398
 399 1;
 400
 401 =pod
 402
 403 =head1 NAME
 404
 405 FCGI - Fast CGI module
 406
 407 =head1 SYNOPSIS
 408
 409     use FCGI;
 410
 411     my $count = 0;
 412     my $request = FCGI::Request();
 413
 414     while($request->Accept() >= 0) {
 415         print("Content-type: text/html\r\n\r\n", ++$count);
 416     }
 417
 418 =head1 DESCRIPTION
 419
 420 Functions:
 421
 422 =over 4
 423
 424 =item FCGI::Request
 425
 426 Creates a request handle. It has the following optional parameters:
 427
 428 =over 8
 429
 430 =item input perl file handle (default: \*STDIN)
 431
 432 =item output perl file handle (default: \*STDOUT)
 433
 434 =item error perl file handle (default: \*STDERR)
 435
 436 These filehandles will be setup to act as input/output/error
 437 on succesful Accept.
 438
 439 =item environment hash reference (default: \%ENV)
 440
 441 The hash will be populated with the environment.
 442
 443 =item socket (default: 0)
 444
 445 Socket to communicate with the server.
 446 Can be the result of the OpenSocket function.
 447 For the moment, it's the file descriptor of the socket
 448 that should be passed. This may change in the future.
 449
 450 You should only use your own socket if your program
 451 is not started by a process manager such as mod_fastcgi
 452 (except for the FastCgiExternalServer case) or cgi-fcgi.
 453 If you use the option, you have to let your FastCGI
 454 server know which port (and possibly server) your program
 455 is listening on.
 456 See remote.pl for an example.
 457
 458 =item flags (default: 0)
 459
 460 Possible values:
 461
 462 =over 12
 463
 464 =item FCGI::FAIL_ACCEPT_ON_INTR
 465
 466 If set, Accept will fail if interrupted.
 467 It not set, it will just keep on waiting.
 468
 469 =back
 470
 471 =back
 472
 473 Example usage:
 474     my $req = FCGI::Request;
 475
 476 or:
 477     my %env;
 478     my $in = new IO::Handle;
 479     my $out = new IO::Handle;
 480     my $err = new IO::Handle;
 481     my $req = FCGI::Request($in, $out, $err, \%env);
 482
 483 =item FCGI::OpenSocket(path, backlog)
 484
 485 Creates a socket suitable to use as an argument to Request.
 486
 487 =over 8
 488
 489 =item path
 490
 491 Pathname of socket or colon followed by local tcp port.
 492 Note that some systems take file permissions into account
 493 on Unix domain sockets, so you'll have to make sure that
 494 the server can write to the created file, by changing
 495 the umask before the call and/or changing permissions and/or
 496 group of the file afterwards.
 497
 498 =item backlog
 499
 500 Maximum length of the queue of pending connections.
 501 If a connection
 502 request arrives with the queue full the client may receive
 503 an  error  with  an  indication of ECONNREFUSED.
 504
 505 =back
 506
 507 =item FCGI::CloseSocket(socket)
 508
 509 Close a socket opened with OpenSocket.
 510
 511 =item $req->Accept()
 512
 513 Accepts a connection on $req, attaching the filehandles and
 514 populating the environment hash.
 515 Returns 0 on success.
 516 If a connection has been accepted before, the old
 517 one will be finished first.
 518
 519 Note that unlike with the old interface, no die and warn
 520 handlers are installed by default. This means that if
 521 you are not running an sfio enabled perl, any warn or
 522 die message will not end up in the server's log by default.
 523 It is advised you set up die and warn handlers yourself.
 524 FCGI.pm contains an example of die and warn handlers.
 525
 526 =item $req->Finish()
 527
 528 Finishes accepted connection.
 529 Also detaches filehandles.
 530
 531 =item $req->Flush()
 532
 533 Flushes accepted connection.
 534
 535 =item $req->Detach()
 536
 537 Temporarily detaches filehandles on an accepted connection.
 538
 539 =item $req->Attach()
 540
 541 Re-attaches filehandles on an accepted connection.
 542
 543 =item $req->LastCall()
 544
 545 Tells the library not to accept any more requests on this handle.
 546 It should be safe to call this method from signal handlers.
 547
 548 Note that this method is still experimental and everything
 549 about it, including its name, is subject to change.
 550
 551 =item $env = $req->GetEnvironment()
 552
 553 Returns the environment parameter passed to FCGI::Request.
 554
 555 =item ($in, $out, $err) = $req->GetHandles()
 556
 557 Returns the file handle parameters passed to FCGI::Request.
 558
 559 =item $isfcgi = $req->IsFastCGI()
 560
 561 Returns whether or not the program was run as a FastCGI.
 562
 563 =back
 564
 565 =head1 AUTHOR
 566
 567 Sven Verdoolaege <skimo@kotnet.org>
 568
 569 =cut
 570
 571 __END__