perl/FCGI.PL

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