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