From 1a7d27971edf8fb85c19eb6ec9bc06b725aa83ad Mon Sep 17 00:00:00 2001
From: Alexander Kuehne <sparrow2009@gmx.net>
Date: Wed, 16 Apr 2025 14:40:30 +0200
Subject: [PATCH] fix path merge with path object

Mojo::Path's support of merging objects of class Mojo::Path (vs. strings)
until now is implemented by object stringification followed by a reparsing
using a default Mojo::Path object.

This approach works fine for merged objects with a character set of UTF-8 as
this is also the default character set for Mojo::Path objects. It can fail
however for other character sets.

Instead copy the path parts and the slash attributes from the source to
the target object.

The missing tests for merging objects are included using the ISO-8859-15
character set. That way those tests can also function as regression tests.
The ISO-8859-15 character set deviates from ISO-8859-1 and in turn from
Unicode in that it reassigns code points of less common symbols (code
point A4 which is the currency sign in ISO-8859-1/Unicode is replaced
by the Euro currency sign e.g.).

Background:
Mojo::URL::to_abs() e.g. passes path objects to Mojo::Path::merge()
in order to merge the path onto the base path today. And can fail in the
way outlined above if the path object is not configured to be UTF-8.
---
 lib/Mojo/Path.pm | 13 ++++++++++---
 t/mojo/path.t    | 26 ++++++++++++++++++++++++++
 2 files changed, 36 insertions(+), 3 deletions(-)

diff --git a/lib/Mojo/Path.pm b/lib/Mojo/Path.pm
index 2f5310f6f6..486a4a0a28 100644
--- a/lib/Mojo/Path.pm
+++ b/lib/Mojo/Path.pm
@@ -41,11 +41,18 @@ sub merge {
   my ($self, $path) = @_;
 
   # Replace
-  return $self->parse($path) if $path =~ m!^/!;
+  if (ref $path) {
+     if ($path->leading_slash) {
+       @{$self->parts} = @{$path->parts};
+       $self->trailing_slash($path->trailing_slash);
+       return $self->leading_slash($path->leading_slash);
+     }
+  }
+  elsif ($path =~ m!^/!) { return $self->parse($path) }
 
   # Merge
-  pop @{$self->parts} unless $self->trailing_slash;
-  $path = $self->new($path);
+  pop @{$self->parts}       unless $self->trailing_slash;
+  $path = $self->new($path) unless ref $path;
   push @{$self->parts}, @{$path->parts};
   return $self->trailing_slash($path->trailing_slash);
 }
diff --git a/t/mojo/path.t b/t/mojo/path.t
index 642a07bb88..631f8a43d0 100644
--- a/t/mojo/path.t
+++ b/t/mojo/path.t
@@ -2,6 +2,7 @@ use Mojo::Base -strict;
 
 use Test::More;
 use Mojo::Path;
+use Mojo::Util qw(encode url_escape);
 
 subtest 'Basic functionality' => sub {
   my $path = Mojo::Path->new;
@@ -170,6 +171,31 @@ subtest 'Merge' => sub {
   is $path->to_route, '/foo/baz/yada', 'right route';
 };
 
+subtest 'Merge path object' => sub {
+  my $charset    = 'ISO-8859-15';
+  my $part       = 'b€r';
+  my $part_enc   = url_escape(encode($charset, $part));
+  my $parse_path = sub { Mojo::Path->new->charset($charset)->parse(@_) };
+
+  for my $has_trailing_slash (!!0, !!1) {
+    my $trailing_slash      = $has_trailing_slash ? '/' : '';
+    my $trailing_slash_diag = 'has'.($has_trailing_slash ? '' : ' no').' trailing slash';
+    my $path = $parse_path->("/$part_enc/");
+    $path->merge($parse_path->($part_enc.$trailing_slash));
+    is_deeply $path->parts, [($part) x 2],              'right structure';
+    is "$path", "/$part_enc/$part_enc".$trailing_slash, 'right path';
+    ok $path->leading_slash,                            'has leading slash';
+    is $path->trailing_slash, $has_trailing_slash,      $trailing_slash_diag;
+    is $path->to_route, "/$part/$part".$trailing_slash, 'right route';
+    $path = $parse_path->("/foo/")->merge($parse_path->("/$part_enc".$trailing_slash));
+    is_deeply $path->parts, [$part],                    'right structure';
+    is "$path", "/$part_enc".$trailing_slash,           'right path';
+    ok $path->leading_slash,                            'has leading slash';
+    is $path->trailing_slash, $has_trailing_slash,      $trailing_slash_diag;
+    is $path->to_route, "/$part".$trailing_slash,       'right route';
+  }
+};
+
 subtest 'Empty path elements' => sub {
   my $path = Mojo::Path->new('//');
   is "$path", '//', 'right path';