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