mktables: Refactor \X test so can be used for others

[perl5.git] / lib / utf8.t

diff --git a/lib/utf8.t b/lib/utf8.t
index b13bb53..5c03b31 100644 (file)
--- a/lib/utf8.t
+++ b/lib/utf8.t
@@ -435,7 +435,68 @@ SKIP: {
     utf8::decode($k1);
     utf8::decode($k2);
     my $h = { $k1 => 1, $k2 => 2 };
-    is join('', keys $h), $k2, 'utf8::decode respects copy-on-write';
+    is join('', keys %$h), $k2, 'utf8::decode respects copy-on-write';
+}
+
+{
+    # Make sure utf8::decode does not modify read-only scalars
+    # [perl #91850].
+    
+    my $name = "\x{c3}\x{b3}";
+    Internals::SvREADONLY($name, 1);
+    eval { utf8::decode($name) };
+    like $@, qr/^Modification of a read-only/,
+       'utf8::decode respects readonliness';
+}
+
+{
+    # utf8::decode should stringify refs [perl #91852].
+
+    package eieifg { use overload '""'      => sub { "\x{c3}\x{b3}" },
+                                   fallback => 1 }
+
+    my $name = bless[], eieifg::;
+    utf8::decode($name);
+    is $name, "\xf3", 'utf8::decode flattens references';
+}
+
+{
+    # What do the utf8::* functions do when given a reference? A test
+    # for a behavior change that made this start dying as of
+    # v5.15.6-407-gc710240 due to a fix for [perl #91852]:
+    #
+    #    ./miniperl -Ilib -wle 'use strict; print $]; my $s = shift; my $s_ref = \$s; utf8::decode($s_ref); print $$s_ref' hlagh
+    my %expected = (
+        'utf8::is_utf8'           => { returns => "hlagh" },
+        'utf8::valid'             => { returns => "hlagh" },
+        'utf8::encode'            => { error => qr/Can't use string .*? as a SCALAR ref/},
+        'utf8::decode'            => { error => qr/Can't use string .*? as a SCALAR ref/},
+        'utf8::upgrade'           => { error => qr/Can't use string .*? as a SCALAR ref/ },
+        'utf8::downgrade'         => { returns => "hlagh" },
+        'utf8::native_to_unicode' => { returns => "hlagh" },
+        'utf8::unicode_to_native' => { returns => "hlagh" },
+    );
+    for my $func (sort keys %expected) { # sort just so it's deterministic wrt diffing *.t output
+        my $code = sprintf q[
+            use strict;
+            my $s = "hlagh";
+            my $r = \$s;
+            %s($r);
+            $$r;
+        ], $func;
+        my $ret = eval $code or my $error = $@;
+        if (my $error_rx = $expected{$func}->{error}) {
+            if (defined $error) {
+                like $error, $error_rx, "The $func function should die with an error matching $error_rx";
+            } else {
+                fail("We were expecting an error when calling the $func function but got a value of '$ret' instead");
+            }
+        } elsif (my $returns = $expected{$func}->{returns}) {
+            is($ret, $returns, "The $func function lives and returns '$returns' as expected");
+        } else {
+            die "PANIC: Internal Error"
+        }
+    }
 }
 
 {
@@ -501,9 +562,6 @@ SKIP: {
 
 for my $pos (0..5) {
 
-    my $pos1 = ($pos >= 3)  ? 2 : ($pos >= 1) ? 1 : 0;
-    my $pos2 = ($pos1 == 2) ? 3 : $pos1;
-
     my $p;
     my $s = "A\xc8\x81\xe8\xab\x86\x{100}";
     chop($s);
@@ -518,11 +576,11 @@ for my $pos (0..5) {
     is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after     utf8::downgrade");
     utf8::decode($s);
     is(length($s), 3,             "(pos $pos) len after  D; utf8::decode");
-    is(pos($s),    $pos1,         "(pos $pos) pos after  D; utf8::decode");
+    is(pos($s),    undef,         "(pos $pos) pos after  D; utf8::decode");
     is($s, "A\x{201}\x{8ac6}",    "(pos $pos) str after  D; utf8::decode");
     utf8::encode($s);
     is(length($s), 6,             "(pos $pos) len after  D; utf8::encode");
-    is(pos($s),    $pos2,         "(pos $pos) pos after  D; utf8::encode");
+    is(pos($s),    undef,         "(pos $pos) pos after  D; utf8::encode");
     is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after  D; utf8::encode");
 
     $s = "A\xc8\x81\xe8\xab\x86";
@@ -536,12 +594,28 @@ for my $pos (0..5) {
     is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after     utf8::upgrade");
     utf8::decode($s);
     is(length($s), 3,             "(pos $pos) len after  U; utf8::decode");
-    is(pos($s),    $pos1,         "(pos $pos) pos after  U; utf8::decode");
+    is(pos($s),    undef,         "(pos $pos) pos after  U; utf8::decode");
     is($s, "A\x{201}\x{8ac6}",    "(pos $pos) str after  U; utf8::decode");
     utf8::encode($s);
     is(length($s), 6,             "(pos $pos) len after  U; utf8::encode");
-    is(pos($s),    $pos2,         "(pos $pos) pos after  U; utf8::encode");
+    is(pos($s),    undef,         "(pos $pos) pos after  U; utf8::encode");
     is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after  U; utf8::encode");
 }
 
+# [perl #119043] utf8::upgrade should not croak on read-only COWs
+for(__PACKAGE__) {
+       eval { utf8::upgrade($_) };
+       is $@, "", 'no error with utf8::upgrade on read-only COW';
+}
+# This one croaks, but not because the scalar is read-only
+eval "package \x{100};\n" . <<'END'
+    for(__PACKAGE__) {
+       eval { utf8::downgrade($_) };
+       ::like $@, qr/^Wide character/,
+           'right error with utf8::downgrade on read-only COW';
+    }
+    1
+END
+or die $@;
+
 done_testing();