When setting environment variables via %ENV, force values to be strings only

(turning off other OK flags), make them byte strings; if wide characters can't
be downgraded to bytes, leave the string utf8 and issue a warning.

diff --git a/mg.c b/mg.c
index 2705109..f4979f1 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1165,13 +1165,22 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
     dVAR;
     STRLEN len = 0, klen;
     const char * const key = MgPV_const(mg,klen);
-    const char *s = "";
+    const char *s = NULL;
 
     PERL_ARGS_ASSERT_MAGIC_SETENV;
 
+    SvGETMAGIC(sv);
     if (SvOK(sv)) {
-       s = SvPV_const(sv,len);
-       SvPOK_only(sv); /* environment variables are strings, period */
+        /* defined environment variables are byte strings; unfortunately
+           there is no SvPVbyte_force_nomg(), so we must do this piecewise */
+        (void)SvPV_force_nomg_nolen(sv);
+        sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
+        if (SvUTF8(sv)) {
+            Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
+            SvUTF8_off(sv);
+        }
+        s = SvPVX(sv);
+        len = SvCUR(sv);
     }
     my_setenv(key, s); /* does the deed */
 

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 27ab286..eb4bc06 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -38,13 +38,21 @@ L</Selected Bug Fixes> section.
 
 =head1 Incompatible Changes
 
-XXX For a release on a stable branch, this section aspires to be:
+[ List each incompatible change as a =head2 entry ]
 
-    There are no changes intentionally incompatible with 5.XXX.XXX
-    If any exist, they are bugs, and we request that you submit a
-    report.  See L</Reporting Bugs> below.
+=head2 C<$ENV{foo} = undef> deletes value from environ, like C<delete $ENV{foo}>
 
-[ List each incompatible change as a =head2 entry ]
+This facilitates use of C<local()> with C<%ENV> entries.  In previous
+versions of Perl, C<undef> was converted to the empty string.
+
+=head2 Defined values stored in environment are forced to byte strings
+
+A value stored in an environment variable has always been stringified.  In
+this release, it is converted to be only a byte string.  First, it is forced
+to be a only a string.  Then if the string is utf8 and the equivalent of
+C<utf8::downgrade> works, that result is used; otherwise, the equivalent of
+C<utf8::encode> is used, and a warning is issued about wide characters
+(L</Diagnostics>).
 
 =head1 Deprecations
 
@@ -164,6 +172,15 @@ include any changes in L<perldiag> that reconcile it to the C<C> code.
 
 XXX Newly added diagnostic messages go here
 
+=over 4
+
+=item *
+
+Attempts to put wide characters into environment variables via %ENV provoke
+the warning "Wide character in setenv".
+
+=back
+
 =head3 New Errors
 
 =over 4

diff --git a/t/op/magic.t b/t/op/magic.t
index 643eeb6..c6c796d 100644 (file)
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan (tests => 156);
+    plan (tests => 171);
 }
 
 # Test that defined() returns true for magic variables created on the fly,
@@ -63,6 +63,17 @@ $PERL = $ENV{PERL}
        $Is_MSWin32            ? '.\perl' :
        './perl');
 
+sub env_is {
+    my ($key, $val, $desc) = @_;
+    if ($Is_MSWin32) {
+        # cmd.exe will echo 'variable=value' but 4nt will echo just the value
+        # -- Nikola Knezevic
+        like `set $key`, qr/^(?:\Q$key\E=)?\Q$val\E$/, $desc;
+    } else {
+        is `echo \$\Q$key\E`, "$val\n", $desc;
+    }
+}
+
 END {
     # On VMS, environment variable changes are peristent after perl exits
     delete $ENV{'FOO'} if $Is_VMS;
@@ -604,15 +615,57 @@ SKIP: {
            }
        }
 
-       $ENV{__NoNeSuCh} = "foo";
-       $0 = "bar";
-# cmd.exe will echo 'variable=value' but 4nt will echo just the value
-# -- Nikola Knezevic
-       if ($Is_MSWin32) {
-           like `set __NoNeSuCh`, qr/^(?:__NoNeSuCh=)?foo$/;
-       } else {
-           is `echo \$__NoNeSuCh`, "foo\n";
+       $ENV{__NoNeSuCh} = 'foo';
+       $0 = 'bar';
+       env_is(__NoNeSuCh => 'foo', 'setting $0 does not break %ENV');
+
+       # stringify a glob
+       $ENV{foo} = *TODO;
+       env_is(foo => '*main::TODO', 'ENV store of stringified glob');
+
+       # stringify a ref
+       my $ref = [];
+       $ENV{foo} = $ref;
+       env_is(foo => "$ref", 'ENV store of stringified ref');
+
+       # downgrade utf8 when possible
+       $bytes = "eh zero \x{A0}";
+       utf8::upgrade($chars = $bytes);
+       $forced = $ENV{foo} = $chars;
+       ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store downgrades utf8 in SV');
+       env_is(foo => $bytes, 'ENV store downgrades utf8 in setenv');
+
+       # warn when downgrading utf8 is not possible
+       $chars = "X-Day \x{1998}";
+       utf8::encode($bytes = $chars);
+       {
+         my $warned = 0;
+         local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /^Wide character in setenv/; print "# @_" };
+         $forced = $ENV{foo} = $chars;
+         ok($warned == 1, 'ENV store warns about wide characters');
        }
+       ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store encodes high utf8 in SV');
+       env_is(foo => $bytes, 'ENV store encodes high utf8 in SV');
+
+       # test local $ENV{foo} on existing foo
+       {
+         local $ENV{__NoNeSuCh};
+         { local $TODO = 'exists on %ENV should reflect real env';
+           ok(!exists $ENV{__NoNeSuCh}, 'not exists $ENV{existing} during local $ENV{existing}'); }
+         env_is(__NoNeLoCaL => '');
+       }
+       ok(exists $ENV{__NoNeSuCh}, 'exists $ENV{existing} after local $ENV{existing}');
+       env_is(__NoNeSuCh => 'foo');
+
+       # test local $ENV{foo} on new foo
+       {
+         local $ENV{__NoNeLoCaL} = 'foo';
+         ok(exists $ENV{__NoNeLoCaL}, 'exists $ENV{new} during local $ENV{new}');
+         env_is(__NoNeLoCaL => 'foo');
+       }
+       ok(!exists $ENV{__NoNeLoCaL}, 'not exists $ENV{new} after local $ENV{new}');
+       env_is(__NoNeLoCaL => '');
+
     SKIP: {
            skip("\$0 check only on Linux and FreeBSD", 2)
                unless $^O =~ /^(linux|freebsd)$/