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