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