Add Ocamltest_stdlib.Unix.has_symlink
Replaces the duplicated C stub. Functions from Unix must be explictly imported.master
parent
f341db8dbe
commit
9bc33d945a
|
@ -118,6 +118,7 @@ _build
|
||||||
/ocamltest/ocamltest
|
/ocamltest/ocamltest
|
||||||
/ocamltest/ocamltest.opt
|
/ocamltest/ocamltest.opt
|
||||||
/ocamltest/ocamltest_config.ml
|
/ocamltest/ocamltest_config.ml
|
||||||
|
/ocamltest/ocamltest_unix.ml
|
||||||
/ocamltest/tsl_lexer.ml
|
/ocamltest/tsl_lexer.ml
|
||||||
/ocamltest/tsl_parser.ml
|
/ocamltest/tsl_parser.ml
|
||||||
/ocamltest/tsl_parser.mli
|
/ocamltest/tsl_parser.mli
|
||||||
|
|
2
Makefile
2
Makefile
|
@ -867,7 +867,7 @@ ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex
|
||||||
$(MAKE) -C ocamldoc opt.opt
|
$(MAKE) -C ocamldoc opt.opt
|
||||||
|
|
||||||
# OCamltest
|
# OCamltest
|
||||||
ocamltest: ocamlc ocamlyacc ocamllex
|
ocamltest: ocamlc ocamlyacc ocamllex otherlibraries
|
||||||
$(MAKE) -C ocamltest all
|
$(MAKE) -C ocamltest all
|
||||||
|
|
||||||
ocamltest.opt: ocamlc.opt ocamlyacc ocamllex
|
ocamltest.opt: ocamlc.opt ocamlyacc ocamllex
|
||||||
|
|
|
@ -346,12 +346,20 @@ ocamltest_config.cmx : \
|
||||||
ocamltest_config.cmi
|
ocamltest_config.cmi
|
||||||
ocamltest_config.cmi :
|
ocamltest_config.cmi :
|
||||||
ocamltest_stdlib.cmo : \
|
ocamltest_stdlib.cmo : \
|
||||||
|
ocamltest_unix.cmi \
|
||||||
ocamltest_config.cmi \
|
ocamltest_config.cmi \
|
||||||
ocamltest_stdlib.cmi
|
ocamltest_stdlib.cmi
|
||||||
ocamltest_stdlib.cmx : \
|
ocamltest_stdlib.cmx : \
|
||||||
|
ocamltest_unix.cmx \
|
||||||
ocamltest_config.cmx \
|
ocamltest_config.cmx \
|
||||||
ocamltest_stdlib.cmi
|
ocamltest_stdlib.cmi
|
||||||
ocamltest_stdlib.cmi :
|
ocamltest_stdlib.cmi : \
|
||||||
|
ocamltest_unix.cmi
|
||||||
|
ocamltest_unix.cmo : \
|
||||||
|
ocamltest_unix.cmi
|
||||||
|
ocamltest_unix.cmx : \
|
||||||
|
ocamltest_unix.cmi
|
||||||
|
ocamltest_unix.cmi :
|
||||||
options.cmo : \
|
options.cmo : \
|
||||||
variables.cmi \
|
variables.cmi \
|
||||||
tests.cmi \
|
tests.cmi \
|
||||||
|
|
|
@ -33,8 +33,16 @@ else
|
||||||
endif
|
endif
|
||||||
|
|
||||||
ifeq "$(filter $(UNIXLIB),$(OTHERLIBRARIES))" ""
|
ifeq "$(filter $(UNIXLIB),$(OTHERLIBRARIES))" ""
|
||||||
|
ocamltest_unix := dummy
|
||||||
|
unix_name :=
|
||||||
|
unix_path :=
|
||||||
unix := None
|
unix := None
|
||||||
|
unix_include :=
|
||||||
else
|
else
|
||||||
|
ocamltest_unix := real
|
||||||
|
unix_name := unix
|
||||||
|
unix_path := $(ROOTDIR)/otherlibs/$(UNIXLIB)
|
||||||
|
unix_include := -I $(unix_path) $(EMPTY)
|
||||||
ifeq "$(UNIX_OR_WIN32)" "win32"
|
ifeq "$(UNIX_OR_WIN32)" "win32"
|
||||||
unix := Some false
|
unix := Some false
|
||||||
else
|
else
|
||||||
|
@ -97,8 +105,8 @@ endif
|
||||||
|
|
||||||
core := \
|
core := \
|
||||||
$(run_source) run_stubs.c \
|
$(run_source) run_stubs.c \
|
||||||
ocamltest_stdlib_stubs.c \
|
|
||||||
ocamltest_config.mli ocamltest_config.ml.in \
|
ocamltest_config.mli ocamltest_config.ml.in \
|
||||||
|
ocamltest_unix.mli ocamltest_unix.ml \
|
||||||
ocamltest_stdlib.mli ocamltest_stdlib.ml \
|
ocamltest_stdlib.mli ocamltest_stdlib.ml \
|
||||||
run_command.mli run_command.ml \
|
run_command.mli run_command.ml \
|
||||||
filecompare.mli filecompare.ml \
|
filecompare.mli filecompare.ml \
|
||||||
|
@ -166,6 +174,7 @@ parsers := $(filter %.mly,$(sources))
|
||||||
config_files := $(filter %.ml.in,$(sources))
|
config_files := $(filter %.ml.in,$(sources))
|
||||||
|
|
||||||
dependencies_generated_prereqs := \
|
dependencies_generated_prereqs := \
|
||||||
|
ocamltest_unix.ml \
|
||||||
$(config_files:.ml.in=.ml) \
|
$(config_files:.ml.in=.ml) \
|
||||||
$(lexers:.mll=.ml) \
|
$(lexers:.mll=.ml) \
|
||||||
$(parsers:.mly=.mli) $(parsers:.mly=.ml)
|
$(parsers:.mly=.mli) $(parsers:.mly=.ml)
|
||||||
|
@ -185,9 +194,9 @@ flags := -g -nostdlib $(include_directories) \
|
||||||
-strict-sequence -safe-string -strict-formats \
|
-strict-sequence -safe-string -strict-formats \
|
||||||
-w +a-4-9-41-42-44-45-48 -warn-error A
|
-w +a-4-9-41-42-44-45-48 -warn-error A
|
||||||
|
|
||||||
ocamlc := $(BEST_OCAMLC) $(flags)
|
ocamlc = $(BEST_OCAMLC) $(flags)
|
||||||
|
|
||||||
ocamlopt := $(BEST_OCAMLOPT) $(flags)
|
ocamlopt = $(BEST_OCAMLOPT) $(flags)
|
||||||
|
|
||||||
ocamldep := $(BEST_OCAMLDEP)
|
ocamldep := $(BEST_OCAMLDEP)
|
||||||
depflags := -slash
|
depflags := -slash
|
||||||
|
@ -210,26 +219,29 @@ opt.opt: allopt
|
||||||
|
|
||||||
compdeps_names=ocamlcommon ocamlbytecomp
|
compdeps_names=ocamlcommon ocamlbytecomp
|
||||||
compdeps_paths=$(addprefix $(ROOTDIR)/compilerlibs/,$(compdeps_names))
|
compdeps_paths=$(addprefix $(ROOTDIR)/compilerlibs/,$(compdeps_names))
|
||||||
compdeps_byte=$(addsuffix .cma,$(compdeps_paths))
|
deps_paths=$(compdeps_paths) $(addprefix $(unix_path)/,$(unix_name))
|
||||||
compdeps_opt=$(addsuffix .cmxa,$(compdeps_paths))
|
deps_byte=$(addsuffix .cma,$(deps_paths))
|
||||||
|
deps_opt=$(addsuffix .cmxa,$(deps_paths))
|
||||||
|
|
||||||
$(eval $(call PROGRAM_SYNONYM,ocamltest))
|
$(eval $(call PROGRAM_SYNONYM,ocamltest))
|
||||||
|
|
||||||
ocamltest$(EXE): $(compdeps_byte) $(bytecode_modules)
|
ocamltest_unix.%: flags+=$(unix_include) -opaque
|
||||||
$(ocamlc_cmd) -custom -o $@ $^
|
|
||||||
|
|
||||||
%.cmo: %.ml $(compdeps_byte)
|
ocamltest$(EXE): $(deps_byte) $(bytecode_modules)
|
||||||
|
$(ocamlc_cmd) $(unix_include)-custom -o $@ $^
|
||||||
|
|
||||||
|
%.cmo: %.ml $(deps_byte)
|
||||||
$(ocamlc) -c $<
|
$(ocamlc) -c $<
|
||||||
|
|
||||||
$(eval $(call PROGRAM_SYNONYM,ocamltest.opt))
|
$(eval $(call PROGRAM_SYNONYM,ocamltest.opt))
|
||||||
|
|
||||||
ocamltest.opt$(EXE): $(compdeps_opt) $(native_modules)
|
ocamltest.opt$(EXE): $(deps_opt) $(native_modules)
|
||||||
$(ocamlopt_cmd) -o $@ $^
|
$(ocamlopt_cmd) $(unix_include)-o $@ $^
|
||||||
|
|
||||||
%.cmx: %.ml $(compdeps_opt)
|
%.cmx: %.ml $(deps_opt)
|
||||||
$(ocamlopt) -c $<
|
$(ocamlopt) -c $<
|
||||||
|
|
||||||
%.cmi: %.mli $(compdeps_byte)
|
%.cmi: %.mli $(deps_byte)
|
||||||
$(ocamlc) -c $<
|
$(ocamlc) -c $<
|
||||||
|
|
||||||
%.ml %.mli: %.mly
|
%.ml %.mli: %.mly
|
||||||
|
@ -238,6 +250,10 @@ ocamltest.opt$(EXE): $(compdeps_opt) $(native_modules)
|
||||||
%.ml: %.mll
|
%.ml: %.mll
|
||||||
$(ocamllex) $(OCAMLLEX_FLAGS) $<
|
$(ocamllex) $(OCAMLLEX_FLAGS) $<
|
||||||
|
|
||||||
|
ocamltest_unix.ml: ocamltest_unix_$(ocamltest_unix).ml
|
||||||
|
echo '# 1 "$^"' > $@
|
||||||
|
cat $^ >> $@
|
||||||
|
|
||||||
ocamltest_config.ml: ocamltest_config.ml.in Makefile ../Makefile.config
|
ocamltest_config.ml: ocamltest_config.ml.in Makefile ../Makefile.config
|
||||||
sed $(call SUBST,AFL_INSTRUMENT) \
|
sed $(call SUBST,AFL_INSTRUMENT) \
|
||||||
$(call SUBST,RUNTIMEI) \
|
$(call SUBST,RUNTIMEI) \
|
||||||
|
|
|
@ -195,7 +195,7 @@ let naked_pointers = make
|
||||||
|
|
||||||
let has_symlink = make
|
let has_symlink = make
|
||||||
"has_symlink"
|
"has_symlink"
|
||||||
(Actions_helpers.pass_or_skip (Sys.has_symlink () )
|
(Actions_helpers.pass_or_skip (Unix.has_symlink () )
|
||||||
"symlinks available"
|
"symlinks available"
|
||||||
"symlinks not available")
|
"symlinks not available")
|
||||||
|
|
||||||
|
|
|
@ -15,6 +15,8 @@
|
||||||
|
|
||||||
(* A few extensions to OCaml's standard library *)
|
(* A few extensions to OCaml's standard library *)
|
||||||
|
|
||||||
|
module Unix = Ocamltest_unix
|
||||||
|
|
||||||
(* Pervaisive *)
|
(* Pervaisive *)
|
||||||
|
|
||||||
let input_line_opt ic =
|
let input_line_opt ic =
|
||||||
|
@ -165,8 +167,6 @@ module Sys = struct
|
||||||
let force_remove file =
|
let force_remove file =
|
||||||
if file_exists file then remove file
|
if file_exists file then remove file
|
||||||
|
|
||||||
external has_symlink : unit -> bool = "caml_has_symlink"
|
|
||||||
|
|
||||||
let with_chdir path f =
|
let with_chdir path f =
|
||||||
let oldcwd = Sys.getcwd () in
|
let oldcwd = Sys.getcwd () in
|
||||||
Sys.chdir path;
|
Sys.chdir path;
|
||||||
|
|
|
@ -54,10 +54,13 @@ module Sys : sig
|
||||||
val copy_chan : in_channel -> out_channel -> unit
|
val copy_chan : in_channel -> out_channel -> unit
|
||||||
val copy_file : string -> string -> unit
|
val copy_file : string -> string -> unit
|
||||||
val force_remove : string -> unit
|
val force_remove : string -> unit
|
||||||
val has_symlink : unit -> bool
|
|
||||||
val with_chdir : string -> (unit -> 'a) -> 'a
|
val with_chdir : string -> (unit -> 'a) -> 'a
|
||||||
val getenv_with_default_value : string -> string -> string
|
val getenv_with_default_value : string -> string -> string
|
||||||
val safe_getenv : string -> string
|
val safe_getenv : string -> string
|
||||||
val with_input_file : ?bin:bool -> string -> (in_channel -> 'a) -> 'a
|
val with_input_file : ?bin:bool -> string -> (in_channel -> 'a) -> 'a
|
||||||
val with_output_file : ?bin:bool -> string -> (out_channel -> 'a) -> 'a
|
val with_output_file : ?bin:bool -> string -> (out_channel -> 'a) -> 'a
|
||||||
end
|
end
|
||||||
|
|
||||||
|
module Unix : sig
|
||||||
|
include module type of Ocamltest_unix
|
||||||
|
end
|
||||||
|
|
|
@ -1,151 +0,0 @@
|
||||||
/**************************************************************************/
|
|
||||||
/* */
|
|
||||||
/* OCaml */
|
|
||||||
/* */
|
|
||||||
/* Sebastien Hinderer, projet Gallium, INRIA Paris */
|
|
||||||
/* */
|
|
||||||
/* Copyright 2018 Institut National de Recherche en Informatique et */
|
|
||||||
/* en Automatique. */
|
|
||||||
/* */
|
|
||||||
/* All rights reserved. This file is distributed under the terms of */
|
|
||||||
/* the GNU Lesser General Public License version 2.1, with the */
|
|
||||||
/* special exception on linking described in the file LICENSE. */
|
|
||||||
/* */
|
|
||||||
/**************************************************************************/
|
|
||||||
|
|
||||||
/* Stubs for ocamltest's standard library */
|
|
||||||
|
|
||||||
#include <stdio.h>
|
|
||||||
#include <stdlib.h>
|
|
||||||
|
|
||||||
#include <caml/config.h>
|
|
||||||
#include <caml/mlvalues.h>
|
|
||||||
#include <caml/memory.h>
|
|
||||||
#include <caml/alloc.h>
|
|
||||||
/*
|
|
||||||
#include <caml/fail.h>
|
|
||||||
*/
|
|
||||||
#include <caml/signals.h>
|
|
||||||
#include <caml/osdeps.h>
|
|
||||||
|
|
||||||
|
|
||||||
#ifdef _WIN32
|
|
||||||
|
|
||||||
/*
|
|
||||||
* Windows Vista functions enabled
|
|
||||||
*/
|
|
||||||
#undef _WIN32_WINNT
|
|
||||||
#define _WIN32_WINNT 0x0600
|
|
||||||
|
|
||||||
#include <wtypes.h>
|
|
||||||
#include <winbase.h>
|
|
||||||
#include <process.h>
|
|
||||||
#include <sys/types.h>
|
|
||||||
|
|
||||||
// Developer Mode allows the creation of symlinks without elevation - see
|
|
||||||
// https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-createsymboliclinkw
|
|
||||||
static BOOL IsDeveloperModeEnabled()
|
|
||||||
{
|
|
||||||
HKEY hKey;
|
|
||||||
LSTATUS status;
|
|
||||||
DWORD developerModeRegistryValue, dwordSize = sizeof(DWORD);
|
|
||||||
|
|
||||||
status = RegOpenKeyExW(
|
|
||||||
HKEY_LOCAL_MACHINE,
|
|
||||||
L"SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\AppModelUnlock",
|
|
||||||
0,
|
|
||||||
KEY_READ | KEY_WOW64_64KEY,
|
|
||||||
&hKey
|
|
||||||
);
|
|
||||||
if (status != ERROR_SUCCESS) {
|
|
||||||
return FALSE;
|
|
||||||
}
|
|
||||||
|
|
||||||
status = RegQueryValueExW(
|
|
||||||
hKey,
|
|
||||||
L"AllowDevelopmentWithoutDevLicense",
|
|
||||||
NULL,
|
|
||||||
NULL,
|
|
||||||
(LPBYTE)&developerModeRegistryValue,
|
|
||||||
&dwordSize
|
|
||||||
);
|
|
||||||
RegCloseKey(hKey);
|
|
||||||
if (status != ERROR_SUCCESS) {
|
|
||||||
return FALSE;
|
|
||||||
}
|
|
||||||
return developerModeRegistryValue != 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
#define luid_eq(l, r) (l.LowPart == r.LowPart && l.HighPart == r.HighPart)
|
|
||||||
|
|
||||||
CAMLprim value caml_has_symlink(value unit)
|
|
||||||
{
|
|
||||||
CAMLparam1(unit);
|
|
||||||
HANDLE hProcess = GetCurrentProcess();
|
|
||||||
BOOL result = FALSE;
|
|
||||||
|
|
||||||
if (IsDeveloperModeEnabled()) {
|
|
||||||
CAMLreturn(Val_true);
|
|
||||||
}
|
|
||||||
|
|
||||||
if (OpenProcessToken(hProcess, TOKEN_READ, &hProcess)) {
|
|
||||||
LUID seCreateSymbolicLinkPrivilege;
|
|
||||||
|
|
||||||
if (LookupPrivilegeValue(NULL,
|
|
||||||
SE_CREATE_SYMBOLIC_LINK_NAME,
|
|
||||||
&seCreateSymbolicLinkPrivilege)) {
|
|
||||||
DWORD length;
|
|
||||||
|
|
||||||
if (!GetTokenInformation(hProcess, TokenPrivileges, NULL, 0, &length)) {
|
|
||||||
if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
|
|
||||||
TOKEN_PRIVILEGES* privileges =
|
|
||||||
(TOKEN_PRIVILEGES*)caml_stat_alloc(length);
|
|
||||||
if (GetTokenInformation(hProcess,
|
|
||||||
TokenPrivileges,
|
|
||||||
privileges,
|
|
||||||
length,
|
|
||||||
&length)) {
|
|
||||||
DWORD count = privileges->PrivilegeCount;
|
|
||||||
|
|
||||||
if (count) {
|
|
||||||
LUID_AND_ATTRIBUTES* privs = privileges->Privileges;
|
|
||||||
while (count-- &&
|
|
||||||
!(result = luid_eq(privs->Luid,
|
|
||||||
seCreateSymbolicLinkPrivilege)))
|
|
||||||
privs++;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
caml_stat_free(privileges);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
CloseHandle(hProcess);
|
|
||||||
}
|
|
||||||
|
|
||||||
CAMLreturn(Val_bool(result));
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
#else /* _WIN32 */
|
|
||||||
|
|
||||||
#ifdef HAS_SYMLINK
|
|
||||||
|
|
||||||
CAMLprim value caml_has_symlink(value unit)
|
|
||||||
{
|
|
||||||
CAMLparam0();
|
|
||||||
CAMLreturn(Val_true);
|
|
||||||
}
|
|
||||||
|
|
||||||
#else /* HAS_SYMLINK */
|
|
||||||
|
|
||||||
CAMLprim value caml_has_symlink(value unit)
|
|
||||||
{
|
|
||||||
CAMLparam0();
|
|
||||||
CAMLreturn(Val_false);
|
|
||||||
}
|
|
||||||
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#endif /* _WIN32 */
|
|
|
@ -0,0 +1,18 @@
|
||||||
|
(**************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* OCaml *)
|
||||||
|
(* *)
|
||||||
|
(* David Allsopp, OCaml Labs, Cambridge. *)
|
||||||
|
(* *)
|
||||||
|
(* Copyright 2020 David Allsopp Ltd. *)
|
||||||
|
(* *)
|
||||||
|
(* All rights reserved. This file is distributed under the terms of *)
|
||||||
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
||||||
|
(* special exception on linking described in the file LICENSE. *)
|
||||||
|
(* *)
|
||||||
|
(**************************************************************************)
|
||||||
|
|
||||||
|
(** Functions imported from Unix. They are explicitly here to remove the
|
||||||
|
temptation to use the Unix module directly in ocamltest. *)
|
||||||
|
|
||||||
|
val has_symlink : unit -> bool
|
|
@ -0,0 +1,16 @@
|
||||||
|
(**************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* OCaml *)
|
||||||
|
(* *)
|
||||||
|
(* David Allsopp, OCaml Labs, Cambridge. *)
|
||||||
|
(* *)
|
||||||
|
(* Copyright 2020 David Allsopp Ltd. *)
|
||||||
|
(* *)
|
||||||
|
(* All rights reserved. This file is distributed under the terms of *)
|
||||||
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
||||||
|
(* special exception on linking described in the file LICENSE. *)
|
||||||
|
(* *)
|
||||||
|
(**************************************************************************)
|
||||||
|
|
||||||
|
(* Dummy implementations for when the Unix library isn't built *)
|
||||||
|
let has_symlink () = false
|
|
@ -0,0 +1,17 @@
|
||||||
|
(**************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* OCaml *)
|
||||||
|
(* *)
|
||||||
|
(* David Allsopp, OCaml Labs, Cambridge. *)
|
||||||
|
(* *)
|
||||||
|
(* Copyright 2020 David Allsopp Ltd. *)
|
||||||
|
(* *)
|
||||||
|
(* All rights reserved. This file is distributed under the terms of *)
|
||||||
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
||||||
|
(* special exception on linking described in the file LICENSE. *)
|
||||||
|
(* *)
|
||||||
|
(**************************************************************************)
|
||||||
|
|
||||||
|
(* It's tempting just to have include Unix, but the binary is then quite a bit
|
||||||
|
bigger. *)
|
||||||
|
let has_symlink = Unix.has_symlink
|
Loading…
Reference in New Issue