[m-rev.] for review: bugfix for io.set_environment_var/4

[Mark Brown]

Hi everyone,

This fixes a bug I hit recently, where some foreign code was not
picking up an environment variable I had set using
io.set_environment_var/4. The problem occurred after a GC freed the
memory held by the string passed to putenv(), which doesn't make a
copy on my platform (linux, glibc 2.21).

In its current form the change affects C backends for which MR_WIN32
is not defined. This is conservative: online documentation tells me it
is not needed on OSX or FreeBSD either, but I can't easily test that.

For review by anyone.

Cheers,
Mark
-------------- next part --------------
commit 29b4d39860e981b0d607f7edd006cf3a4df0742d
Author: Mark Brown <mark at mercurylang.org>
Date:   Fri Apr 15 22:11:13 2016 +1000

    Fix bug with io.set_environment_var/4 when using glibc.
    
    library/io.m:
    	Prevent garbage collection of strings passed to putenv(), which
    	could otherwise leave dangling references in the environment.
    
    tests/hard_coded/Mmakefile:
    tests/hard_coded/putenv_gc_fail.{m,exp}:
    	Test case.

diff --git a/library/io.m b/library/io.m
index 28fab1a..2c32e73 100644
--- a/library/io.m
+++ b/library/io.m
@@ -10280,23 +10280,45 @@ command_line_argument(_, "") :-
     end
 ").
 
+    % Glibc requires that we keep a copy of strings we pass to putenv(), so
+    % we store them here to prevent them being garbage collected. This map
+    % is *not* used to retrieve values from the environment: a map is used
+    % so that strings can be easily removed if a subsequent call sets a
+    % new value for the environment variable.
+    %
+:- mutable(putenv_strings, map(string, string), map.init, ground, [untrailed]).
+
 io.setenv(Var, Value) :-
-    impure io.putenv(Var ++ "=" ++ Value).
+    VarAndValue = Var ++ "=" ++ Value,
+    impure io.putenv(VarAndValue, Keep),
+    (
+        Keep = no
+    ;
+        Keep = yes,
+        semipure get_putenv_strings(Strings0),
+        map.set(Var, VarAndValue, Strings0, Strings),
+        impure set_putenv_strings(Strings)
+    ).
 
     % io.putenv(VarString): If VarString is a string of the form "name=value",
     % sets the environment variable name to the specified value. Fails if
     % the operation does not work. This should only be called from io.setenv.
     %
-:- impure pred io.putenv(string::in) is semidet.
+    % Returns 'yes' in the second argument if the caller is required to keep
+    % a copy of VarString (i.e., prevent it being garbage collected or freed).
+    %
+:- impure pred io.putenv(string::in, bool::out) is semidet.
 
 :- pragma foreign_proc("C",
-    io.putenv(VarAndValue::in),
+    io.putenv(VarAndValue::in, Keep::out),
     [will_not_call_mercury, not_thread_safe, tabled_for_io,
         does_not_affect_liveness, no_sharing],
 "
 #ifdef MR_WIN32
+    Keep = MR_NO;
     SUCCESS_INDICATOR = (_wputenv(ML_utf8_to_wide(VarAndValue)) == 0);
 #else
+    Keep = MR_YES;
     SUCCESS_INDICATOR = (putenv(VarAndValue) == 0);
 #endif
 ").
@@ -10314,7 +10336,7 @@ io.setenv(Var, Value) :-
 ").
 
 :- pragma foreign_proc("C#",
-    io.putenv(_VarAndValue::in),
+    io.putenv(_VarAndValue::in, _Keep::out),
     [will_not_call_mercury, tabled_for_io],
 "
     // This procedure should never be called, as io.setenv/2 has been
@@ -10336,7 +10358,7 @@ io.setenv(Var, Value) :-
 ").
 
 :- pragma foreign_proc("Java",
-    io.putenv(VarAndValue::in),
+    io.putenv(VarAndValue::in, _Keep::out),
     [will_not_call_mercury, tabled_for_io, may_not_duplicate],
 "
     // This procedure should never be called, as io.setenv/2 has been
@@ -10358,7 +10380,7 @@ io.setenv(Var, Value) :-
 ").
 
 :- pragma foreign_proc("Erlang",
-    io.putenv(VarAndValue::in),
+    io.putenv(VarAndValue::in, _Keep::out),
     [will_not_call_mercury, tabled_for_io],
 "
     % This procedure should never be called, as io.setenv/2 has been
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index 1e19c0e..1d10c07 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -242,6 +242,7 @@ ORDINARY_PROGS =	\
 	promise_eqv_solns_typeclasses \
 	psqueue_test \
 	pure_mutable \
+	putenv_gc_fail \
 	puzzle_detism_bug \
 	qual_adv_test \
 	qual_basic_test \
diff --git a/tests/hard_coded/putenv_gc_fail.exp b/tests/hard_coded/putenv_gc_fail.exp
new file mode 100644
index 0000000..154f429
--- /dev/null
+++ b/tests/hard_coded/putenv_gc_fail.exp
@@ -0,0 +1,3 @@
+Use mem: ok
+Use mem: ok
+Got value: bar
diff --git a/tests/hard_coded/putenv_gc_fail.m b/tests/hard_coded/putenv_gc_fail.m
new file mode 100644
index 0000000..7a35958
--- /dev/null
+++ b/tests/hard_coded/putenv_gc_fail.m
@@ -0,0 +1,39 @@
+:- module putenv_gc_fail.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module gc.
+:- import_module int.
+:- import_module list.
+:- import_module maybe.
+:- import_module string.
+
+main(!IO) :-
+    io.set_environment_var("foo", "bar", !IO),
+    use_mem(1000000, !IO),
+    gc.garbage_collect(!IO),
+    use_mem(1000000, !IO),
+    io.get_environment_var("foo", Res, !IO),
+    (
+        Res = yes(Value),
+        io.write_string("Got value: " ++ Value ++ "\n", !IO)
+    ;
+        Res = no,
+        io.write_string("Failure!\n", !IO)
+    ).
+
+:- pred use_mem(int::in, io::di, io::uo) is det.
+
+use_mem(N, !IO) :-
+    io.write_string("Use mem: ", !IO),
+    ( if length(1 `..` N) = N then
+        io.write_string("ok\n", !IO)
+    else
+        io.write_string("hmm\n", !IO)
+    ).
+