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