This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_sys.c: pp_select UTF8 cleanup.
authorBrian Fraser <fraserbn@gmail.com>
Sun, 10 Jul 2011 11:18:57 +0000 (08:18 -0300)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 6 Oct 2011 20:01:18 +0000 (13:01 -0700)
MANIFEST
pp_sys.c
t/uni/select.t [new file with mode: 0644]

index b3715f8..b46ef3e 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5286,6 +5286,7 @@ t/uni/method.t                    See if Unicode methods work
 t/uni/overload.t               See if Unicode overloading works
 t/uni/package.t                        See if Unicode in package declarations works
 t/uni/parser.t                 See if Unicode in the parser works in edge cases.
+t/uni/select.t                 See if Unicode filehandles aren't mangled by select()
 t/uni/sprintf.t                        See if Unicode sprintf works
 t/uni/stash.t                  See if Unicode stashes work
 t/uni/tie.t                    See if Unicode tie works
index 79d6787..26aaf2e 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1226,7 +1226,7 @@ PP(pp_select)
     if (! hv)
        XPUSHs(&PL_sv_undef);
     else {
-       GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
+       GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE);
        if (gvp && *gvp == egv) {
            gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
            XPUSHTARG;
diff --git a/t/uni/select.t b/t/uni/select.t
new file mode 100644 (file)
index 0000000..0e00105
--- /dev/null
@@ -0,0 +1,35 @@
+#!./perl
+
+#
+# Tests whenever the return value of select(FH) is correctly encoded.
+#
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+use utf8;
+use open qw( :utf8 :std );
+
+plan( tests => 5 );
+
+open DÙP, ">&", *STDERR;
+open $dùp, ">&", *STDOUT;
+open 둪,  ">&", *STDERR;
+open $ᛞ웊, ">&", *STDOUT;
+
+is select(DÙP), "main::STDOUT";
+is select($dùp), "main::DÙP";
+
+TODO: {
+    local $TODO = "Scalar filehandles not yet clean";
+    is select(둪), "main::dùp";
+}
+
+is select($ᛞ웊), "main::둪";
+TODO: {
+    local $TODO = "Scalar filehandles not yet clean";
+    is select(STDOUT), "main::ᛞ웊";
+}