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 package FCGI::Stream;
 297
 298 sub PRINTF {
 299   shift->PRINT(sprintf(shift, @_));
 300 }
 301
 302 sub BINMODE {
 303 }
 304
 305 sub READLINE {
 306     my $stream = shift;
 307     my ($s, $c);
 308     my $rs = $/ eq '' ? "\n\n" : $/;
 309     my $l = substr $rs, -1;
 310     my $len = length $rs;
 311
 312     $c = $stream->GETC();
 313     if ($/ eq '') {
 314         while ($c eq "\n") {
 315             $c = $stream->GETC();
 316         }
 317     }
 318     while (defined $c) {
 319         $s .= $c;
 320         last if $c eq $l and substr($s, -$len) eq $rs;
 321         $c = $stream->GETC();
 322     }
 323     $s;
 324 }
 325
 326 sub OPEN {
 327     $_[0]->CLOSE;
 328     if (@_ == 2) {
 329         return open($_[0], $_[1]);
 330     } else {
 331         my $rc;
 332         eval("$rc = open($_[0], $_[1], $_[2])");
 333         die $@ if $@;
 334         return $rc;
 335     }
 336 }
 337
 338 # Some things (e.g. IPC::Run) use fileno to determine if a filehandle is open,
 339 # so we return a defined, but meaningless value. (-1 being the error return
 340 # value from the syscall in c, meaning it can never be a valid fd no)
 341 # Probably a better alternative would be to return the fcgi stream fd.
 342 sub FILENO { -1 }
 343
 344 1;
 345
 346 =pod
 347
 348 =head1 NAME
 349
 350 FCGI - Fast CGI module
 351
 352 =head1 SYNOPSIS
 353
 354     use FCGI;
 355
 356     my $count = 0;
 357     my $request = FCGI::Request();
 358
 359     while($request->Accept() >= 0) {
 360         print("Content-type: text/html\r\n\r\n", ++$count);
 361     }
 362
 363 =head1 DESCRIPTION
 364
 365 Functions:
 366
 367 =over 4
 368
 369 =item FCGI::Request
 370
 371 Creates a request handle. It has the following optional parameters:
 372
 373 =over 8
 374
 375 =item input perl file handle (default: \*STDIN)
 376
 377 =item output perl file handle (default: \*STDOUT)
 378
 379 =item error perl file handle (default: \*STDERR)
 380
 381 These filehandles will be setup to act as input/output/error
 382 on successful Accept.
 383
 384 =item environment hash reference (default: \%ENV)
 385
 386 The hash will be populated with the environment.
 387
 388 =item socket (default: 0)
 389
 390 Socket to communicate with the server.
 391 Can be the result of the OpenSocket function.
 392 For the moment, it's the file descriptor of the socket
 393 that should be passed. This may change in the future.
 394
 395 You should only use your own socket if your program
 396 is not started by a process manager such as mod_fastcgi
 397 (except for the FastCgiExternalServer case) or cgi-fcgi.
 398 If you use the option, you have to let your FastCGI
 399 server know which port (and possibly server) your program
 400 is listening on.
 401 See remote.pl for an example.
 402
 403 =item flags (default: 0)
 404
 405 Possible values:
 406
 407 =over 12
 408
 409 =item FCGI::FAIL_ACCEPT_ON_INTR
 410
 411 If set, Accept will fail if interrupted.
 412 It not set, it will just keep on waiting.
 413
 414 =back
 415
 416 =back
 417
 418 Example usage:
 419     my $req = FCGI::Request;
 420
 421 or:
 422     my %env;
 423     my $in = new IO::Handle;
 424     my $out = new IO::Handle;
 425     my $err = new IO::Handle;
 426     my $req = FCGI::Request($in, $out, $err, \%env);
 427
 428 =item FCGI::OpenSocket(path, backlog)
 429
 430 Creates a socket suitable to use as an argument to Request.
 431
 432 =over 8
 433
 434 =item path
 435
 436 Pathname of socket or colon followed by local tcp port.
 437 Note that some systems take file permissions into account
 438 on Unix domain sockets, so you'll have to make sure that
 439 the server can write to the created file, by changing
 440 the umask before the call and/or changing permissions and/or
 441 group of the file afterwards.
 442
 443 =item backlog
 444
 445 Maximum length of the queue of pending connections.
 446 If a connection
 447 request arrives with the queue full the client may receive
 448 an  error  with  an  indication of ECONNREFUSED.
 449
 450 =back
 451
 452 =item FCGI::CloseSocket(socket)
 453
 454 Close a socket opened with OpenSocket.
 455
 456 =item $req->Accept()
 457
 458 Accepts a connection on $req, attaching the filehandles and
 459 populating the environment hash.
 460 Returns 0 on success.
 461 If a connection has been accepted before, the old
 462 one will be finished first.
 463
 464 Note that unlike with the old interface, no die and warn
 465 handlers are installed by default. This means that if
 466 you are not running an sfio enabled perl, any warn or
 467 die message will not end up in the server's log by default.
 468 It is advised you set up die and warn handlers yourself.
 469 FCGI.pm contains an example of die and warn handlers.
 470
 471 =item $req->Finish()
 472
 473 Finishes accepted connection.
 474 Also detaches filehandles.
 475
 476 =item $req->Flush()
 477
 478 Flushes accepted connection.
 479
 480 =item $req->Detach()
 481
 482 Temporarily detaches filehandles on an accepted connection.
 483
 484 =item $req->Attach()
 485
 486 Re-attaches filehandles on an accepted connection.
 487
 488 =item $req->LastCall()
 489
 490 Tells the library not to accept any more requests on this handle.
 491 It should be safe to call this method from signal handlers.
 492
 493 Note that this method is still experimental and everything
 494 about it, including its name, is subject to change.
 495
 496 =item $env = $req->GetEnvironment()
 497
 498 Returns the environment parameter passed to FCGI::Request.
 499
 500 =item ($in, $out, $err) = $req->GetHandles()
 501
 502 Returns the file handle parameters passed to FCGI::Request.
 503
 504 =item $isfcgi = $req->IsFastCGI()
 505
 506 Returns whether or not the program was run as a FastCGI.
 507
 508 =back
 509
 510 =HEAD1 LIMITATIONS
 511
 512 FCGI.pm isn't Unicode aware, only characters within the range 0x00-0xFF are
 513 supported. Attempts to output strings containing characters above 0xFF results
 514 in a exception: (F) C<Wide character in %s>.
 515
 516 Users who wants the previous (FCGI.pm <= 0.68) incorrect behavior can disable the
 517 exception by using the C<bytes> pragma.
 518
 519     {
 520         use bytes;
 521         print "\x{263A}";
 522     }
 523
 524
 525 =head1 AUTHOR
 526
 527 Sven Verdoolaege <skimo@kotnet.org>
 528
 529 =cut
 530
 531 __END__