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     return 1;
 268 }
 269
 270 sub CLOSE {
 271     my ($stream) = @_;
 272     $stream->{src}->write_record($stream->{type}, undef, 0);
 273 }
 274
 275 }
 276
 277 EOP
 278 print OUT while <DATA>;
 279 close OUT;
 280 __END__
 281
 282 # Preloaded methods go here.
 283
 284 # Autoload methods go after __END__, and are processed by the autosplit program.
 285
 286 *FAIL_ACCEPT_ON_INTR = sub() { 1 };
 287
 288 sub Request(;***$*$) {
 289     my @defaults = (\*STDIN, \*STDOUT, \*STDERR, \%ENV, 0, FAIL_ACCEPT_ON_INTR());
 290     $_[4] = fileno($_[4]) if defined($_[4]) && defined(fileno($_[4]));
 291     splice @defaults,0,@_,@_;
 292     RequestX(@defaults);
 293 }
 294
 295 sub accept() {
 296     warn "accept called as a method; you probably wanted to call Accept" if @_;
 297     if (%FCGI::ENV) {
 298         %ENV = %FCGI::ENV;
 299     } else {
 300         %FCGI::ENV = %ENV;
 301     }
 302     my $rc = Accept($global_request);
 303     for (keys %FCGI::ENV) {
 304         $ENV{$_} = $FCGI::ENV{$_} unless exists $ENV{$_};
 305     }
 306
 307     # not SFIO
 308     $SIG{__WARN__} = $warn_handler if (tied (*STDIN));
 309     $SIG{__DIE__} = $die_handler if (tied (*STDIN));
 310
 311     return $rc;
 312 }
 313
 314 sub finish() {
 315     warn "finish called as a method; you probably wanted to call Finish" if @_;
 316     %ENV = %FCGI::ENV if %FCGI::ENV;
 317
 318     # not SFIO
 319     if (tied (*STDIN)) {
 320         delete $SIG{__WARN__} if ($SIG{__WARN__} == $warn_handler);
 321         delete $SIG{__DIE__} if ($SIG{__DIE__} == $die_handler);
 322     }
 323
 324     Finish ($global_request);
 325 }
 326
 327 sub flush() {
 328     warn "flush called as a method; you probably wanted to call Flush" if @_;
 329     Flush($global_request);
 330 }
 331
 332 sub detach() {
 333     warn "detach called as a method; you probably wanted to call Detach" if @_;
 334     Detach($global_request);
 335 }
 336
 337 sub attach() {
 338     warn "attach called as a method; you probably wanted to call Attach" if @_;
 339     Attach($global_request);
 340 }
 341
 342 # deprecated
 343 sub set_exit_status {
 344 }
 345
 346 sub start_filter_data() {
 347     StartFilterData($global_request);
 348 }
 349
 350 $global_request = Request();
 351 $warn_handler = sub { print STDERR @_ };
 352 $die_handler = sub { print STDERR @_ unless $^S };
 353
 354 package FCGI::Stream;
 355
 356 sub PRINTF {
 357   shift->PRINT(sprintf(shift, @_));
 358 }
 359
 360 sub BINMODE {
 361 }
 362
 363 sub READLINE {
 364     my $stream = shift;
 365     my ($s, $c);
 366     my $rs = $/ eq '' ? "\n\n" : $/;
 367     my $l = substr $rs, -1;
 368     my $len = length $rs;
 369
 370     $c = $stream->GETC();
 371     if ($/ eq '') {
 372         while ($c eq "\n") {
 373             $c = $stream->GETC();
 374         }
 375     }
 376     while (defined $c) {
 377         $s .= $c;
 378         last if $c eq $l and substr($s, -$len) eq $rs;
 379         $c = $stream->GETC();
 380     }
 381     $s;
 382 }
 383
 384 sub OPEN {
 385     $_[0]->CLOSE;
 386     if (@_ == 2) {
 387         return open($_[0], $_[1]);
 388     } else {
 389         my $rc;
 390         eval("$rc = open($_[0], $_[1], $_[2])");
 391         die $@ if $@;
 392         return $rc;
 393     }
 394 }
 395
 396 # Some things (e.g. IPC::Run) use fileno to determine if a filehandle is open,
 397 # so we return a defined, but meaningless value. (-1 being the error return
 398 # value from the syscall in c, meaning it can never be a valid fd no)
 399 # Probably a better alternative would be to return the fcgi stream fd.
 400 sub FILENO { -1 }
 401
 402 1;
 403
 404 =pod
 405
 406 =head1 NAME
 407
 408 FCGI - Fast CGI module
 409
 410 =head1 SYNOPSIS
 411
 412     use FCGI;
 413
 414     my $count = 0;
 415     my $request = FCGI::Request();
 416
 417     while($request->Accept() >= 0) {
 418         print("Content-type: text/html\r\n\r\n", ++$count);
 419     }
 420
 421 =head1 DESCRIPTION
 422
 423 Functions:
 424
 425 =over 4
 426
 427 =item FCGI::Request
 428
 429 Creates a request handle. It has the following optional parameters:
 430
 431 =over 8
 432
 433 =item input perl file handle (default: \*STDIN)
 434
 435 =item output perl file handle (default: \*STDOUT)
 436
 437 =item error perl file handle (default: \*STDERR)
 438
 439 These filehandles will be setup to act as input/output/error
 440 on successful Accept.
 441
 442 =item environment hash reference (default: \%ENV)
 443
 444 The hash will be populated with the environment.
 445
 446 =item socket (default: 0)
 447
 448 Socket to communicate with the server.
 449 Can be the result of the OpenSocket function.
 450 For the moment, it's the file descriptor of the socket
 451 that should be passed. This may change in the future.
 452
 453 You should only use your own socket if your program
 454 is not started by a process manager such as mod_fastcgi
 455 (except for the FastCgiExternalServer case) or cgi-fcgi.
 456 If you use the option, you have to let your FastCGI
 457 server know which port (and possibly server) your program
 458 is listening on.
 459 See remote.pl for an example.
 460
 461 =item flags (default: 0)
 462
 463 Possible values:
 464
 465 =over 12
 466
 467 =item FCGI::FAIL_ACCEPT_ON_INTR
 468
 469 If set, Accept will fail if interrupted.
 470 It not set, it will just keep on waiting.
 471
 472 =back
 473
 474 =back
 475
 476 Example usage:
 477     my $req = FCGI::Request;
 478
 479 or:
 480     my %env;
 481     my $in = new IO::Handle;
 482     my $out = new IO::Handle;
 483     my $err = new IO::Handle;
 484     my $req = FCGI::Request($in, $out, $err, \%env);
 485
 486 =item FCGI::OpenSocket(path, backlog)
 487
 488 Creates a socket suitable to use as an argument to Request.
 489
 490 =over 8
 491
 492 =item path
 493
 494 Pathname of socket or colon followed by local tcp port.
 495 Note that some systems take file permissions into account
 496 on Unix domain sockets, so you'll have to make sure that
 497 the server can write to the created file, by changing
 498 the umask before the call and/or changing permissions and/or
 499 group of the file afterwards.
 500
 501 =item backlog
 502
 503 Maximum length of the queue of pending connections.
 504 If a connection
 505 request arrives with the queue full the client may receive
 506 an  error  with  an  indication of ECONNREFUSED.
 507
 508 =back
 509
 510 =item FCGI::CloseSocket(socket)
 511
 512 Close a socket opened with OpenSocket.
 513
 514 =item $req->Accept()
 515
 516 Accepts a connection on $req, attaching the filehandles and
 517 populating the environment hash.
 518 Returns 0 on success.
 519 If a connection has been accepted before, the old
 520 one will be finished first.
 521
 522 Note that unlike with the old interface, no die and warn
 523 handlers are installed by default. This means that if
 524 you are not running an sfio enabled perl, any warn or
 525 die message will not end up in the server's log by default.
 526 It is advised you set up die and warn handlers yourself.
 527 FCGI.pm contains an example of die and warn handlers.
 528
 529 =item $req->Finish()
 530
 531 Finishes accepted connection.
 532 Also detaches filehandles.
 533
 534 =item $req->Flush()
 535
 536 Flushes accepted connection.
 537
 538 =item $req->Detach()
 539
 540 Temporarily detaches filehandles on an accepted connection.
 541
 542 =item $req->Attach()
 543
 544 Re-attaches filehandles on an accepted connection.
 545
 546 =item $req->LastCall()
 547
 548 Tells the library not to accept any more requests on this handle.
 549 It should be safe to call this method from signal handlers.
 550
 551 Note that this method is still experimental and everything
 552 about it, including its name, is subject to change.
 553
 554 =item $env = $req->GetEnvironment()
 555
 556 Returns the environment parameter passed to FCGI::Request.
 557
 558 =item ($in, $out, $err) = $req->GetHandles()
 559
 560 Returns the file handle parameters passed to FCGI::Request.
 561
 562 =item $isfcgi = $req->IsFastCGI()
 563
 564 Returns whether or not the program was run as a FastCGI.
 565
 566 =back
 567
 568 =HEAD1 LIMITATIONS
 569
 570 FCGI.pm isn't Unicode aware, only characters within the range 0x00-0xFF are
 571 supported. Attempts to output strings containing characters above 0xFF results
 572 in a exception: (F) C<Wide character in %s>.
 573
 574 Users who wants the previous (FCGI.pm <= 0.68) incorrect behavior can disable the
 575 exception by using the C<bytes> pragma.
 576
 577     {
 578         use bytes;
 579         print "\x{263A}";
 580     }
 581
 582
 583 =head1 AUTHOR
 584
 585 Sven Verdoolaege <skimo@kotnet.org>
 586
 587 =cut
 588
 589 __END__