perl/FCGI.PL

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