Girocco/extra/CGI/FCGI.pm

   1 package CGI::FCGI;
   2
   3 # CGI::FCGI -- Alternative Pure Perl CGI::Fast and FCGI implementation
   4 # Copyright (C) 2015,2016,2017,2020,2021 Kyle J. McKay.
   5 # All rights reserved.
   6
   7 # Licensed under the same license as Perl OR GNU GPL v2 or later
   8 # There is NO WARRANTY, to the extent permitted by law.
   9 # See license below starting with '=head1 LICENSE'
  10
  11 # See documentation below starting with '=head1'
  12
  13 # MUST be used BEFORE CGI::Fast and FCGI.
  14
  15 $CGI::FCGI::VERSION = '1.0.1';
  16
  17 use strict;
  18 use warnings;
  19
  20 use Errno;
  21 use Socket;
  22 use Carp 'croak';
  23 use CGI;
  24 our @ISA = ('CGI');
  25
  26 BEGIN {
  27         my $subtoname = sub {
  28                 my $name = shift;
  29                 $name =~ s,::,/,g;
  30                 "$name.pm"
  31         };
  32         my $name = $subtoname->(__PACKAGE__);
  33         $INC{$name} = __FILE__ if !$INC{$name};
  34         foreach my $pkg (qw(CGI::Fast FCGI)) {
  35                 my $pkgn = $subtoname->($pkg);
  36                 croak "Must `use ".__PACKAGE__.";` ".
  37                         "BEFORE `use $pkg;`!"
  38                 if $INC{$pkgn} && $INC{$pkgn} ne $INC{$name};
  39                 $INC{$pkgn} = $INC{$name};
  40         }
  41 }
  42
  43 my %PARAMS;
  44 my %ROLES;
  45 BEGIN {
  46         %PARAMS = (
  47                 FCGI_MAX_CONNS => 1,  # Maximum concurrent connections
  48                 FCGI_MAX_REQS => 1,   # Max concurrent requests on a connection
  49                 FCGI_MPXS_CONNS => 0, # No multiplexing capabilities here
  50         );
  51         %ROLES = (
  52                 1 => "RESPONDER",
  53                 2 => "AUTHORIZER",
  54                 3 => "FILTER",        # Not currently supported
  55         );
  56 }
  57
  58 sub IsFCGI {
  59         open my $fh, '+<&0' or return 0;
  60         return 0 unless getsockname $fh;
  61         defined(my $st = getsockopt($fh, SOL_SOCKET, SO_TYPE)) or return 0;
  62         $st = unpack("i", $st);
  63         defined($st) && $st == SOCK_STREAM or return 0;
  64         return 0 if getpeername $fh;
  65         return $!{ENOTCONN} ? 1 : 0;
  66 }
  67
  68 sub save_request {
  69         # Make sure state's not saved
  70 }
  71
  72 my $is_inited;
  73 my %fcgi;
  74 my %active;
  75 my $generation;
  76
  77 BEGIN {
  78         $generation = 1;
  79 }
  80
  81 sub _init {
  82         return unless !$is_inited;
  83         $is_inited = 1;
  84         undef %active;
  85         undef %fcgi;
  86         croak 'STDIN_FILENO (0) is not an accept socket' unless IsFCGI;
  87         local *ASOCK;
  88         open ASOCK, '<&=0' or croak 'STDIN_FILENO (0) is not valid';
  89         $fcgi{'asock'} = *ASOCK;
  90 }
  91
  92 sub _write_all {
  93         use bytes;
  94         my $fh = shift;
  95         my $data = shift;
  96         return unless defined $data;
  97         my $offset = 0;
  98         my $len = length $data;
  99         while ($len) {
 100                 my $cnt = syswrite $fh, $data, $len, $offset;
 101                 next if !defined($cnt) && $!{EINTR};
 102                 croak "syswrite failed: $!" unless defined $cnt;
 103                 croak "syswrite of $len wrote 0" unless $cnt;
 104                 $offset += $cnt;
 105                 $len -= $cnt;
 106         }
 107 }
 108
 109 sub _read_all {
 110         use bytes;
 111         my $fh = shift;
 112         my $cnt = shift;
 113         my $eofok = shift;
 114         return undef unless defined $cnt && $cnt >= 0;
 115         my $data = '';
 116         my $len = 0;
 117         while ($len < $cnt) {
 118                 my $r = sysread $fh, $data, $cnt - $len, $len;
 119                 next if !defined($r) && $!{EINTR};
 120                 croak "sysread failed: $!" unless defined $r;
 121                 return '' if $eofok && !$r && !$len; # EOF at beginning okay
 122                 croak "sysread of @{[$cnt - $len]} read 0" unless $r;
 123                 $len += $r;
 124         }
 125         return $data;
 126 }
 127
 128 sub _read_discard {
 129         use bytes;
 130         my $fh = shift;
 131         my $cnt = shift;
 132         return undef unless defined $cnt && $cnt >= 0;
 133         my $len = 0;
 134         while ($len < $cnt) {
 135                 my $data;
 136                 my $r = sysread $fh, $data, 32768;
 137                 next if !defined($r) && $!{EINTR};
 138                 croak "sysread failed: $!" unless defined $r;
 139                 croak "sysread of 32768 read 0" unless $r;
 140                 $len += $r;
 141         }
 142         return $cnt;
 143 }
 144
 145 sub _read_one_var {
 146         use bytes;
 147         my $data = shift;
 148         my $offset = shift || 0;
 149         my $discardvalue = shift || 0;
 150         my $len = length($data);
 151         croak "_read_one_var invalid input" unless $offset >= 0 && $offset + 3 <= $len;
 152         my $ptr = $offset;
 153         my $nlen = unpack('C', substr($data, $ptr++, 1));
 154         if ($nlen & 0x80) {
 155                 croak "_read_one_var invalid input" unless $ptr + 5 <= $len;
 156                 my @bytes = unpack('CCC', substr($data, $ptr, 3));
 157                 $ptr += 3;
 158                 $nlen = (($nlen & 0x7f) << 24) | ($bytes[0] << 16) |
 159                         ($bytes[1] << 8) | $bytes[2];
 160         }
 161         my $vlen = unpack('C', substr($data, $ptr++, 1));
 162         if ($vlen & 0x80) {
 163                 croak "_read_one_var invalid input" unless $ptr + 4 <= $len;
 164                 my @bytes = unpack('CCC', substr($data, $ptr, 3));
 165                 $ptr += 3;
 166                 $vlen = (($vlen & 0x7f) << 24) | ($bytes[0] << 16) |
 167                         ($bytes[1] << 8) | $bytes[2];
 168         }
 169         croak "FCGI out of bounds var name/value length" if $ptr + $nlen + $vlen > $len;
 170         if (!$nlen) {
 171                 _read_discard($fcgi{'csock'}, $nlen + $vlen);
 172                 return ("_ZERO_LENGTH_VAR_NAME", "", $ptr - $offset + $nlen + $vlen);
 173         }
 174         if ($nlen > 256) {
 175                 _read_discard($fcgi{'csock'}, $nlen + $vlen);
 176                 return ("_TOO_LONG_VAR_NAME", "", $ptr - $offset + $nlen + $vlen);
 177         }
 178         if ($vlen > 32768) {
 179                 _read_discard($fcgi{'csock'}, $nlen + $vlen);
 180                 return ("_TOO_LONG_VAR_VAL", "", $ptr - $offset + $nlen + $vlen);
 181         }
 182         return (substr($data, $ptr, $nlen),
 183                 ($discardvalue ? undef : substr($data, $ptr+$nlen, $vlen)),
 184                 $ptr - $offset + $nlen + $vlen);
 185 }
 186
 187 sub _encode_length {
 188         use bytes;
 189         my $l = shift;
 190         return pack('C', ($l & 0x7f)) if $l < 128;
 191         my $b3 = $l & 0xff;
 192         $l >>= 8;
 193         my $b2 = $l & 0xff;
 194         $l >>= 8;
 195         my $b1 = $l & 0xff;
 196         $l >>= 8;
 197         my $b0 = $l | 0x80;
 198         return pack('CCCC', $b3, $b2, $b1, $b0);
 199 }
 200
 201 sub _encode_one_var {
 202         my ($n, $v) = @_;
 203         return _encode_length(length($n)).
 204                 _encode_length(length($v)).
 205                 $n.$v;
 206 }
 207
 208 sub _get_padding {
 209         use bytes;
 210         my $len = shift;
 211         my $rem = $len & 0x7;
 212         return '' unless $rem;
 213         return pack('C', 0) x (8 - $rem);
 214 }
 215
 216 sub _write_stream {
 217         use bytes;
 218         my $fh = shift;
 219         my $type = shift;
 220         my $rid = shift;
 221         my $data = shift;
 222         my $force = shift;
 223         return unless ($type == 6 || $type == 7) && length($data) || $force;
 224         while (length($data) > 65535) {
 225                 _write_all($fh, pack('CCnnCC', 1, $type, $rid, 32768, 0, 0).substr($data, 0, 32768));
 226                 substr($data, 0, 32768) = '';
 227         }
 228         my $padding = _get_padding(length($data));
 229         _write_all($fh, pack('CCnnCC', 1, $type, $rid, length($data), length($padding), 0).$data.$padding);
 230 }
 231
 232 sub _write_end_stream {
 233         my $fh = shift;
 234         my $type = shift;
 235         my $rid = shift;
 236         return _write_stream($fh, $type, $rid, '', 1);
 237 }
 238
 239 sub _write_end_request {
 240         use bytes;
 241         my $fh = shift;
 242         my $rid = shift;
 243         my $pstat = shift || 0;
 244         my $astat = shift || 0;
 245         _write_all($fh, pack('CCnnCCNCCCC',
 246                 1, 3, $rid, 8, 0, 0, $astat, $pstat, 0, 0, 0));
 247 }
 248
 249 sub _handle_unknown_packet {
 250         my ($fh, $rid, $clen, $plen) = @_;
 251         croak "FCGI invalid unkown packet content length $clen (must be >= 1)"
 252                 unless $clen >= 1;
 253         my $t = _read_all($fh, 1);
 254         _read_discard($fh, $clen + $plen - 1);
 255         _write_all($fh, pack('CCnnCCCCCCCCCC',
 256                 1, 11, $rid, 8, 0, 0, unpack('C', $t), 0, 0, 0, 0, 0, 0, 0));
 257 }
 258
 259 sub _handle_get_params {
 260         my ($fh, $rid, $clen, $plen) = @_;
 261         my $varnames = _read_all($fh, $clen);
 262         _read_discard($fh, $plen);
 263         my @v = ();
 264         my $offset = 0;
 265         my $len = length($varnames);
 266         while ($offset < $len) {
 267                 my ($n, undef, $b) = _read_one_var($varnames, $offset, 1);
 268                 push(@v, $n);
 269                 $offset += $b;
 270         }
 271         my $vars = '';
 272         $vars = join('',
 273                 map({exists($PARAMS{$_}) ? _encode_one_var($_, $PARAMS{$_}) : ()} @v))
 274         unless $rid;
 275         _write_stream($fh, 10, $rid, $vars, 1);
 276 }
 277
 278 # Can only return types 1, 2, 4, 5, or 8
 279 # And for types 1 and 2 the packet is fully read along with its padding
 280 sub _read_packet {
 281         my $fh = shift;
 282         my $eofok = shift;
 283         my $done;
 284         my ($type, $rid, $clen, $plen);
 285         {
 286                 my $request = _read_all($fh, 8, $eofok);
 287                 return undef if !defined($request) && $eofok;
 288                 my $vers;
 289                 ($vers, $type, $rid, $clen, $plen) = unpack('CCnnC', $request);
 290                 croak "FCGI bad packet header version $vers (should be 1)"
 291                         unless $vers == 1;
 292                 croak "FCGI invalid packet type $type (should be 1..11)"
 293                         unless $type >= 1 && $type <= 11;
 294                 croak "FCGI unexpected packet type $type (should be 1, 2, 4, 5, 8, 9 or 11)"
 295                         if $type == 3 || $type == 6 || $type == 7 || $type == 10;
 296                 _handle_get_params($fh, $rid, $clen, $plen), redo if $type == 9;
 297                 _handle_unknown_packet($fh, $rid, $clen, $plen), redo if $type == 11;
 298                 croak "FCGI invalid BEGIN content length $clen (should be 8)"
 299                         if $type == 1 && $clen != 8;
 300                 croak "FCGI invalid ABORT content length $clen (should be 0)"
 301                         if $type == 2 && $clen != 0;
 302                 croak "FCGI invalid requestId == 0 for BEGIN/ABORT/PARAMS/STDIN/DATA"
 303                         if ($type <= 2 || $type == 4 || $type == 5 || $type == 8) && !$rid;
 304         }
 305         my ($role, $flags);
 306         if ($type == 1) {
 307                 my $begin = _read_all($fh, $clen);
 308                 _read_discard($fh, $plen);
 309                 ($role, $flags) = unpack('nC', $begin);
 310         }
 311         if ($type == 2) {
 312                 _read_discard($fh, $plen);
 313         }
 314         return ($type, $rid, $clen, $plen, $role, $flags);
 315 }
 316
 317 sub _close_active {
 318         return unless $active{'active'};
 319         my $pstat = shift || 0;
 320         my $astat = shift || 0;
 321         my $done = shift || 0;
 322         _write_end_stream($fcgi{'csock'}, 6, $active{'active'}) if $done;
 323         _write_end_request($fcgi{'csock'}, $active{'active'}, $pstat, $astat);
 324         *STDIN = $active{'STDIN'};
 325         *STDOUT = $active{'STDOUT'};
 326         *STDERR = $active{'STDERR'};
 327         %ENV = %{$active{'ENV'}};
 328         $/ = $active{'RS'};
 329         unless ($active{'keep'}) {
 330                 close($fcgi{'csock'});
 331                 undef $fcgi{'csock'};
 332         }
 333         undef %active;
 334         ++$generation;
 335 }
 336
 337 sub _next_request {
 338         _init unless $is_inited;
 339         _close_active(0, 0, 1) if $active{'active'};
 340
 341         RETRY:
 342         while (!$active{'active'}) {
 343                 while (!$fcgi{'csock'}) {
 344                         local *CSOCK;
 345                         unless (accept(CSOCK, $fcgi{'asock'})) {
 346                                 next if $!{EINTR} || $!{ECONNABORTED};
 347                                 croak "accept failed: $!";
 348                         }
 349                         $fcgi{'csock'} = *CSOCK;
 350                 }
 351                 my ($type, $rid, $clen, $plen, $role, $flags) = _read_packet($fcgi{'csock'}, 1);
 352                 if (!$type) {
 353                         close($fcgi{'csock'});
 354                         undef $fcgi{'csock'};
 355                         next;
 356                 }
 357                 _read_discard($fcgi{'csock'}, $clen+$plen), redo if $type == 5 || $type == 8;
 358                 croak "FCGI unexpected packet type $type (expecting 1 -- BEGIN)"
 359                         unless $type == 1;
 360                 if ($role != 1 && $role != 2) {
 361                         _write_end_request($fcgi{'csock'}, $rid, 3);
 362                         unless($flags & 0x01) {
 363                                 close($fcgi{'csock'});
 364                                 undef $fcgi{'csock'};
 365                         }
 366                         next;
 367                 }
 368                 $active{'active'} = $rid;
 369                 $active{'role'} = $role;
 370                 $active{'keep'} = 1 if $flags & 0x01;
 371                 $active{'STDIN'} = *STDIN;
 372                 $active{'STDOUT'} = *STDOUT;
 373                 $active{'STDERR'} = *STDERR;
 374                 my %saveenv = %ENV;
 375                 $active{'ENV'} = \%saveenv;
 376                 $active{'RS'} = $/;
 377         }
 378         my %vars = ();
 379         {
 380                 my ($type, $rid, $clen, $plen) = _read_packet($fcgi{'csock'});
 381                 if ($type == 1) {
 382                         _write_end_request($fcgi{'sock'}, $rid, 1)
 383                                 unless $rid == $active{'active'};
 384                         redo;
 385                 }
 386                 redo unless $rid == $active{'active'};
 387                 if ($type == 2) {
 388                         _close_active;
 389                         goto RETRY;
 390                 }
 391                 croak "FCGI unexpected packet type $type (expecting 4 -- PARAMS)"
 392                         unless $type == 4;
 393                 if ($clen) {
 394                         my $vars = _read_all($fcgi{'csock'}, $clen);
 395                         _read_discard($plen);
 396                         my $offset = 0;
 397                         my $len = length($vars);
 398                         while ($offset < $len) {
 399                                 my ($n, $v, $b) = _read_one_var($vars, $offset);
 400                                 $vars{$n} = $v;
 401                                 $offset += $b;
 402                         }
 403                         redo;
 404                 } else {
 405                         _read_discard($plen);
 406                 }
 407                 $vars{'FCGI_ROLE'} = $ROLES{$active{'role'}}; # We must add this
 408         }
 409         # Tie the streams, set %ENV and off we go!
 410         local *TI;
 411         tie *TI, 'CGI::FCGI::IStream' or croak "CGI::FCGI::IStream tie STDIN failed";
 412         local *TO;
 413         tie *TO, 'CGI::FCGI::OStream', 6 or croak "CGI::FCGI::IStream tie STDOUT failed";
 414         local *TE;
 415         tie *TE, 'CGI::FCGI::OStream', 7 or croak "CGI::FCGI::IStream tie STDERR failed";
 416         *STDIN = *TI;
 417         *STDOUT = *TO;
 418         *STDERR = *TE;
 419         my ($n, $v);
 420         $ENV{$n} = $v while ($n,$v) = each %vars;
 421 }
 422
 423 sub _read_more {
 424         my $min = shift || 1;
 425         return '' unless $active{'active'};
 426         my $ans = '';
 427         while (!$active{'eof'} && $min > 0) {
 428                 my ($type, $rid, $clen, $plen) = _read_packet($fcgi{'csock'});
 429                 if ($type == 1) {
 430                         _write_end_request($fcgi{'sock'}, $rid, 1)
 431                                 unless $rid == $active{'active'};
 432                         redo;
 433                 }
 434                 redo unless $rid == $active{'active'};
 435                 if ($type == 2) {
 436                         _close_active(0, 1);
 437                         exit(1);
 438                 }
 439                 croak "FCGI unexpected packet type $type (expecting 5 -- STDIN)"
 440                         unless $type == 5;
 441                 my $input = _read_all($fcgi{'csock'}, $clen);
 442                 _read_discard($fcgi{'sock'}, $plen);
 443                 $min -= length($input);
 444                 $active{'eof'} = 1 unless length($input);
 445                 $ans .= $input;
 446         }
 447         return $ans;
 448 }
 449
 450 sub _write_more {
 451         my $type = shift;
 452         my $data = shift;
 453         return unless $active{'active'};
 454         _write_stream($fcgi{'csock'}, $type, $active{'active'}, $data)
 455                 if defined($data) && length($data);
 456 }
 457
 458 sub _get_new_class {
 459         use Carp 'croak';
 460         my ($class, $package) = @_;
 461         $package or $package = __PACKAGE__;
 462         my $try = ref $class || $class || $package;
 463         UNIVERSAL::isa($try, $package)
 464                 or croak "Cannot call ${package}::new with a class ($try)".
 465                         " that does not inherit from $package";
 466         return $try;
 467 }
 468
 469 sub new {
 470         my $class = _get_new_class(shift);
 471         $CGI::Q = undef;
 472         CGI->_reset_globals();
 473         $class->_setup_symbols(@CGI::SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS;
 474         _next_request;
 475         my $self = $CGI::Q = $class->SUPER::new(@_);
 476         $self->{'.fcgi_generation'} = $generation if $self;
 477         return $self;
 478 }
 479
 480 sub DESTROY {
 481         my $self = shift;
 482         $self->SUPER::DESTROY if $self->can('SUPER::DESTROY');
 483         _close_active(0, 0, 1)
 484                 if $active{'active'} && $self->{'.fcgi_generation'} == $generation;
 485 }
 486
 487 sub CGI::FCGI::Raw::new {
 488         my $class = _get_new_class(shift, 'CGI::FCGI::Raw');
 489         _next_request;
 490         my $self = {};
 491         bless $self, $class;
 492         $self->{'.fcgi_generation'} = $generation if $self;
 493         return $self;
 494 }
 495
 496 sub CGI::FCGI::Raw::DESTROY {
 497         my $self = shift;
 498         _close_active(0, 0, 1)
 499                 if $active{'active'} && $self->{'.fcgi_generation'} == $generation;
 500 }
 501
 502 sub CGI::FCGI::Raw::ResetCGI {
 503         $CGI::Q = undef;
 504         CGI->_reset_globals();
 505         CGI->_setup_symbols(@CGI::SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS;
 506         1;
 507 }
 508
 509 package CGI::FCGI::IStream;
 510
 511 use Carp 'croak';
 512
 513 sub TIEHANDLE {
 514         my $class = shift;
 515         my $self = {};
 516         $self->{'buffer'} = '';
 517         return bless $self, $class;
 518 }
 519
 520 sub BINMODE {
 521         return 1;
 522 }
 523
 524 sub FILENO {
 525         return undef;
 526 }
 527
 528 sub _read_more {
 529         my $self = shift;
 530         my $min = shift;
 531         if (!$self->{'eof'}) {
 532                 my $more = CGI::FCGI::_read_more($min);
 533                 $self->{'eof'} = 1 if !length($more);
 534                 $self->{'buffer'} .= $more;
 535         }
 536 }
 537
 538 sub EOF {
 539         my $self = shift;
 540         $self->_read_more
 541                 if !$self->{'eof'} && !length($self->{'buffer'});
 542         return $self->{'eof'} ? 1 : 0;
 543 }
 544
 545 sub GETC {
 546         my $self = shift;
 547         $self->_read_more
 548                 if !$self->{'eof'} && !length($self->{'buffer'});
 549         return undef unless length($self->{'buffer'});
 550         my $c = substr($self->{'buffer'}, 0, 1);
 551         substr($self->{'buffer'}, 0, 1) = '';
 552         return $c;
 553 }
 554
 555 sub READ {
 556         my ($self, undef, $length, $offset) = @_;
 557         my $bufref = \$_[1];
 558         $offset = 0 unless defined($offset);
 559         $$bufref = '' unless defined($$bufref);
 560         croak "CGI::FCGI::IStream::READ invalid length $length"
 561                 if $length < 0;
 562         $offset += length($$bufref) if $offset < 0;
 563         croak "CGI::FCGI::IStream::READ invalid read offset"
 564                 if $offset > length($$bufref);
 565         $self->_read_more(length($self->{'buffer'} - $length))
 566                 if length($self->{'buffer'}) < $length;
 567         $length = length($self->{'buffer'}) if $length > length($self->{'buffer'});
 568         substr($$bufref, $offset) = substr($self->{'buffer'}, 0, $length);
 569         substr($self->{'buffer'}, 0, $length) = '';
 570         return $length;
 571 }
 572
 573 sub _read_line {
 574         my $self = shift;
 575         if (ref($/) eq 'SCALAR') {
 576                 $self->_read_more(${$/} - length($self->{'buffer'}))
 577                         if !$self->{'eof'} && length($self->{'buffer'}) < ${$/};
 578                 my $ans = substr($self->{'buffer'}, 0, ${$/});
 579                 substr($self->{'buffer'}, 0, ${$/}) = '';
 580                 return $ans;
 581         } elsif (defined($/)) {
 582                 my $pos = -1;
 583                 my $offset = 0;
 584                 my $d = $/ eq '' ? "\n\n" : $/;
 585                 while (($pos = index($self->{'buffer'}, $d, $offset)) < 0 && !$self->{'eof'}) {
 586                         $offset += length($self->{'buffer'}) - (length($d) - 1);
 587                         $self->_read_more;
 588                 }
 589                 if ($pos >= 0) {
 590                         $pos += length($d);
 591                         my $cpos = $pos;
 592                         if ($/ eq '') {{
 593                                 $self->_read_more
 594                                         if !$self->{'eeof'} && length($self->{'buffer'}) <= $pos;
 595                                 ++$pos, redo
 596                                         if substr($self->{'buffer'}, $pos, 1) eq "\n";
 597                         }}
 598                         my $ans = substr($self->{'buffer'}, 0, $cpos);
 599                         substr($self->{'buffer'}, 0, $pos) = '';
 600                         return $ans;
 601                 }
 602         } else {
 603                 $self->_read_more(32768) while !$self->{'eof'};
 604         }
 605         return undef unless length($self->{'buffer'});
 606         my $ans = $self->{'buffer'};
 607         $self->{'buffer'} = '';
 608         return $ans;
 609 }
 610
 611 sub READLINE {
 612         my $self = shift;
 613         if (wantarray) {
 614                 my @a = ();
 615                 my $l;
 616                 push(@a, $l) while defined($l = $self->_read_line);
 617                 return @a;
 618         } else {
 619                 return $self->_read_line;
 620         }
 621 }
 622
 623 sub CLOSE {
 624         return 1;
 625 }
 626
 627 sub DESTROY {
 628 }
 629
 630 package CGI::FCGI::OStream;
 631
 632 use Carp 'croak';
 633
 634 sub TIEHANDLE {
 635         my $class = shift;
 636         my $type = shift;
 637         my $self = {};
 638         $self->{'type'} = $type;
 639         return bless $self, $class;
 640 }
 641
 642 sub BINMODE {
 643         return 1;
 644 }
 645
 646 sub FILENO {
 647         return undef;
 648 }
 649
 650 sub EOF {
 651         return 0;
 652 }
 653
 654 sub CLOSE {
 655         return 1;
 656 }
 657
 658 sub DESTROY {
 659 }
 660
 661 sub PRINTF {
 662         my $self = shift;
 663         my $template = shift;
 664         return $self->PRINT(sprintf $template, @_);
 665 }
 666
 667 sub PRINT {goto &FCGI::Stream::PRINT}
 668
 669 sub FCGI::Stream::PRINT {
 670         my $self = shift;
 671         CGI::FCGI::_write_more($self->{'type'}, join('', @_));
 672         return 1;
 673 }
 674
 675 sub WRITE {
 676         my $self = shift;
 677         my ($scalar, $length, $offset) = @_;
 678         $scalar = '' if !defined($scalar);
 679         $length = length($scalar) if !defined($length);
 680         croak "CGI::FCGI::OStream::WRITE invalid length $length"
 681                 if $length < 0;
 682         $offset = 0 if !defined($offset);
 683         $offset += length($scalar) if $offset < 0;
 684         croak "CGI::FCGI::OStream::WRITE invalid write offset"
 685                 if $offset < 0 || $offset > $length;
 686         my $max = length($scalar) - $offset;
 687         $length = $max if $length > $max;
 688         $self->PRINT(substr($scalar, $offset, $length));
 689         return $length;
 690 }
 691
 692 package FCGI;
 693
 694 use Carp 'croak';
 695
 696 sub new {croak 'FCGI->new is not permitted when `use CGI::FCGI;` is in effect'}
 697
 698 package CGI::Fast;
 699
 700 our @ISA = ('CGI::FCGI');
 701
 702 sub new {goto &CGI::FCGI::new}
 703
 704 1;
 705
 706 =head1 NAME
 707
 708 CGI::FCGI - Alternative CGI::Fast and FCGI Interface
 709
 710 =head1 SYNOPSIS
 711
 712     use CGI::FCGI;
 713     use CGI qw/ :standard /;
 714
 715     my $maxrequests = 1;
 716     my $CGI = 'CGI';
 717     if (CGI::FCGI::IsFCGI) {
 718         $CGI = 'CGI::Fast';
 719         $maxrequests = 100;
 720     }
 721
 722     while (my $q = $CGI->new) {
 723         ProcessRequest($q);
 724         last unless --$maxrequests;
 725     }
 726
 727     sub ProcessRequest {
 728         my $r = shift;
 729
 730         # Perform standard CGI processing for one request
 731     }
 732
 733     1;
 734
 735 =head1 DESCRIPTION
 736
 737 CGI::FCGI is intended as a bare bones Pure Perl replacement for
 738 both CGI::Fast and FCGI.  It's lightweight and supports the most
 739 common use case of wanting to support FastCGI but missing one
 740 or both of the CGI::Fast and FCGI modules.
 741
 742 It only supports 'RESPONDER' and 'AUTHORIZER' roles (the
 743 'RESPONDER' role corresponding to standard CGI applications) and it
 744 only handles one request at a time on one socket at a time.  For
 745 compatibility with FCGI.pm, the FCGI_ROLE environment variable is always
 746 set to either "RESPONDER" or "AUTHORIZER".
 747
 748 Nevertheless, this is quite sufficient to reap a huge performance
 749 gain as Perl need not be restarted once for every CGI request.
 750
 751 Note that just like FCGI, input/output is always byte oriented so
 752 the caller is responsible for decoding/encoding as needed.  To
 753 facilitate compatibility with the standard FCGI, the tied output
 754 streams call a FCGI::Stream::PRINT function which contains the
 755 actual PRINT implementation and may be head-patched in exactly
 756 the same manner as the standard FCGI::Stream::PRINT implemention
 757 to provide UTF-8 encoding on output.
 758
 759 Other than CGI::Fast::new and FCGI::Stream::PRINT, B<none> of the
 760 other standard CGI::Fast or FCGI functions are provided!
 761
 762 Remember, if using CGI::FCGI::Raw to allow custom handling of any
 763 'POST' data, the data B<MUST> be read from <STDIN> and B<NOT>
 764 the <ARGV> file handle which is also known as <>.
 765
 766 =head1 FUNCTIONS
 767
 768 =over 4
 769
 770 =item CGI::FCGI::IsFCGI
 771
 772 Returns true if STDIN_FILENO appears to be a FastCGI socket.
 773
 774 As there's not a direct equivalent in CGI::Fast or FCGI, don't
 775 call this if code is to be interchangeable between CGI::FCGI and
 776 CGI::Fast.
 777
 778 =item CGI::FCGI::new
 779
 780 Returns a new CGI instance for the next request.  Returns undef
 781 if the listen socket has been closed.  All arguments are passed
 782 on up to CGI::new.
 783
 784 =item CGI::Fast::new
 785
 786 Convenient alias for CGI::FCGI::new, all arguments are passed
 787 on up to CGI::new.
 788
 789 =item CGI::FCGI::Raw::new
 790
 791 Returns a new instance for the next request that is B<NOT> a CGI instance.
 792 This is similar to FCGI::Request()->Accept() but can be used in a loop just the
 793 same way CGI::FCGI::new (or the equivalent CGI::Fast::new) can.  While the
 794 returned instance is alive, STDIN, STDOUT, STDERR and %ENV are directed to the
 795 request being serviced (in just the same way as for CGI::FCGI::new), but
 796 B<none> of the CGI processing happens (e.g. slurping up 'POST' data, parsing
 797 QUERY_STRING, etc.) as the instance is B<NOT> a CGI instance and for the same
 798 reason B<NONE> of the standard CGI methods are available on the instance.
 799 No arguments are passed up to CGI since the new instance is B<NOT> a CGI.
 800 Returns undef if the listen socket has been closed.  However, it is possible
 801 to explicitly create a new CGI instance (CGI->new) after calling this function
 802 provided the CGI global state has first been reset to its normal "empty" state.
 803 See the CGI::FCGI::Raw::ResetCGI function for help with this.
 804
 805 =item CGI::FCGI::Raw::ResetCGI
 806
 807 Resets the global CGI state so that a call to CGI->new will create a new
 808 CGI instance from the current environment in %ENV without being influenced by a
 809 previously handled request.
 810
 811 Do B<NOT> call this unless the "Raw" interface is being used!  The regular
 812 interface (CGI::FCGI::new or CGI::Fast::new) takes care of this automatically.
 813
 814 When using the "Raw" interface (i.e. CGI::FCGI::Raw::new) B<AND> then calling
 815 CGI->new directly, this function should be called B<AFTER> CGI::FCGI::Raw::new
 816 but B<BEFORE> CGI->new to make sure that CGI->new doesn't return an instance
 817 with leftover configuration and/or data from a previously handled request.
 818
 819 =item FCGI::Stream::PRINT
 820
 821 All stream output passes through this function which may be head-patched
 822 to perform custom processing such as UTF-8 encoding.  This is the same
 823 name used by the standard FCGI module for compatibility.
 824
 825 =back
 826
 827 =head1 LIMITATIONS
 828
 829 Although the implementation is Pure Perl, it I<does> make heavy use of
 830 the socket functions so may not function properly on platforms where the
 831 socket functions are not available or only partially supported.
 832
 833 This module must be use'd B<before> CGI::Fast and FCGI otherwise it
 834 will die with a fatal error.
 835
 836 While a request is active, STDIN, STDOUT, STDERR and %ENV are temporarily
 837 altered and there's no option to do otherwise.
 838
 839 When a new request is started, the current values of the STDIN, STDOUT,
 840 STDERR, %ENV and $/ variables are preserved before tying STDIN, STDOUT,
 841 STDERR and adding received variables to %ENV.
 842
 843 When the request ends (i.e. it's DESTROY'd) those variables are restored
 844 to the values they had just prior to the start of the request therefore
 845 changes to any of those variables during the processing of a request are,
 846 deliberately, nonpersistent.
 847
 848 =head1 LICENSE
 849
 850 =over
 851
 852 =item CGI::FCGI Copyright (C) 2015,2016,2017,2020,2021 Kyle J. McKay.
 853
 854 =item All rights reserved.
 855
 856 =back
 857
 858 This library is free software; you can redistribute it and/or modify
 859 it under the same terms as Perl itself or under the terms of the
 860 GNU General Public License version 2 (or, at your option, any later
 861 version).
 862
 863 This program is distributed in the hope that it will be useful,
 864 but WITHOUT ANY WARRANTY; without even the implied warranty of
 865 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 866
 867 Address feedback to mackyle <at> gmail.com.
 868
 869 =head1 BUGS
 870
 871 Hopefully squashed.
 872
 873 =head1 SEE ALSO
 874
 875 CGI, CGI::Fast, FCGI
 876
 877 =cut