Ajout primitives LargeFile

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4486 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

5 files changed, 162 insertions, 7 deletions

diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt
index 4d7daa658..dc0e8cd78 100644
--- a/otherlibs/win32unix/Makefile.nt
+++ b/otherlibs/win32unix/Makefile.nt
@@ -28,15 +28,15 @@ WIN_OBJS = accept.obj bind.obj channels.obj close.obj \
   getpeername.obj getpid.obj getsockname.obj gettimeofday.obj \
   link.obj listen.obj lseek.obj \
   mkdir.obj open.obj pipe.obj read.obj select.obj sendrecv.obj \
-  shutdown.obj sleep.obj socket.obj sockopt.obj startup.obj system.obj \
-  unixsupport.obj windir.obj winwait.obj write.obj
+  shutdown.obj sleep.obj socket.obj sockopt.obj startup.obj stat.obj \
+  system.obj unixsupport.obj windir.obj winwait.obj write.obj
 
 # Files from the ..\unix directory
 UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \
   cstringv.c envir.c execv.c execve.c execvp.c \
   exit.c getcwd.c gethost.c gethostname.c getproto.c \
   getserv.c gmtime.c putenv.c rename.c rmdir.c \
-  socketaddr.c stat.c strofaddr.c time.c unlink.c utimes.c
+  socketaddr.c strofaddr.c time.c unlink.c utimes.c
 
 UNIX_OBJS = $(UNIX_FILES:.c=.obj)
 
diff --git a/otherlibs/win32unix/lseek.c b/otherlibs/win32unix/lseek.c
index 9544268cf..06f636fe3 100644
--- a/otherlibs/win32unix/lseek.c
+++ b/otherlibs/win32unix/lseek.c
@@ -28,14 +28,48 @@ static int seek_command_table[] = {
   FILE_BEGIN, FILE_CURRENT, FILE_END
 };
 
+#ifndef INVALID_SET_FILE_POINTER
+#define INVALID_SET_FILE_POINTER (-1)
+#endif
+
 CAMLprim value unix_lseek(value fd, value ofs, value cmd)
 {
   long ret;
-  ret = SetFilePointer(Handle_val(fd), Long_val(ofs), NULL,
+  long ofs_low = Long_val(ofs);
+  long ofs_high = ofs_low >= 0 ? 0 : -1;
+  long err;
+
+  ret = SetFilePointer(Handle_val(fd), ofs_low, &ofs_high,
                        seek_command_table[Int_val(cmd)]);
-  if (ret == -1) {
-    win32_maperr(GetLastError());
+  if (ret == INVALID_SET_FILE_POINTER) {
+    err = GetLastError();
+    if (err != NO_ERROR) {
+      win32_maperr(err);
+      uerror("lseek", Nothing);
+    }
+  }
+  if (ofs_high != 0 || ret > Max_long) {
+    win32_maperr(ERROR_ARITHMETIC_OVERFLOW);
     uerror("lseek", Nothing);
   }
   return Val_long(ret);
 }
+
+CAMLprim value unix_lseek_64(value fd, value ofs, value cmd)
+{
+  long ret;
+  long ofs_low = (long) Int64_val(ofs);
+  long ofs_high = (long) (Int64_val(ofs) >> 32);
+  long err;
+
+  ret = SetFilePointer(Handle_val(fd), ofs_low, &ofs_high,
+                       seek_command_table[Int_val(cmd)]);
+  if (ret == INVALID_SET_FILE_POINTER) {
+    err = GetLastError();
+    if (err != NO_ERROR) {
+      win32_maperr(err);
+      uerror("lseek", Nothing);
+    }
+  }
+  return copy_int64(ofs_high << 32 | ret);
+}
diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c
new file mode 100644
index 000000000..6a1259acd
--- /dev/null
+++ b/otherlibs/win32unix/stat.c
@@ -0,0 +1,93 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2002 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../../LICENSE.  */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <errno.h>
+#include <mlvalues.h>
+#include <memory.h>
+#include <alloc.h>
+#include "unixsupport.h"
+#include "cst2constr.h"
+#define _INTEGRAL_MAX_BITS 64
+#include <sys/types.h>
+#include <sys/stat.h>
+
+#ifndef S_IFLNK
+#define S_IFLNK 0
+#endif
+#ifndef S_IFIFO
+#define S_IFIFO 0
+#endif
+#ifndef S_IFSOCK
+#define S_IFSOCK 0
+#endif
+#ifndef S_IFBLK
+#define S_IFBLK 0
+#endif
+
+static int file_kind_table[] = {
+  S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, S_IFLNK, S_IFIFO, S_IFSOCK
+};
+
+static value stat_aux(int use_64, struct _stati64 *buf)
+{
+  value v;
+  value atime = Val_unit, mtime = Val_unit, ctime = Val_unit;
+
+  Begin_roots3(atime,mtime,ctime)
+    atime = copy_double((double) buf->st_atime);
+    mtime = copy_double((double) buf->st_mtime);
+    ctime = copy_double((double) buf->st_ctime);
+    v = alloc_small(12, 0);
+    Field (v, 0) = Val_int (buf->st_dev);
+    Field (v, 1) = Val_int (buf->st_ino);
+    Field (v, 2) = cst_to_constr(buf->st_mode & S_IFMT, file_kind_table,
+                                 sizeof(file_kind_table) / sizeof(int), 0);
+    Field (v, 3) = Val_int(buf->st_mode & 07777);
+    Field (v, 4) = Val_int (buf->st_nlink);
+    Field (v, 5) = Val_int (buf->st_uid);
+    Field (v, 6) = Val_int (buf->st_gid);
+    Field (v, 7) = Val_int (buf->st_rdev);
+    Field (v, 8) = 
+      use_64 ? copy_int64(buf->st_size) : Val_int (buf->st_size);
+    Field (v, 9) = atime;
+    Field (v, 10) = mtime;
+    Field (v, 11) = ctime;
+  End_roots();
+  return v;
+}
+
+CAMLprim value unix_stat(value path)
+{
+  int ret;
+  struct _stati64 buf;
+
+  ret = _stati64(String_val(path), &buf);
+  if (ret == -1) uerror("stat", path);
+  if (buf.st_size > Max_long) {
+    win32_maperr(ERROR_ARITHMETIC_OVERFLOW);
+    uerror("stat", path);
+  }
+  return stat_aux(0, &buf);
+}
+
+CAMLprim value unix_stat_64(value path)
+{
+  int ret;
+  struct _stati64 buf;
+  ret = _stati64(String_val(path), &buf);
+  if (ret == -1) uerror("stat", path);
+  return stat_aux(1, &buf);
+}
+
diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
index 56cfb4ba2..936a763fe 100644
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -92,6 +92,7 @@ type error =
   | EHOSTDOWN           (* Host is down *)
   | EHOSTUNREACH        (* No route to host *)
   | ELOOP               (* Too many levels of symbolic links *)
+  | EOVERFLOW
   (* All other errors are mapped to EUNKNOWNERR *)
   | EUNKNOWNERR of int  (* Unknown error *)
 
@@ -254,6 +255,32 @@ external unlink : string -> unit = "unix_unlink"
 external rename : string -> string -> unit = "unix_rename"
 external link : string -> string -> unit = "unix_link"
 
+(* Operations on large files *)
+
+module LargeFile =
+  struct
+    external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64"
+    let truncate name len = invalid_arg "Unix.LargeFile.truncate not implemented"
+    let ftruncate name len = invalid_arg "Unix.LargeFile.ftruncate not implemented"
+    type stats =
+      { st_dev : int;
+        st_ino : int;
+        st_kind : file_kind;
+        st_perm : file_perm;
+        st_nlink : int;
+        st_uid : int;
+        st_gid : int;
+        st_rdev : int;
+        st_size : int64;
+        st_atime : float;
+        st_mtime : float;
+        st_ctime : float;
+      }
+    external stat : string -> stats = "unix_stat_64"
+    let lstat = stat
+    let fstat fd = invalid_arg "Unix.LargeFile.fstat not implemented"
+  end
+
 (* File permissions and ownership *)
 
 type access_permission =
diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c
index f4e6e2867..9f3ae3189 100644
--- a/otherlibs/win32unix/unixsupport.c
+++ b/otherlibs/win32unix/unixsupport.c
@@ -182,6 +182,7 @@ void win32_maperr(unsigned long errcode)
 #define ESTALE                  -WSAESTALE
 #define EREMOTE                 -WSAEREMOTE
 
+#define EOVERFLOW -ERROR_ARITHMETIC_OVERFLOW
 #define EACCESS EACCES
 
 int error_table[] = {
@@ -195,7 +196,7 @@ int error_table[] = {
   EAFNOSUPPORT, EADDRINUSE, EADDRNOTAVAIL, ENETDOWN, ENETUNREACH,
   ENETRESET, ECONNABORTED, ECONNRESET, ENOBUFS, EISCONN, ENOTCONN,
   ESHUTDOWN, ETOOMANYREFS, ETIMEDOUT, ECONNREFUSED, EHOSTDOWN,
-  EHOSTUNREACH, ELOOP /*, EUNKNOWNERR */
+  EHOSTUNREACH, ELOOP, EOVERFLOW /*, EUNKNOWNERR */
 };
 
 static value * unix_error_exn = NULL;