• Bug#1092774: libfcgi: CVE-2025-23016 (4/5)

    From Bastian Germann@21:1/5 to All on Mon Apr 14 20:50:01 2025
    [continued from previous message]

    - read($self->{socket}, $header, 8);
    - my ($version, $type, $id, $clen, $plen) = unpack("CCnnC", $header);
    - read($self->{socket}, $body, $clen+$plen);
    - $body = undef if $clen == 0;
    - ($type, $id, $body);
    -}
    -
    -sub read {
    - my ($self, $rtype, $len) = @_;
    - while (length $self->{buf} < $len) {
    - my ($type, $id, $buf) = $self->read_record();
    - return undef unless defined $buf;
    - if ($type != $rtype) {
    - $self->{error} = "unexpected stream type";
    - return 0;
    - }
    - $self->{buf} .= $buf;
    - }
    - my ($newbuf, $result) = (substr($self->{buf}, $len),
    - substr($self->{buf}, 0, $len));
    - $self->{buf} = $newbuf;
    - $result;
    -}
    -
    -sub Flush {
    - my ($req) = @_;
    -}
    -
    -sub write {
    - my ($self, $type, $content, $len) = @_;
    - return unless $len > 0;
    - $self->write_record($type, $content, $len);
    -}
    -
    -sub write_record {
    - my ($self, $type, $content, $length) = @_;
    - my $offset = 0;
    - while ($length > 0) {
    - my $len = $length > 32*1024 ? 32*1024 : $length;
    - my $padlen = (8 - ($len % 8)) % 8;
    - my $templ = "CCnnCxa${len}x$padlen";
    - my $data = pack($templ,
    - VERSION_1, $type, $self->{id}, $len, $padlen,
    - substr($content, $offset, $len));
    - syswrite $self->{socket}, $data;
    - $length -= $len;
    - $offset += $len;
    - }
    -}
    -
    -{ package FCGI::Stream;
    -
    -sub new {
    - my ($class, $src, $type) = @_;
    - my $handle = do { \local *FH };
    - tie($$handle, $class, $src, $type);
    - $handle;
    -}
    -
    -sub TIEHANDLE {
    - my ($class, $src, $type) = @_;
    - bless { src => $src, type => $type }, $class;
    -}
    -
    -sub READ {
    - my ($stream, undef, $len, $offset) = @_;
    - my ($ref) = \$_[1];
    - my $buf = $stream->{src}->read($stream->{type}, $len);
    - return undef unless defined $buf;
    - substr($$ref, $offset, 0, $buf);
    - length $buf;
    -}
    -
    -sub PRINT {
    - my ($stream) = shift;
    - for (@_) {
    - $stream->{src}->write($stream->{type}, $_, length($_));
    - }
    -}
    -
    -sub CLOSE {
    - my ($stream) = @_;
    - $stream->{src}->write_record($stream->{type}, undef, 0);
    -}
    -
    -}
    -
    -EOP
    -print OUT while <DATA>;
    -close OUT;
    -__END__
    -
    -# Preloaded methods go here.
    -
    -# Autoload methods go after __END__, and are processed by the autosplit program.
    -
    -*FAIL_ACCEPT_ON_INTR = sub() { 1 };
    -
    -sub Request(;***$*$) {
    - my @defaults = (\*STDIN, \*STDOUT, \*STDERR, \%ENV, 0, 0);
    - $_[4] = fileno($_[4]) if defined($_[4]) && defined(fileno($_[4]));
    - splice @defaults,0,@_,@_;
    - RequestX(@defaults);
    -}
    -
    -sub accept() {
    - warn "accept called as a method; you probably wanted to call Accept" if @_;
    - if (defined %FCGI::ENV) {
    - %ENV = %FCGI::ENV;
    - } else {
    - %FCGI::ENV = %ENV;
    - }
    - my $rc = Accept($global_request);
    - for (keys %FCGI::ENV) {
    - $ENV{$_} = $FCGI::ENV{$_} unless exists $ENV{$_};
    - }
    -
    - # not SFIO
    - $SIG{__WARN__} = $warn_handler if (tied (*STDIN));
    - $SIG{__DIE__} = $die_handler if (tied (*STDIN));
    -
    - return $rc;
    -}
    -
    -sub finish() {
    - warn "finish called as a method; you probably wanted to call Finish" if @_;
    - %ENV = %FCGI::ENV if (defined %FCGI::ENV);
    -
    - # not SFIO
    - if (tied (*STDIN)) {
    - delete $SIG{__WARN__} if ($SIG{__WARN__} == $warn_handler);
    - delete $SIG{__DIE__} if ($SIG{__DIE__} == $die_handler);
    - }
    -
    - Finish ($global_request);
    -}
    -
    -sub flush() {
    - warn "flush called as a method; you probably wanted to call Flush" if @_; - Flush($global_request);
    -}
    -
    -sub detach() {
    - warn "detach called as a method; you probably wanted to call Detach" if @_;
    - Detach($global_request);
    -}
    -
    -sub attach() {
    - warn "attach called as a method; you probably wanted to call Attach" if @_;
    - Attach($global_request);
    -}
    -
    -# deprecated
    -sub set_exit_status {
    -}
    -
    -sub start_filter_data() {
    - StartFilterData($global_request);
    -}
    -
    -$global_request = Request();
    -$warn_handler = sub { print STDERR @_ };
    -$die_handler = sub { print STDERR @_ unless $^S };
    -
    -package FCGI::Stream;
    -
    -sub PRINTF {
    - shift->PRINT(sprintf(shift, @_));
    -}
    -
    -sub BINMODE {
    -}
    -
    -sub READLINE {
    - my $stream = shift;
    - my ($s, $c);
    - my $rs = $/ eq '' ? "\n\n" : $/;
    - my $l = substr $rs, -1;
    - my $len = length $rs;
    -
    - $c = $stream->GETC();
    - if ($/ eq '') {
    - while ($c eq "\n") {
    - $c = $stream->GETC();
    - }
    - }
    - while (defined $c) {
    - $s .= $c;
    - last if $c eq $l and substr($s, -$len) eq $rs;
    - $c = $stream->GETC();
    - }
    - $s;
    -}
    -
    -sub OPEN {
    - $_[0]->CLOSE;
    - if (@_ == 2) {
    - return open($_[0], $_[1]);
    - } else {
    - my $rc;
    - eval("$rc = open($_[0], $_[1], $_[2])");
    - die $@ if $@;
    - return $rc;
    - }
    -}
    -
    -# Apparently some use fileno to determine if a filehandle is open,
    -# so we might want to return a defined, but meaningless value.
    -# An alternative would be to return the fcgi stream fd.
    -# sub FILENO { -2 }
    -
    -1;
    -
    -=pod
    -
    -=head1 NAME
    -
    -FCGI - Fast CGI module
    -
    -=head1 SYNOPSIS
    -
    - use FCGI;
    -
    - my $count = 0;
    - my $request = FCGI::Request();
    -
    - while($request->Accept() >= 0) {
    - print("Content-type: text/html\r\n\r\n", ++$count);
    - }
    -
    -=head1 DESCRIPTION
    -
    -Functions:
    -
    -=over 4
    -
    -=item FCGI::Request
    -
    -Creates a request handle. It has the following optional parameters:
    -
    -=over 8
    -
    -=item input perl file handle (default: \*STDIN)
    -
    -=item output perl file handle (default: \*STDOUT)
    -
    -=item error perl file handle (default: \*STDERR)
    -
    -These filehandles will be setup to act as input/output/error
    -on successful Accept.
    -
    -=item environment hash reference (default: \%ENV)
    -
    -The hash will be populated with the environment.
    -
    -=item socket (default: 0)
    -
    -Socket to communicate with the server.
    -Can be the result of the OpenSocket function.
    -For the moment, it's the file descriptor of the socket
    -that should be passed. This may change in the future.
    -
    -You should only use your own socket if your program
    -is not started by a process manager such as mod_fastcgi
    -(except for the FastCgiExternalServer case) or cgi-fcgi.
    -If you use the option, you have to let your FastCGI
    -server know which port (and possibly server) your program
    -is listening on.
    -See remote.pl for an example.
    -
    -=item flags (default: 0)
    -
    -Possible values:
    -
    -=over 12
    -
    -=item FCGI::FAIL_ACCEPT_ON_INTR
    -
    -If set, Accept will fail if interrupted.
    -It not set, it will just keep on waiting.
    -
    -=back
    -
    -=back
    -
    -Example usage:
    - my $req = FCGI::Request;
    -
    -or:
    - my %env;
    - my $in = new IO::Handle;
    - my $out = new IO::Handle;
    - my $err = new IO::Handle;
    - my $req = FCGI::Request($in, $out, $err, \%env);
    -
    -=item FCGI::OpenSocket(path, backlog)
    -
    -Creates a socket suitable to use as an argument to Request.
    -
    -=over 8
    -
    -=item path
    -
    -Pathname of socket or colon followed by local tcp port.
    -Note that some systems take file permissions into account
    -on Unix domain sockets, so you'll have to make sure that
    -the server can write to the created file, by changing
    -the umask before the call and/or changing permissions and/or
    -group of the file afterwards.
    -
    -=item backlog
    -
    -Maximum length of the queue of pending connections.
    -If a connection
    -request arrives with the queue full the client may receive
    -an error with an indication of ECONNREFUSED.
    -
    -=back
    -
    -=item FCGI::CloseSocket(socket)
    -
    -Close a socket opened with OpenSocket.
    -
    -=item $req->Accept()
    -
    -Accepts a connection on $req, attaching the filehandles and
    -populating the environment hash.
    -Returns 0 on success.
    -If a connection has been accepted before, the old
    -one will be finished first.
    -
    -Note that unlike with the old interface, no die and warn
    -handlers are installed by default. This means that if
    -you are not running an sfio enabled perl, any warn or
    -die message will not end up in the server's log by default.
    -It is advised you set up die and warn handlers yourself.
    -FCGI.pm contains an example of die and warn handlers.
    -
    -=item $req->Finish()
    -
    -Finishes accepted connection.
    -Also detaches filehandles.
    -
    -=item $req->Flush()
    -
    -Flushes accepted connection.
    -
    -=item $req->Detach()
    -
    -Temporarily detaches filehandles on an accepted connection.
    -
    -=item $req->Attach()
    -
    -Re-attaches filehandles on an accepted connection.
    -
    -=item $req->LastCall()
    -
    -Tells the library not to accept any more requests on this handle.
    -It should be safe to call this method from signal handlers.
    -
    -Note that this method is still experimental and everything
    -about it, including its name, is subject to change.
    -
    -=item $env = $req->GetEnvironment()
    -
    -Returns the environment parameter passed to FCGI::Request.
    -
    -=item ($in, $out, $err) = $req->GetHandles()
    -
    -Returns the file handle parameters passed to FCGI::Request.
    -
    -=item $isfcgi = $req->IsFastCGI()
    -
    -Returns whether or not the program was run as a FastCGI.
    -
    -=back
    -
    -=head1 AUTHOR
    -
    -Sven Verdoolaege <skimo@kotnet.org>
    -
    -=cut
    -
    -__END__
    diff -Nru libfcgi-2.4.2/perl/FCGI.pm libfcgi-2.4.5/perl/FCGI.pm
    --- libfcgi-2.4.2/perl/FCGI.pm 1970-01-01 01:00:00.000000000 +0100
    +++ libfcgi-2.4.5/perl/FCGI.pm 2025-04-14 19:35:59.000000000 +0200
    @@ -0,0 +1,265 @@
    +package FCGI;
    +use strict;
    +
    +BEGIN {
    + our $VERSION = '0.82';
    +
    + require XSLoader;
    + XSLoader::load(__PACKAGE__, $VERSION);
    +}
    +
    +sub FAIL_ACCEPT_ON_INTR () { 1 };
    +
    +sub Request(;***$*$) {
    + my @defaults = (\*STDIN, \*STDOUT, \*STDERR, \%ENV, 0, FAIL_ACCEPT_ON_INTR);
    + $_[4] = fileno($_[4]) if defined($_[4]) && defined(fileno($_[4]));
    + splice @defaults,0,@_,@_;
    + &RequestX(@defaults);
    +}
    +
    +package FCGI::Stream;
    +use strict;
    +
    +sub PRINTF {
    + shift->PRINT(sprintf(shift, @_));
    +}
    +
    +sub BINMODE {
    +}
    +
    +sub READLINE {
    + my $stream = shift;
    + my ($s, $c);
    + my $rs = $/ eq '' ? "\n\n" : $/;
    + my $l = substr $rs, -1;
    + my $len = length $rs;
    +
    + $c = $stream->GETC();
    + if ($/ eq '') {
    + while ($c eq "\n") {
    + $c = $stream->GETC();
    + }
    + }
    + whi