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.26 2001/08/22 17:20:20 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     $_[4] = fileno($_[4]) if defined(fileno($_[4]));
 267     splice @defaults,0,@_,@_;
 268     RequestX(@defaults);
 269 }
 270
 271 sub accept() {
 272     warn "accept called as a method; you probably wanted to call Accept" if @_;
 273     if (defined %FCGI::ENV) {
 274         %ENV = %FCGI::ENV;
 275     } else {
 276         %FCGI::ENV = %ENV;
 277     }
 278     my $rc = Accept($global_request);
 279     for (keys %FCGI::ENV) {
 280         $ENV{$_} = $FCGI::ENV{$_} unless exists $ENV{$_};
 281     }
 282
 283     # not SFIO
 284     $SIG{__WARN__} = $warn_handler if (tied (*STDIN));
 285     $SIG{__DIE__} = $die_handler if (tied (*STDIN));
 286
 287     return $rc;
 288 }
 289
 290 sub finish() {
 291     warn "finish called as a method; you probably wanted to call Finish" if @_;
 292     %ENV = %FCGI::ENV if (defined %FCGI::ENV);
 293
 294     # not SFIO
 295     if (tied (*STDIN)) {
 296         delete $SIG{__WARN__} if ($SIG{__WARN__} == $warn_handler);
 297         delete $SIG{__DIE__} if ($SIG{__DIE__} == $die_handler);
 298     }
 299
 300     Finish ($global_request);
 301 }
 302
 303 sub flush() {
 304     warn "flush called as a method; you probably wanted to call Flush" if @_;
 305     Flush($global_request);
 306 }
 307
 308 sub detach() {
 309     warn "detach called as a method; you probably wanted to call Detach" if @_;
 310     Detach($global_request);
 311 }
 312
 313 sub attach() {
 314     warn "attach called as a method; you probably wanted to call Attach" if @_;
 315     Attach($global_request);
 316 }
 317
 318 # deprecated
 319 sub set_exit_status {
 320 }
 321
 322 sub start_filter_data() {
 323     StartFilterData($global_request);
 324 }
 325
 326 $global_request = Request();
 327 $warn_handler = sub { print STDERR @_ };
 328 $die_handler = sub { print STDERR @_ unless $^S };
 329
 330 package FCGI::Stream;
 331
 332 sub PRINTF {
 333   shift->PRINT(sprintf(shift, @_));
 334 }
 335
 336 sub BINMODE {
 337 }
 338
 339 sub READLINE {
 340     my $stream = shift;
 341     my ($s, $c);
 342     my $rs = $/ eq '' ? "\n\n" : $/;
 343     my $l = substr $rs, -1;
 344     my $len = length $rs;
 345
 346     $c = $stream->GETC();
 347     if ($/ eq '') {
 348         while ($c eq "\n") {
 349             $c = $stream->GETC();
 350         }
 351     }
 352     while (defined $c) {
 353         $s .= $c;
 354         last if $c eq $l and substr($s, -$len) eq $rs;
 355         $c = $stream->GETC();
 356     }
 357     $s;
 358 }
 359
 360 sub OPEN {
 361     $_[0]->CLOSE;
 362     if (@_ == 2) {
 363         return open($_[0], $_[1]);
 364     } else {
 365         my $rc;
 366         eval("$rc = open($_[0], $_[1], $_[2])");
 367         die $@ if $@;
 368         return $rc;
 369     }
 370 }
 371
 372 1;
 373
 374 =pod
 375
 376 =head1 NAME
 377
 378 FCGI - Fast CGI module
 379
 380 =head1 SYNOPSIS
 381
 382     use FCGI;
 383
 384     my $count = 0;
 385     my $request = FCGI::Request();
 386
 387     while($request->Accept() >= 0) {
 388         print("Content-type: text/html\r\n\r\n", ++$count);
 389     }
 390
 391 =head1 DESCRIPTION
 392
 393 Functions:
 394
 395 =over 4
 396
 397 =item FCGI::Request
 398
 399 Creates a request handle. It has the following optional parameters:
 400
 401 =over 8
 402
 403 =item input perl file handle (default: \*STDIN)
 404
 405 =item output perl file handle (default: \*STDOUT)
 406
 407 =item error perl file handle (default: \*STDERR)
 408
 409 These filehandles will be setup to act as input/output/error
 410 on succesful Accept.
 411
 412 =item environment hash reference (default: \%ENV)
 413
 414 The hash will be populated with the environment.
 415
 416 =item socket (default: 0)
 417
 418 Socket to communicate with the server.
 419 Can be the result of the OpenSocket function.
 420 For the moment, it's the file descriptor of the socket
 421 that should be passed. This may change in the future.
 422
 423 You should only use your own socket if your program
 424 is not started by a process manager such as mod_fastcgi
 425 (except for the FastCgiExternalServer case) or cgi-fcgi.
 426 If you use the option, you have to let your FastCGI
 427 server know which port (and possibly server) your program
 428 is listening on.
 429 See remote.pl for an example.
 430
 431 =item flags (default: 0)
 432
 433 Possible values:
 434
 435 =over 12
 436
 437 =item FCGI::FAIL_ACCEPT_ON_INTR
 438
 439 If set, Accept will fail if interrupted.
 440 It not set, it will just keep on waiting.
 441
 442 =back
 443
 444 =back
 445
 446 Example usage:
 447     my $req = FCGI::Request;
 448
 449 or:
 450     my %env;
 451     my $in = new IO::Handle;
 452     my $out = new IO::Handle;
 453     my $err = new IO::Handle;
 454     my $req = FCGI::Request($in, $out, $err, \%env);
 455
 456 =item FCGI::OpenSocket(path, backlog)
 457
 458 Creates a socket suitable to use as an argument to Request.
 459
 460 =over 8
 461
 462 =item path
 463
 464 Pathname of socket or colon followed by local tcp port.
 465 Note that some systems take file permissions into account
 466 on Unix domain sockets, so you'll have to make sure that
 467 the server can write to the created file, by changing
 468 the umask before the call and/or changing permissions and/or
 469 group of the file afterwards.
 470
 471 =item backlog
 472
 473 Maximum length of the queue of pending connections.
 474 If a connection
 475 request arrives with the queue full the client may receive
 476 an  error  with  an  indication of ECONNREFUSED.
 477
 478 =back
 479
 480 =item FCGI::CloseSocket(socket)
 481
 482 Close a socket opened with OpenSocket.
 483
 484 =item $req->Accept()
 485
 486 Accepts a connection on $req, attaching the filehandles and
 487 populating the environment hash.
 488 Returns 0 on success.
 489 If a connection has been accepted before, the old
 490 one will be finished first.
 491
 492 Note that unlike with the old interface, no die and warn
 493 handlers are installed by default. This means that if
 494 you are not running an sfio enabled perl, any warn or
 495 die message will not end up in the server's log by default.
 496 It is advised you set up die and warn handlers yourself.
 497 FCGI.pm contains an example of die and warn handlers.
 498
 499 =item $req->Finish()
 500
 501 Finishes accepted connection.
 502 Also detaches filehandles.
 503
 504 =item $req->Flush()
 505
 506 Flushes accepted connection.
 507
 508 =item $req->Detach()
 509
 510 Temporarily detaches filehandles on an accepted connection.
 511
 512 =item $req->Attach()
 513
 514 Re-attaches filehandles on an accepted connection.
 515
 516 =item $env = $req->GetEnvironment()
 517
 518 Returns the environment parameter passed to FCGI::Request.
 519
 520 =item ($in, $out, $err) = $req->GetHandles()
 521
 522 Returns the file handle parameters passed to FCGI::Request.
 523
 524 =item $isfcgi = $req->IsFastCGI()
 525
 526 Returns whether or not the program was run as a FastCGI.
 527
 528 =back
 529
 530 =head1 AUTHOR
 531
 532 Sven Verdoolaege <skimo@kotnet.org>
 533
 534 =cut
 535
 536 __END__