[m-rev.] for review: add dir.current_directory

[Peter Wang]

Estimated hours taken: 1.5
Branches: main

NEWS:
library/dir.m:
	Add a predicate to return the current working directory, currently
	implemented for C and Erlang backends.

library/io.m:
	Add supporting functions to create io.res(string) values from foreign
	code.

tests/hard_coded/dir_test.exp:
tests/hard_coded/dir_test.exp2:
tests/hard_coded/dir_test.m:
	Test the new predicate.


Index: NEWS
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/NEWS,v
retrieving revision 1.477
diff -u -r1.477 NEWS
--- NEWS	7 Sep 2007 15:08:16 -0000	1.477
+++ NEWS	19 Sep 2007 06:57:30 -0000
@@ -195,6 +195,8 @@
 * We have added a predicate io.remove_file_recursively/4
   which can remove non-empty directories.
 
+* We have added the predicate `dir.current_directory'.
+
 Changes to the Mercury compiler:
 
 * Support for the reserve tag grades has been removed.
Index: library/dir.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/dir.m,v
retrieving revision 1.42
diff -u -r1.42 dir.m
--- library/dir.m	17 Aug 2007 02:08:38 -0000	1.42
+++ library/dir.m	19 Sep 2007 06:57:30 -0000
@@ -164,6 +164,13 @@
 
 %-----------------------------------------------------------------------------%
 
+    % io.current_directory(Result)
+    % Return the current working directory.
+    %
+:- pred dir.current_directory(io.res(string)::out, io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
     % Make the given directory, and all parent directories.
     % This will also succeed if the directory already exists
     % and is readable and writable by the current user.
@@ -820,6 +827,50 @@
 
 %-----------------------------------------------------------------------------%
 
+:- pragma foreign_proc("C",
+    dir.current_directory(Res::out, IO0::di, IO::uo),
+    [may_call_mercury, promise_pure, tabled_for_io, terminates],
+"   
+    size_t      size = 256; 
+    char        *buf;
+    MR_String   str;
+
+    while (1) {
+        buf = MR_GC_NEW_ARRAY(char, size);
+        if (getcwd(buf, size)) {
+            MR_make_aligned_string(str, buf);
+            Res = ML_make_io_res_1_ok_string(str);
+            break;
+        }
+        if (errno != ERANGE) {
+            ML_make_io_res_1_error_string(errno,
+                MR_make_string_const(""dir.current_directory failed: ""),
+                &Res);
+            break;
+        }
+        /* Buffer too small.  Resize and try again. */
+        size *= 1.5;
+    }
+
+    IO = IO0;
+").
+
+:- pragma foreign_proc("Erlang",
+    dir.current_directory(Res::out, _IO0::di, _IO::uo),
+    [may_call_mercury, promise_pure, tabled_for_io, terminates],
+"
+    case file:get_cwd() of
+        {ok, Cwd} ->
+            Res = mercury__io:'ML_make_io_res_1_ok_string'(
+                list_to_binary(Cwd));
+        {error, Reason} ->
+            Res = mercury__io:'ML_make_io_res_1_error_string'(Reason,
+                ""dir.current_directory failed: "")
+    end
+").
+
+%-----------------------------------------------------------------------------%
+
 dir.make_directory(PathName, Result, !IO) :-
     ( can_implement_make_directory ->
         DirName = dir.dirname(PathName),
Index: library/io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/io.m,v
retrieving revision 1.402
diff -u -r1.402 io.m
--- library/io.m	17 Aug 2007 02:08:39 -0000	1.402
+++ library/io.m	19 Sep 2007 06:57:31 -0000
@@ -3568,6 +3568,26 @@
 make_io_res_1_error_file_type(Error, Msg0, error(make_io_error(Msg)), !IO) :-
     io.make_err_msg(Error, Msg0, Msg, !IO).
 
+:- func make_io_res_1_ok_string(string) = io.res(string).
+:- pragma foreign_export("C", (make_io_res_1_ok_string(in) = out),
+    "ML_make_io_res_1_ok_string").
+:- pragma foreign_export("Erlang", (make_io_res_1_ok_string(in) = out),
+    "ML_make_io_res_1_ok_string").
+
+make_io_res_1_ok_string(String) = ok(String).
+
+:- pred make_io_res_1_error_string(io.system_error::in,
+    string::in, io.res(string)::out, io::di, io::uo) is det.
+:- pragma foreign_export("C",
+    make_io_res_1_error_string(in, in, out, di, uo),
+    "ML_make_io_res_1_error_string").
+:- pragma foreign_export("Erlang",
+    make_io_res_1_error_string(in, in, out, di, uo),
+    "ML_make_io_res_1_error_string").
+
+make_io_res_1_error_string(Error, Msg0, error(make_io_error(Msg)), !IO) :-
+    io.make_err_msg(Error, Msg0, Msg, !IO).
+
 %-----------------------------------------------------------------------------%
 
 :- type file_id ---> file_id.
Index: tests/hard_coded/dir_test.exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/dir_test.exp,v
retrieving revision 1.2
diff -u -r1.2 dir_test.exp
--- tests/hard_coded/dir_test.exp	28 Jul 2003 15:50:45 -0000	1.2
+++ tests/hard_coded/dir_test.exp	19 Sep 2007 06:57:31 -0000
@@ -131,6 +131,7 @@
 "foo/"/"bar/baz" = "foo\bar\baz".
 checking whether `unwritable' is readable...ok
 unwritable file found to be unwritable
+current_directory succeeded: hard_coded
 make_directory succeeded
 make_directory succeeded
 dir.make_single_directory with non-existent parent failed as expected.
Index: tests/hard_coded/dir_test.exp2
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/dir_test.exp2,v
retrieving revision 1.2
diff -u -r1.2 dir_test.exp2
--- tests/hard_coded/dir_test.exp2	28 Jul 2003 15:50:45 -0000	1.2
+++ tests/hard_coded/dir_test.exp2	19 Sep 2007 06:57:31 -0000
@@ -128,6 +128,7 @@
 "foo/"/"bar/baz" = "foo/bar/baz".
 checking whether `unwritable' is readable...ok
 unwritable file found to be unwritable
+current_directory succeeded: hard_coded
 make_directory succeeded
 make_directory succeeded
 dir.make_single_directory with non-existent parent failed as expected.
Index: tests/hard_coded/dir_test.m
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/dir_test.m,v
retrieving revision 1.4
diff -u -r1.4 dir_test.m
--- tests/hard_coded/dir_test.m	29 Mar 2006 08:08:00 -0000	1.4
+++ tests/hard_coded/dir_test.m	19 Sep 2007 06:57:31 -0000
@@ -60,6 +60,19 @@
 		"unwritable file found to be unwritable\n")
 	),
 
+	dir__current_directory(CwdResult),
+	(
+	    { CwdResult = ok(Cwd) },
+	    io__write_string("current_directory succeeded: "),
+	    io__write_string(dir__det_basename(Cwd)),
+	    io__nl
+	;
+	    { CwdResult = error(Error) },
+	    io__write_string("current_directory failed: "),
+	    io__write_string(io__error_message(Error)),
+	    io__nl
+	),
+
 	{ Dir1 = "test_dir"/"d1" },
 	test0("make_directory", dir__make_directory(Dir1)),
 	% Test making a directory that already exists.

--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to:       mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions:          mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------