Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add Ocamltest_stdlib.Unix.has_symlink 

Replaces the duplicated C stub. Functions from Unix must be explictly
imported.
master
David Allsopp 2020-07-23 14:55:36 +01:00
parent f341db8dbe
commit 9bc33d945a
11 changed files with 97 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -118,6 +118,7 @@ _build
/ocamltest/ocamltest
/ocamltest/ocamltest.opt
/ocamltest/ocamltest_config.ml
/ocamltest/ocamltest_unix.ml
/ocamltest/tsl_lexer.ml
/ocamltest/tsl_parser.ml
/ocamltest/tsl_parser.mli

2
Makefile
View File

@ -867,7 +867,7 @@ ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex
$(MAKE) -C ocamldoc opt.opt
# OCamltest
ocamltest: ocamlc ocamlyacc ocamllex
ocamltest: ocamlc ocamlyacc ocamllex otherlibraries
$(MAKE) -C ocamltest all
ocamltest.opt: ocamlc.opt ocamlyacc ocamllex

10
ocamltest/.depend
View File

@ -346,12 +346,20 @@ ocamltest_config.cmx : \
ocamltest_config.cmi
ocamltest_config.cmi :
ocamltest_stdlib.cmo : \
ocamltest_unix.cmi \
ocamltest_config.cmi \
ocamltest_stdlib.cmi
ocamltest_stdlib.cmx : \
ocamltest_unix.cmx \
ocamltest_config.cmx \
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 : \
variables.cmi \
tests.cmi \

40
ocamltest/Makefile
View File

@ -33,8 +33,16 @@ else
endif
ifeq "$(filter $(UNIXLIB),$(OTHERLIBRARIES))" ""
ocamltest_unix := dummy
unix_name :=
unix_path :=
unix := None
unix_include :=
else
ocamltest_unix := real
unix_name := unix
unix_path := $(ROOTDIR)/otherlibs/$(UNIXLIB)
unix_include := -I $(unix_path) $(EMPTY)
ifeq "$(UNIX_OR_WIN32)" "win32"
unix := Some false
else
@ -97,8 +105,8 @@ endif
core := \
$(run_source) run_stubs.c \
ocamltest_stdlib_stubs.c \
ocamltest_config.mli ocamltest_config.ml.in \
ocamltest_unix.mli ocamltest_unix.ml \
ocamltest_stdlib.mli ocamltest_stdlib.ml \
run_command.mli run_command.ml \
filecompare.mli filecompare.ml \
@ -166,6 +174,7 @@ parsers := $(filter %.mly,$(sources))
config_files := $(filter %.ml.in,$(sources))
dependencies_generated_prereqs := \
ocamltest_unix.ml \
$(config_files:.ml.in=.ml) \
$(lexers:.mll=.ml) \
$(parsers:.mly=.mli) $(parsers:.mly=.ml)
@ -185,9 +194,9 @@ flags := -g -nostdlib $(include_directories) \
-strict-sequence -safe-string -strict-formats \
-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)
depflags := -slash
@ -210,26 +219,29 @@ opt.opt: allopt
compdeps_names=ocamlcommon ocamlbytecomp
compdeps_paths=$(addprefix $(ROOTDIR)/compilerlibs/,$(compdeps_names))
compdeps_byte=$(addsuffix .cma,$(compdeps_paths))
compdeps_opt=$(addsuffix .cmxa,$(compdeps_paths))
deps_paths=$(compdeps_paths) $(addprefix $(unix_path)/,$(unix_name))
deps_byte=$(addsuffix .cma,$(deps_paths))
deps_opt=$(addsuffix .cmxa,$(deps_paths))
$(eval $(call PROGRAM_SYNONYM,ocamltest))
ocamltest$(EXE): $(compdeps_byte) $(bytecode_modules)
$(ocamlc_cmd) -custom -o $@ $^
ocamltest_unix.%: flags+=$(unix_include) -opaque
%.cmo: %.ml $(compdeps_byte)
ocamltest$(EXE): $(deps_byte) $(bytecode_modules)
$(ocamlc_cmd) $(unix_include)-custom -o $@ $^
%.cmo: %.ml $(deps_byte)
$(ocamlc) -c $<
$(eval $(call PROGRAM_SYNONYM,ocamltest.opt))
ocamltest.opt$(EXE): $(compdeps_opt) $(native_modules)
$(ocamlopt_cmd) -o $@ $^
ocamltest.opt$(EXE): $(deps_opt) $(native_modules)
$(ocamlopt_cmd) $(unix_include)-o $@ $^
%.cmx: %.ml $(compdeps_opt)
%.cmx: %.ml $(deps_opt)
$(ocamlopt) -c $<
%.cmi: %.mli $(compdeps_byte)
%.cmi: %.mli $(deps_byte)
$(ocamlc) -c $<
%.ml %.mli: %.mly
@ -238,6 +250,10 @@ ocamltest.opt$(EXE): $(compdeps_opt) $(native_modules)
%.ml: %.mll
$(ocamllex) $(OCAMLLEX_FLAGS) $<
ocamltest_unix.ml: ocamltest_unix_$(ocamltest_unix).ml
echo '# 1 "$^"' > $@
cat $^ >> $@
ocamltest_config.ml: ocamltest_config.ml.in Makefile ../Makefile.config
sed $(call SUBST,AFL_INSTRUMENT) \
$(call SUBST,RUNTIMEI) \

2
ocamltest/builtin_actions.ml
View File

@ -195,7 +195,7 @@ let naked_pointers = make
let has_symlink = make
"has_symlink"
(Actions_helpers.pass_or_skip (Sys.has_symlink () )
(Actions_helpers.pass_or_skip (Unix.has_symlink () )
"symlinks available"
"symlinks not available")

4
ocamltest/ocamltest_stdlib.ml
View File

@ -15,6 +15,8 @@
(* A few extensions to OCaml's standard library *)
module Unix = Ocamltest_unix
(* Pervaisive *)
let input_line_opt ic =
@ -165,8 +167,6 @@ module Sys = struct
let force_remove file =
if file_exists file then remove file
external has_symlink : unit -> bool = "caml_has_symlink"
let with_chdir path f =
let oldcwd = Sys.getcwd () in
Sys.chdir path;

5
ocamltest/ocamltest_stdlib.mli
View File

@ -54,10 +54,13 @@ module Sys : sig
val copy_chan : in_channel -> out_channel -> unit
val copy_file : string -> string -> unit
val force_remove : string -> unit
val has_symlink : unit -> bool
val with_chdir : string -> (unit -> 'a) -> 'a
val getenv_with_default_value : string -> string -> string
val safe_getenv : string -> string
val with_input_file : ?bin:bool -> string -> (in_channel -> 'a) -> 'a
val with_output_file : ?bin:bool -> string -> (out_channel -> 'a) -> 'a
end
module Unix : sig
include module type of Ocamltest_unix
end

151
ocamltest/ocamltest_stdlib_stubs.c
View File

@ -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 */

18
ocamltest/ocamltest_unix.mli Normal file
View File

@ -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

16
ocamltest/ocamltest_unix_dummy.ml Normal file
View File

@ -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

17
ocamltest/ocamltest_unix_real.ml Normal file
View File

@ -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