From 97e215f80f487922c44923116a5ad57c7bf149ce Mon Sep 17 00:00:00 2001
From: Brian Fraser <brian.fraser@booking.com>
Date: Fri, 19 Feb 2021 11:17:14 +0100
Subject: [PATCH] Plack::Util::load_psgi: guard against hitting the identifier
 length limit

When Plack is asked to load a path with a psgi app inside,
ala /foo/bar/app.psgi, it first generates a namespace for
the file -- something like Plack::Sandbox::_2ffoo_2fbar_2fapp_2epsgi.

Those "sandboxed" namespaces can get very long.  Long enough
that they hit Perl's identifier limit of ~250 characters
(see https://perldoc.perl.org/perldiag#Identifier-too-long).

This commit patches Plack::Util::load_psgi()
that always generates paths shorter than the threshold,
and jumps through some hoops to ensure that no two
applications end up sharing namespaces after the trimming.
---
 lib/Plack/Util.pm   | 33 +++++++++++++++++++++++++++++++--
 t/Plack-Util/load.t |  8 ++++++++
 2 files changed, 39 insertions(+), 2 deletions(-)

diff --git a/lib/Plack/Util.pm b/lib/Plack/Util.pm
index 37a243d3b..29966b309 100644
--- a/lib/Plack/Util.pm
+++ b/lib/Plack/Util.pm
@@ -108,11 +108,40 @@ sub class_to_file {
     $class . ".pm";
 }
 
+{
+    my $counter = 0;
+    my $file_to_generated_package = {};
+    sub _generate_sandbox_package {
+        my $abs_path = shift;
+        return $file_to_generated_package->{$abs_path}
+            if $file_to_generated_package->{$abs_path};
+
+        my $_package = $abs_path;
+        $_package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;
+
+        # Make sure our generated package won't pass Perl's identifier
+        # limit:
+        substr($_package, 0, 30, '') while length($_package) > 200;
+
+        # And to make up for the possibly less-unique path, add a unique
+        # prefix per file, so that two files with different early
+        # paths but similar later paths
+        # (think /foo/bar/baz/app.psgi vs /something/bar/baz/app.psgi)
+        # do not share namespaces:
+        $counter++;
+        my $prefix = "Guard$counter";
+        my $generated_package = $prefix . '::' . $_package;
+
+        # and in the rare case that this function gets called
+        # twice for the same file, make sure we return the same
+        # generated namespace for both invocations:
+        return $file_to_generated_package->{$abs_path} = $generated_package;
+    }
+}
 sub _load_sandbox {
     my $_file = shift;
 
-    my $_package = $_file;
-    $_package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;
+    my $_package = _generate_sandbox_package($_file);
 
     local $0 = $_file; # so FindBin etc. works
     local @ARGV = ();  # Some frameworks might try to parse @ARGV
diff --git a/t/Plack-Util/load.t b/t/Plack-Util/load.t
index 0b69d8bf8..ee71974c8 100644
--- a/t/Plack-Util/load.t
+++ b/t/Plack-Util/load.t
@@ -67,4 +67,12 @@ use Test::More;
     chdir $cwd;
 }
 
+{
+    local $@;
+    # must be at least 250 characters long
+    my $very_long_path = join '/', map 1..300, 'very_long.psgi';
+    eval { Plack::Util::load_psgi($very_long_path) };
+    unlike($@, qr/Identifier too long/);
+}
+
 done_testing;