[PATCH] Perl: request object validation

[Maxim Dounin]

# HG changeset patch
# User Maxim Dounin <mdounin at mdounin.ru>
# Date 1782985214 -10800
#      Thu Jul 02 12:40:14 2026 +0300
# Node ID 9a7e15e971f8759e177123da2d3217f1a5f621d5
# Parent  3072e5ce18a55cae5d1389d1b396cc62c2e053ab
Perl: request object validation.

Previously, using stale request objects resulted in accesses to already
freed memory, causing segmentation faults:

    location /stale {
        perl 'sub {
            my $r = shift;
            $prev->log_error(0, "next request arrived") if $prev;
            $prev = $r;
            $r->send_http_header;
            return OK;
        }';
    }

Similarly, incorrectly blessed objects might cause segmentation faults,
such as in the following configuration:

    location /bless {
        perl 'sub {
            my $v = 10;
            my $r = bless \$v, "nginx";
            $r->send_http_header;
            return OK;
        }';
    }

With this change, active request object is recorded in the
ngx_http_perl_call_handler() function, and checked by
ngx_http_perl_set_request() to prevent use of unexpected request
objects.

Reported by Axel Mierczuk, Keith Hoodlet, 1Password’s Off-by-1 Labs.

diff --git a/src/http/modules/perl/nginx.xs b/src/http/modules/perl/nginx.xs
--- a/src/http/modules/perl/nginx.xs
+++ b/src/http/modules/perl/nginx.xs
@@ -18,6 +18,9 @@
 #define ngx_http_perl_set_request(r, ctx)                                     \
                                                                               \
     ctx = INT2PTR(ngx_http_perl_ctx_t *, SvIV((SV *) SvRV(ST(0))));           \
+    if (ctx != ngx_http_perl_active_context || ctx == NULL) {                 \
+        croak("invalid request object");                                      \
+    }                                                                         \
     r = ctx->request
 
 
diff --git a/src/http/modules/perl/ngx_http_perl_module.c b/src/http/modules/perl/ngx_http_perl_module.c
--- a/src/http/modules/perl/ngx_http_perl_module.c
+++ b/src/http/modules/perl/ngx_http_perl_module.c
@@ -148,6 +148,9 @@ static ngx_http_ssi_command_t  ngx_http_
 #endif
 
 
+ngx_http_perl_ctx_t     *ngx_http_perl_active_context;
+
+
 static ngx_str_t         ngx_null_name = ngx_null_string;
 static HV               *nginx_stash;
 
@@ -746,6 +749,8 @@ ngx_http_perl_call_handler(pTHX_ ngx_htt
 
     PUSHMARK(sp);
 
+    ngx_http_perl_active_context = ctx;
+
     sv = sv_2mortal(sv_bless(newRV_noinc(newSViv(PTR2IV(ctx))), nginx));
     XPUSHs(sv);
 
@@ -790,6 +795,8 @@ ngx_http_perl_call_handler(pTHX_ ngx_htt
     FREETMPS;
     LEAVE;
 
+    ngx_http_perl_active_context = NULL;
+
     if (ctx->error) {
 
         ngx_log_debug1(NGX_LOG_DEBUG_HTTP, c->log, 0,
diff --git a/src/http/modules/perl/ngx_http_perl_module.h b/src/http/modules/perl/ngx_http_perl_module.h
--- a/src/http/modules/perl/ngx_http_perl_module.h
+++ b/src/http/modules/perl/ngx_http_perl_module.h
@@ -59,6 +59,9 @@ typedef struct {
 extern ngx_module_t  ngx_http_perl_module;
 
 
+extern ngx_http_perl_ctx_t  *ngx_http_perl_active_context;
+
+
 /*
  * workaround for "unused variable `Perl___notused'" warning
  * when building with perl 5.6.1