├── .github └── workflows │ └── main.yml ├── .gitignore ├── .ocamlformat ├── .ocamlformat-ignore ├── CHANGES.txt ├── LICENSE.txt ├── Makefile ├── README.md ├── TODO ├── discover ├── discover.ml ├── discover.mli └── dune ├── dune-project ├── extunix.opam ├── ppx_have ├── dune └── ppx_have.ml ├── src ├── TODO │ └── ftruncate │ │ ├── ftruncate.ml │ │ └── ftruncateC.c ├── atfile.c ├── bigarray.c ├── common.c ├── common.h ├── dirfd.c ├── dune ├── endian.c ├── endian_helper.h ├── endianba.c ├── eventfd.c ├── execinfo.c ├── extUnix.mli ├── extUnix.pp.ml ├── fadvise.c ├── fallocate.c ├── fexecve.c ├── fsync.c ├── ioctl_siocgifconf.c ├── malloc.c ├── memalign.c ├── mktemp.c ├── mman.c ├── mount.c ├── poll.c ├── pread_pwrite_ba.c ├── ptrace.c ├── pts.c ├── read_cred.c ├── realpath.c ├── rename.c ├── resource.c ├── sendmsg.c ├── signalfd.c ├── sockopt.c ├── splice.c ├── statvfs.c ├── stdlib.c ├── sysconf.c ├── sysinfo.c ├── syslog.c ├── time.c ├── tty_ioctl.c ├── uname.c ├── unistd.c ├── unshare.c └── wait4.c └── test ├── dune ├── test.ml ├── test_user_namespace.ml └── testba.ml /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Builds, tests & co 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | permissions: read-all 8 | 9 | jobs: 10 | build: 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | os: 15 | - ubuntu-latest 16 | - macos-latest 17 | - windows-latest 18 | ocaml-compiler: 19 | - '5' 20 | include: 21 | - os: ubuntu-latest 22 | ocaml-compiler: '4.08' 23 | 24 | runs-on: ${{ matrix.os }} 25 | 26 | steps: 27 | - name: Checkout tree 28 | uses: actions/checkout@v4 29 | 30 | - name: Set-up OCaml 31 | uses: ocaml/setup-ocaml@v3 32 | with: 33 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 34 | 35 | - run: opam install . --deps-only --with-test 36 | 37 | - run: opam exec -- dune build 38 | 39 | - run: opam exec -- dune runtest 40 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | _opam 3 | .merlin 4 | *.install 5 | web/index.html 6 | *~ 7 | /userns_test/ 8 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = default 2 | version = 0.27.0 3 | -------------------------------------------------------------------------------- /.ocamlformat-ignore: -------------------------------------------------------------------------------- 1 | discover/** 2 | src/** 3 | test/** 4 | -------------------------------------------------------------------------------- /CHANGES.txt: -------------------------------------------------------------------------------- 1 | ## v0.4.4 - 11 Mar 2025 2 | * New bindings: 3 | * #58: support wait4 (Filipe Marques) 4 | * #60: Fix dirfd argument in unlinkat and newfd argument in renameat 5 | not being correctl propagated. 6 | (Antonin Décimo) 7 | * #59: Update to ppxlib 0.36.0 and depend on OCaml >= 4.08. 8 | (Antonin Décimo) 9 | 10 | ## v0.4.3 - 4 Dec 2024 11 | * Move macros accessing values outside of blocking sections 12 | * Use caml_stat_* functions instead of malloc/free for heap data 13 | * Support renameat2 14 | 15 | ## v0.4.2 - 10 Aug 2024 16 | * Add TIOCGWINSZ ioctl 17 | * Release runtime mutex in all functions in atfile.c 18 | * Fix splice bindings 19 | * Minor bug fixes 20 | 21 | ## v0.4.1 - 20 Jun 2022 22 | * Support OCaml 5 new Unix primitive names 23 | 24 | ## v0.4.0 - 04 Fev 2022 25 | * Remove top-level module names, modules should be accessed via 26 | ExtUnix top-level module. 27 | * Import realpath from OCaml 4.13 28 | * Support realpath on Windows 29 | 30 | ## v0.3.2 - 09 May 2021 31 | * Emulate statvfs on Windows 32 | * build: mark ppxlib as build-time dep, depend on OCaml >= 4.06 33 | 34 | ## v0.3.1 - 11 Apr 2021 35 | * temporarily keep backward compatibility wrt top-level module names 36 | 37 | ## v0.3.0 - 10 Apr 2021 38 | * build: switch to dune, dune-configurator and ppxlib 39 | * sockopt: handle missing options at runtime 40 | * Add IPv6 support to getifaddrs 41 | * better Windows support 42 | + Support Endian module on Windows 43 | + Enable asctime, strftime, tzname, timezone, timegm on Windows 44 | 45 | ## v0.2.0 - 8 Nov 2019 46 | * camlp4 dependency replaced with ppx 47 | * use available endian functions on Mac OS 48 | 49 | ## v0.1.7 - 27 Mar 2019 50 | * detect endian functions on more platforms 51 | * fix openlog 52 | * improve gettid on Mac OS 53 | 54 | ## v0.1.6 - 11 Mar 2018 55 | * OCaml 4.05 compatibility (O_KEEPEXEC) 56 | * sockopt: add BPF options 57 | * make tests less fragile 58 | * New bindings: 59 | * syslog 60 | 61 | ## v0.1.5 - 28 Jun 2017 62 | * build with -safe-string 63 | 64 | ## v0.1.4 - 11 Nov 2016 65 | + SO_REUSEPORT 66 | * fix sendmsg bug 67 | * fix build on mingw 68 | 69 | ## v0.1.3 - 24 Nov 2015 70 | * New bindings : 71 | * fchmodat 72 | * fchownat 73 | + ExtUnix.Config 74 | * fix sysconf detection wrt non-standard options 75 | 76 | ## v0.1.2 - 24 Jul 2015 77 | * New bindings : 78 | * sysinfo uptime 79 | * mtrace muntrace 80 | * mount umount2 81 | * unshare 82 | * chroot 83 | + U.Poll.is_inter inter 84 | * TCP_KEEPCNT TCP_KEEPIDLE TCP_KEEPINTLV are now detected one by one and 85 | can be available or not available independently. Extunix currently doesn't 86 | have a mechanism to expose only selected variants from a single type in 87 | module [Specific], hence one should use [have_sockopt] function to check 88 | for options presence at runtime. 89 | 90 | ## v0.1.1 - 18 May 2014 91 | * New bindings : 92 | * gettid 93 | * poll 94 | * OCaml 4.02 compatibility (install all .cmi) 95 | * sendmsg/sendfd : fix sending binary data 96 | 97 | ## v0.1.0 - 8 Oct 2013 98 | * statvfs: add f_flags - decoded f_flag field 99 | * New bindings : 100 | * sysconf 101 | * splice tee vmsplice 102 | * setsockopt_int getsockopt_int (TCP keepalive) 103 | * sync syncfs 104 | * timezone 105 | * OCaml 4.01 compatibility (Unix.open_flag) 106 | * relax restrictions on bigarray types 107 | 108 | ## v0.0.6 - 1 Apr 2013 109 | * New string and bigarray functions : 110 | * get_uint63 set_uint63 get_int63 set_int63 111 | * fstatat: flags parameter was omitted 112 | * New bindings : 113 | * readlinkat 114 | * getifaddrs 115 | 116 | ## v0.0.5 - 16 Jun 2012 117 | * src/discover.ml : 118 | * New option -q to suppress stderr 119 | * --disable-* options to exclude selected features from build 120 | * More precise test for `sendmsg` (bug #1162) 121 | * Fix FTBFS on kfreebsd-* (Debian patch) 122 | * Unit tests are disabled by default and oUnit is now an optional dependency, 123 | configure with --enable-tests to build tests 124 | * OCaml 4 compatibility (Unix.open_flag) 125 | * List email contacts (bug #1108) 126 | 127 | ## v0.0.4 - 19 May 2012 128 | * ExtUnix now depends on Bigarray and provides variants of 129 | some bindings operating on bigarray buffers (BA submodule) 130 | * New bindings : 131 | * timegm 132 | * malloc_stats 133 | * malloc_info 134 | * read_credentials 135 | * fexecve 136 | * sendmsg recvmsg 137 | * pread pwrite (+ LargeFile and BA variants) 138 | * read write (+ LargeFile and BA variants) 139 | * mkstemp mkostemp 140 | * setresuid setresgid 141 | * posix_memalign 142 | * New submodules: BigEndian LittleEndian HostEndian 143 | * New bindings 144 | * uint16_from_host uint16_to_host 145 | * int16_from_host int16_to_host 146 | * uint31_from_host uint31_to_host 147 | * int31_from_host int31_to_host 148 | * int32_from_host int32_to_host 149 | * int64_from_host int64_to_host 150 | * New string and bigarray functions 151 | * get_uint8 set_uint8 get_int8 set_int8 152 | * get_uint16 set_uint16 get_int16 set_int16 153 | * get_uint31 set_uint31 get_int31 set_int31 154 | * get_int32 set_int32 155 | * get_int64 set_int64 156 | 157 | ## v0.0.3 - 12 Jul 2011 158 | * Keep unlinkat interface compatible with Netsys 159 | * statvfs : return all fields, use POSIX names 160 | * realpath : fix segfault on non-glibc systems 161 | * New bindings : 162 | * backtrace 163 | * setenv unsetenv clearenv 164 | * linkat symlinkat 165 | * mkdtemp 166 | 167 | ## v0.0.2 - 26 Dec 2010 168 | * New bindings : 169 | * getrlimit setrlimit 170 | * getpriority setpriority 171 | * ptrace (minimal) 172 | * renameat mkdirat 173 | * mlockall munlockall 174 | * strftime strptime asctime 175 | * tzname 176 | * posix_openpt grantpt unlockpt ptsname (Niki Yoshiuchi) 177 | * getsid 178 | * ctermid 179 | * is_open_descr 180 | * tcgetpgrp tcsetpgrp 181 | * int_of_file_descr file_descr_of_int 182 | * sys_exit 183 | * Separate configure test for fsync and fdatasync 184 | * ExtUnix.All.have function to test for features at runtime 185 | * Skip tests of functions not available on the current platform 186 | 187 | ## v0.0.1 - 7 Nov 2010 188 | * First release, implemented bindings : 189 | * fsync fdatasync 190 | * eventfd signalfd 191 | * statvfs fstatvfs 192 | * dirfd openat unlinkat fstatat 193 | * uname 194 | * fadvise fallocate 195 | * ttyname setpgid getpgid setreuid setregid 196 | * realpath 197 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | build: 2 | dune build @install 3 | 4 | clean: 5 | dune clean 6 | 7 | doc: 8 | dune build @doc 9 | 10 | test: 11 | dune runtest 12 | 13 | VERSION=0.4.4 14 | NAME=ocaml-extunix-$(VERSION) 15 | 16 | release: 17 | git tag -a -m $(VERSION) v$(VERSION) 18 | git archive --prefix=$(NAME)/ v$(VERSION) | gzip > $(NAME).tar.gz 19 | gpg -a -b $(NAME).tar.gz -o $(NAME).tar.gz.asc 20 | 21 | dune-release: 22 | dune-release tag 23 | dune-release 24 | 25 | .PHONY: build clean doc release dune-release test 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ExtUnix OCaml library 2 | 3 | [![Build Status](https://github.com/ygrek/extunix/actions/workflows/main.yml/badge.svg?branch=master)](https://github.com/ygrek/extunix/actions/workflows/main.yml?branch=master) 4 | [![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https%3A%2F%2Focaml.ci.dev%2Fbadge%2Fygrek%2Fextunix%2Fmaster&logo=ocaml)](https://ocaml.ci.dev/github/ygrek/extunix) 5 | 6 | A collection of thin bindings to various low-level system API. 7 | 8 | Our motto: "Be to Unix, what extlib is to stdlib" 9 | 10 | * Implement thin C bindings that directly map to underlying system API. 11 | * Provide common consistent ocaml interface: naming convention, exceptions. 12 | * Simple to build - no extra dependencies. 13 | 14 | Homepage: 15 | 16 | ## Why? 17 | 18 | Most of the system API don't deserve fully fledged library. 19 | 20 | The ExtUnix project aims to collect these in one place. Read the 21 | "[ExtUnix integration requirements](#extunix-integration-requirements)" 22 | to know what kind of system API we can integrate. 23 | 24 | ## Installation 25 | 26 | Dependencies : 27 | 28 | * OCaml, Dune, ppxlib for build and installation 29 | * (optional) oUnit2 for tests, odoc for documentation 30 | 31 | Build and install: 32 | 33 | ``` shell 34 | make 35 | make install 36 | ``` 37 | 38 | Alternatively use the underlying Dune build system directly (plain ocaml, 39 | no sh and make needed): 40 | 41 | ``` shell 42 | dune build @install 43 | ``` 44 | Usage example: 45 | 46 | ``` console 47 | $ ocaml 48 | # #use "topfind";; 49 | # #require "extunix";; 50 | # module U = ExtUnix.Specific;; 51 | # U.ttyname Unix.stdout;; 52 | - : string = "/dev/pts/8" 53 | ``` 54 | 55 | Run unit tests: 56 | 57 | ``` sh 58 | make test 59 | ``` 60 | 61 | ## Guidelines 62 | 63 | For OCaml programming style, we follow Unix module: 64 | 65 | * Values and types should be named by the name of the underlying C function 66 | * Raise `Unix_error` on runtime errors 67 | * Uniformly raise `Not_available` exception for functions not available on the 68 | current platform 69 | * Be MT friendly by default - i.e. release runtime lock for blocking 70 | operations, (FIXME) optionally provide ST variants 71 | 72 | Portability: 73 | 74 | * No shell scripting for build and install (think windows :) ) 75 | * Write portable C code (use compiler options to catch compatibility issues), 76 | NB: msvc doesn't support C99. 77 | * Provide module (`ExtUnix.Specific`) exposing only functions available on the 78 | platform where library is built - i.e. guaranteed to not throw 79 | `Not_available` exception (experimental). 80 | 81 | Build infrastructure: 82 | 83 | * [`discover`][] is used to discover available functions during 84 | configure step. 85 | 86 | * Generated `config.h` describes "features" discovered - it is 87 | responsible for inclusion of system-specific headers - this ensures 88 | coherent result at configure and build steps. 89 | 90 | * Generated `config.ml` describes the same features for the ocaml 91 | syntax extension [`ppx_have`][], which preprocesses 92 | [`src/extUnix.pp.ml`][] and generates two modules: `ExtUnix.All` 93 | where bindings to missing functions are rewritten to raise exception 94 | and `ExtUnix.Specific` which drops bindings to missing functions. 95 | 96 | [`discover`]: discover/discover.ml 97 | [`ppx_have`]: ppx_have/ppx_have.ml 98 | [`src/extUnix.pp.ml`]: src/extUnix.pp.ml 99 | 100 | ## ExtUnix integration requirements 101 | 102 | We can integrate into ExtUnix: 103 | 104 | * Official POSIX calls not in Unix module. 105 | * Drafted POSIX calls which are at least present on two systems among: 106 | Linux, *BSD, MacOS X. 107 | * System specific calls, as long as they don't need additional library, 108 | that they are marked as such in the documentation and that we have an 109 | automatic configure system test for them. 110 | 111 | We should avoid system calls that are complex and would deserve a library on 112 | their own. For example, a family of more than 10 functions and datatypes should 113 | deserve its own library. If an external library already exists and works, like 114 | for inotify system call, we also won't consider it for integration. 115 | 116 | Regarding Win32 portability: 117 | If there is a sane default to create a portable equivalent of the function on 118 | Windows, we can consider it. And we will mark it as such in the documentation. 119 | 120 | ## Checklist for adding new bindings 121 | 122 | * Add the C code to [`src`][] (follow the code style of existing bindings) 123 | * Add the required checks to [`discover/discover.ml`][] 124 | * Add the name of the C bindings to [`src/dune`][] 125 | * Add the OCaml code to [`src/extUnix.pp.ml`][] guarded with `HAVE ... END` 126 | * Add some tests to [`test/test.ml`][] 127 | * Add note to [`CHANGES.txt`][] 128 | * Run `make` 129 | 130 | [`src`]: src 131 | [`discover/discover.ml`]: discover/discover.ml 132 | [`src/dune`]: src/dune 133 | [`test/test.ml`]: test/test.ml 134 | [`CHANGES.txt`]: CHANGES.txt 135 | 136 | ## Checklist for release 137 | 138 | * Review `git log` and update [`CHANGES.txt`][] 139 | * Increase VERSION in Makefile 140 | * Commit 141 | * `make release` 142 | 143 | ## Development 144 | 145 | Many people contribute to extunix. Please submit your patches and/or feature 146 | requests to the project bugtracker at . 147 | 148 | The current maintainer is reachable at . 149 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | TODO 2 | ==== 3 | 4 | * comments: mark "emulated" (windows) functions 5 | * unsetenv winapi? see http://old.nabble.com/-patch--(msvc)-use-more-modern-facilities-for-setenv()-unsetenv()-td15877005.html 6 | * investigate F_FULLFSYNC fcntl and fsync on Mac OS 7 | * nanosleep 8 | * fdtruncate win32 9 | * waitid 10 | 11 | DONE 12 | ==== 13 | 14 | * INRIA request for extended UNIX: 15 | http://caml.inria.fr/mantis/view.php?id=5063 16 | http://caml.inria.fr/mantis/view.php?id=2533 17 | http://caml.inria.fr/mantis/view.php?id=3851 18 | http://caml.inria.fr/mantis/view.php?id=480 19 | * mkdtemp (see Jane Street Core) 20 | * sysconf: get system configuration constants. In particular, PAGESIZE, 21 | _SC_PHYS_PAGES, _SC_AVPHYS_PAGES, _SC_NPROCESSORS_CONF, _SC_NPROCESSORS_ONLN 22 | (see Jane Street Core) 23 | * sysinfo (see Jane Street Core) 24 | -------------------------------------------------------------------------------- /discover/discover.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Discover features available on this platform. 3 | 4 | There are two stages: actual discover by means of trying to compile snippets of test code 5 | and generation of config file listing all the discovered features 6 | *) 7 | 8 | module C = Configurator.V1 9 | 10 | open Printf 11 | 12 | type arg = 13 | | I of string (* check header file (#include) available (promoted to config) *) 14 | | T of string (* check type available *) 15 | | DEFINE of string (* define symbol prior to including header files (promoted to config) *) 16 | | Z of string (* define symbol to zero if not defined after the includes (promoted to config) *) 17 | | IF of string * string * string 18 | (* let [(cond, symbol, value)], then if [cond] is met after the 19 | includes, define [symbol] to [value] (promoted to config) *) 20 | | S of string (* check symbol available (e.g. function name) *) 21 | | V of string (* check value available (e.g. enum member) *) 22 | | D of string (* check symbol defined *) 23 | | ND of string (* check symbol not defined *) 24 | | F of string * string (* check structure type available and specified field present in it *) 25 | | Ldlib of string (* ccomp_type *) * string (* library flag or name given to compilers when they 26 | are supposed to invoke the linker *) 27 | 28 | type test = 29 | | L of arg list 30 | | ANY of arg list list 31 | 32 | type t = 33 | | YES of { 34 | name : string; 35 | args : arg list; 36 | ldlibs : string list; 37 | (* list of flags to give to the linker. Required if functions 38 | looked for with this test aren't in the set of libraries 39 | linked by default. *) 40 | } 41 | | NO of string 42 | 43 | let verbose = ref 1 44 | let disabled = ref [] 45 | 46 | let print_define b s = bprintf b "#define %s\n" s 47 | let print_include b s = bprintf b "#include <%s>\n" s 48 | let print_zdefine b s = bprintf b "#ifndef %s\n#define %s 0\n#endif\n" s s 49 | let print_ifdefine b (condition,symbol,value) = bprintf b "#if %s\n#define %s (%s)\n#endif\n" condition symbol value 50 | let filter_map f l = List.rev (List.fold_left (fun acc x -> match f x with Some s -> s::acc | None -> acc) [] l) 51 | let get_defines = filter_map (function DEFINE s -> Some s | _ -> None) 52 | let get_zdefines = filter_map (function Z s -> Some s | _ -> None) 53 | let get_ifdefines = filter_map (function IF (c,s,v) -> Some (c,s,v) | _ -> None) 54 | let get_includes = filter_map (function I s -> Some s | _ -> None) 55 | let get_ldlibs ccomp_type = filter_map (function Ldlib (ct, lib) when ct = ccomp_type -> Some lib | _ -> None) 56 | 57 | let config_defines = [ 58 | "_POSIX_C_SOURCE 200809L"; 59 | "_XOPEN_SOURCE 700"; 60 | "_BSD_SOURCE"; 61 | "_DEFAULT_SOURCE"; 62 | "_DARWIN_C_SOURCE"; 63 | "_LARGEFILE64_SOURCE"; 64 | "WIN32_LEAN_AND_MEAN"; 65 | "_WIN32_WINNT 0x0602"; (* Windows 8 *) 66 | "CAML_NAME_SPACE"; 67 | "_GNU_SOURCE"; 68 | "UNICODE"; 69 | "_UNICODE"; 70 | ] 71 | 72 | let config_includes = [ 73 | "string.h"; 74 | "errno.h"; 75 | "assert.h"; 76 | "caml/memory.h"; 77 | "caml/fail.h"; 78 | "caml/unixsupport.h"; 79 | "caml/signals.h"; 80 | "caml/alloc.h"; 81 | "caml/callback.h"; 82 | "caml/custom.h"; 83 | "caml/bigarray.h"; 84 | "caml/version.h"; 85 | ] 86 | 87 | let build_code args = 88 | let b = Buffer.create 10 in 89 | let pr fmt = ksprintf (fun s -> Buffer.add_string b (s^"\n")) fmt in 90 | let fresh = let n = ref 0 in fun () -> incr n; !n in 91 | List.iter (print_define b) config_defines; 92 | List.iter (print_define b) (get_defines args); 93 | List.iter (print_include b) config_includes; 94 | List.iter (print_include b) (get_includes args); 95 | (* pr "#include "; (* size_t *)*) 96 | List.iter begin function 97 | | I _ | Ldlib _ -> () 98 | | T s -> pr "%s var_%d;" s (fresh ()) 99 | | DEFINE _ -> () 100 | | Z _ | IF _ -> () (* no test required *) 101 | | D s -> pr "#ifndef %s" s; pr "#error %s not defined" s; pr "#endif" 102 | | ND s -> pr "#ifdef %s" s; pr "#error %s defined" s; pr "#endif" 103 | | S s -> pr "size_t var_%d = (size_t)&%s;" (fresh ()) s 104 | | V s -> pr "int var_%d = (0 == %s);" (fresh ()) s 105 | | F (s,f) -> pr "size_t var_%d = (size_t)&((struct %s*)0)->%s;" (fresh ()) s f 106 | end args; 107 | pr "int main(void) { return 0; }"; 108 | Buffer.contents b 109 | 110 | let discover c (name,test) = 111 | print_string ("checking " ^ name ^ (String.make (20 - String.length name) '.')); 112 | let ccomp_type = C.ocaml_config_var_exn c "ccomp_type" in 113 | let rec loop args other = 114 | let code = build_code args in 115 | let ldlibs = get_ldlibs ccomp_type args in 116 | match C.c_test c ~link_flags:ldlibs code, other with 117 | | false, [] -> 118 | if !verbose >= 2 then prerr_endline code; 119 | print_endline "failed"; NO name 120 | | false, (x::xs) -> loop x xs 121 | | true, _ -> print_endline "ok"; YES {name; args; ldlibs} 122 | in 123 | match List.mem name !disabled with 124 | | true -> print_endline "disabled"; NO name 125 | | false -> 126 | match test with 127 | | L l -> loop l [] 128 | | ANY (x::xs) -> loop x xs 129 | | ANY [] -> assert false 130 | 131 | let show_c file result = 132 | let b = Buffer.create 10 in 133 | let pr fmt = ksprintf (fun s -> Buffer.add_string b (s^"\n")) fmt in 134 | pr ""; 135 | List.iter (print_define b) config_defines; 136 | List.iter begin function 137 | | NO _ -> (); 138 | | YES {name; args; _} -> 139 | match get_defines args with 140 | | [] -> () 141 | | l -> 142 | pr ""; 143 | pr "#if defined(EXTUNIX_WANT_%s)" name; 144 | List.iter (print_define b) l; 145 | pr "#endif"; 146 | end result; 147 | pr ""; 148 | List.iter (print_include b) config_includes; 149 | pr {|#if OCAML_VERSION < 50100 150 | #define caml_uerror uerror 151 | #define caml_unix_error unix_error 152 | #define win32_maperr caml_win32_maperr 153 | #endif 154 | |}; 155 | pr "#include \"common.h\""; 156 | List.iter begin function 157 | | NO name -> 158 | pr ""; 159 | pr "#undef EXTUNIX_HAVE_%s" name; 160 | | YES {name; args; _} -> 161 | pr ""; 162 | pr "#define EXTUNIX_HAVE_%s" name; 163 | match get_includes args, get_zdefines args, get_ifdefines args with 164 | | [],[],[] -> () 165 | | includes,zdefines,ifdefines -> 166 | pr "#if defined(EXTUNIX_WANT_%s)" name; 167 | List.iter (print_include b) includes; 168 | List.iter (print_zdefine b) zdefines; 169 | List.iter (print_ifdefine b) ifdefines; 170 | pr "#endif"; 171 | end result; 172 | pr ""; 173 | let ch = open_out file in 174 | Buffer.output_buffer ch b; 175 | close_out ch 176 | 177 | let show_ml file result = 178 | let ch = open_out file in 179 | let pr fmt = ksprintf (fun s -> output_string ch (s^"\n")) fmt in 180 | pr "(** @return whether feature is available *)"; 181 | pr "let feature = function"; 182 | List.iter (function 183 | | YES {name; _} -> pr "| %S -> Some true" name 184 | | NO name -> pr "| %S -> Some false" name) result; 185 | pr "| _ -> None"; 186 | pr ""; 187 | pr "(** @return whether feature is available *)"; 188 | pr "let have = function"; 189 | List.iter (function 190 | | YES {name; _} -> pr "| `%s -> true" name 191 | | NO name -> pr "| `%s -> false" name) result; 192 | close_out ch 193 | 194 | let show_c_flags_sexp file c = 195 | let cflags = 196 | match C.ocaml_config_var c "ccomp_type" with 197 | | Some "cc" -> ["-Wall"; "-Wextra"] 198 | | Some "msvc" -> ["-W2"] 199 | | _ -> [] 200 | in 201 | C.Flags.write_sexp file cflags 202 | 203 | let show_link_flags_sexp file result = 204 | let ch = open_out file in 205 | let pr fmt = ksprintf (fun s -> output_string ch s) fmt in 206 | pr "("; 207 | List.(fold_left (fun acc -> function 208 | | YES {ldlibs; _} when not (mem ldlibs acc) -> ldlibs :: acc 209 | | _ -> acc) 210 | [] 211 | result |> concat |> iter (fun ldlib -> pr "%s " ldlib)); 212 | pr ")\n"; 213 | close_out ch 214 | 215 | let main c config = 216 | let result = List.map (discover c) config in 217 | show_c "config.h" result; 218 | show_ml "config.ml" result; 219 | show_c_flags_sexp "c_flags.sexp" c; 220 | show_link_flags_sexp "link_flags.sexp" result 221 | 222 | let features = 223 | let fd_int = ND "Handle_val" in (* marker for bindings code assuming fd is represented as int *) 224 | let statvfs = 225 | [ 226 | I "sys/statvfs.h"; 227 | T "struct statvfs"; 228 | D "ST_RDONLY"; D "ST_NOSUID"; 229 | Z "ST_NODEV"; Z "ST_NOEXEC"; Z "ST_SYNCHRONOUS"; Z "ST_MANDLOCK"; Z "ST_WRITE"; 230 | Z "ST_APPEND"; Z "ST_IMMUTABLE"; Z "ST_NOATIME"; Z "ST_NODIRATIME"; Z "ST_RELATIME"; 231 | ] 232 | in 233 | [ 234 | "EVENTFD", L[ 235 | fd_int; 236 | I "sys/eventfd.h"; 237 | T "eventfd_t"; 238 | S "eventfd"; S "eventfd_read"; S "eventfd_write"; 239 | ]; 240 | "ATFILE", L[ 241 | fd_int; 242 | DEFINE "_ATFILE_SOURCE"; 243 | I "fcntl.h"; 244 | I "sys/types.h"; I "sys/stat.h"; 245 | I "unistd.h"; I "stdio.h"; 246 | D "S_IFREG"; 247 | S "fstatat"; S "openat"; S "unlinkat"; S "renameat"; S "mkdirat"; S "linkat"; S "symlinkat"; S "readlinkat"; S "fchownat"; S "fchmodat"; 248 | ]; 249 | "RENAMEAT2", L[ 250 | fd_int; 251 | I "fcntl.h"; I "stdio.h"; 252 | S "renameat2"; 253 | ]; 254 | "RENAME_WHITEOUT", L[ 255 | DEFINE "_GNU_SOURCE"; 256 | D "RENAME_WHITEOUT"; 257 | ]; 258 | "DIRFD", L[ 259 | fd_int; 260 | I "sys/types.h"; 261 | I "dirent.h"; 262 | S "dirfd"; 263 | ]; 264 | "STATVFS", ANY [ 265 | statvfs@[S"statvfs"]; 266 | [ DEFINE "CAML_INTERNALS"; I "windows.h"; S "GetDiskFreeSpace"; S "GetDiskFreeSpaceEx"; S "GetVolumeInformation"]; 267 | ]; 268 | "FSTATVFS", L ([fd_int]@statvfs@[S"fstatvfs"]); 269 | "SIOCGIFCONF", L[ 270 | fd_int; 271 | I "sys/ioctl.h"; 272 | I "net/if.h"; 273 | D "SIOCGIFCONF"; 274 | S "ioctl"; 275 | T "struct ifconf"; T "struct ifreq"; 276 | ]; 277 | "IFADDRS", L[ 278 | I "sys/types.h"; 279 | I "ifaddrs.h"; 280 | S "getifaddrs"; 281 | S "freeifaddrs"; 282 | T "struct ifaddrs"; 283 | ]; 284 | "INET_NTOA", ANY[ 285 | [ I "sys/socket.h"; I "netinet/in.h"; I "arpa/inet.h"; S "inet_ntoa"; ]; 286 | [ I "winsock2.h"; I "ws2tcpip.h"; S "inet_ntoa"; ]; 287 | ]; 288 | "INET_NTOP", ANY[ 289 | [ I "arpa/inet.h"; S "inet_ntop"; ]; 290 | [ I "winsock2.h"; I "ws2tcpip.h"; S "inet_ntop"; ]; 291 | ]; 292 | "UNAME", L[ 293 | I "sys/utsname.h"; 294 | T "struct utsname"; 295 | S "uname"; 296 | ]; 297 | "FADVISE", L[ 298 | fd_int; 299 | I "fcntl.h"; 300 | S "posix_fadvise"; S "posix_fadvise64"; 301 | D "POSIX_FADV_NORMAL"; 302 | ]; 303 | "FALLOCATE", ANY[ 304 | [I "fcntl.h"; S "posix_fallocate"; S "posix_fallocate64"; ]; 305 | [D "_WIN32"; S "GetFileSizeEx"; ]; 306 | ]; 307 | "TTY_IOCTL", L[ 308 | fd_int; 309 | I "termios.h"; I "sys/ioctl.h"; 310 | T "struct winsize"; 311 | S "ioctl"; S "tcsetattr"; S "tcgetattr"; 312 | D "CRTSCTS"; D "TCSANOW"; D "TIOCMGET"; D "TIOCMSET"; D "TIOCMBIC"; D "TIOCMBIS"; D "TIOCGWINSZ" 313 | ]; 314 | "TTYNAME", L[ fd_int; I "unistd.h"; S "ttyname"; ]; 315 | "CTERMID", L[ I "stdio.h"; S "ctermid"; V "L_ctermid"; ]; 316 | "GETTID", ANY[ 317 | [ D "_WIN32"; S "GetCurrentThreadId" ]; 318 | [ DEFINE "EXTUNIX_USE_THREADID"; I "pthread.h"; I "stdint.h"; S "pthread_threadid_np" ]; 319 | [ DEFINE "EXTUNIX_USE_THREAD_SELFID"; I "sys/syscall.h"; S "syscall"; V "SYS_thread_selfid"]; 320 | [ I "sys/syscall.h"; S "syscall"; V "SYS_gettid"; ]; 321 | ]; 322 | "PGID", L[ I "unistd.h"; S "getpgid"; S "setpgid"; S "getsid"; ]; 323 | "SETREUID", L[ I "sys/types.h"; I "unistd.h"; S "setreuid"; S "setregid" ]; 324 | "FSYNC", ANY[ 325 | [I "unistd.h"; S "fsync";]; 326 | [D "_WIN32"; S "FlushFileBuffers"; ]; 327 | ]; 328 | "FDATASYNC", ANY[ 329 | [I "unistd.h"; S "fdatasync";]; 330 | [D "_WIN32"; S "FlushFileBuffers"; ]; 331 | ]; 332 | "SYNC", L[ I "unistd.h"; S "sync"]; 333 | "SYNCFS", ANY[ 334 | [fd_int;I "unistd.h"; S "syncfs"]; 335 | [fd_int;DEFINE "EXTUNIX_USE_SYS_SYNCFS"; I "unistd.h"; I "sys/syscall.h"; S"syscall"; V"SYS_syncfs"]; 336 | ]; 337 | "REALPATH", ANY[ 338 | [I "limits.h"; I "stdlib.h"; S "realpath"]; 339 | [D "_WIN32"; DEFINE "CAML_INTERNALS"] 340 | ]; 341 | "SIGNALFD", L[ fd_int; I "sys/signalfd.h"; S "signalfd"; I "signal.h"; S "sigemptyset"; S "sigaddset"; ]; 342 | "PTRACE", L[ I "sys/ptrace.h"; S "ptrace"; V "PTRACE_TRACEME"; V "PTRACE_ATTACH"; ]; 343 | "RESOURCE", L[ 344 | I "sys/time.h"; I "sys/resource.h"; 345 | S "getpriority"; S "setpriority"; S "getrlimit"; S "setrlimit"; 346 | V "PRIO_PROCESS"; V "RLIMIT_NOFILE"; V "RLIM_INFINITY"; 347 | ]; 348 | "MLOCKALL", L[ I "sys/mman.h"; S "mlockall"; S "munlockall"; V "MCL_CURRENT"; V "MCL_FUTURE"; ]; 349 | "STRPTIME", L[ I "time.h"; S "strptime"; ]; 350 | "STRTIME", ANY[ 351 | [ I "time.h"; S"strftime"; S"asctime_r"; S"tzset"; S"tzname"; ]; 352 | [ DEFINE"CAML_INTERNALS"; I"caml/osdeps.h"; I "time.h"; Ldlib ("cc", "-lucrtbase"); 353 | S"wcsftime"; S"_wasctime_s"; S"_tzset"; S"_get_tzname"; ]; 354 | ]; 355 | "TIMEZONE", ANY[ 356 | [ I "time.h"; S"tzset"; S"timezone"; S"daylight" ]; 357 | [ I "time.h"; Ldlib ("cc", "-lucrtbase"); S"_tzset"; S"_get_timezone"; S"_get_daylight" ]; 358 | ]; 359 | "TIMEGM", ANY[ 360 | [ I "time.h"; S"timegm"; ]; 361 | [ I "time.h"; Ldlib ("cc", "-lucrtbase"); S"_mkgmtime" ]; 362 | ]; 363 | "PTS", L[ 364 | fd_int; 365 | I "fcntl.h"; I "stdlib.h"; 366 | S "posix_openpt"; S "grantpt"; S "unlockpt"; S "ptsname"; 367 | ]; 368 | "FCNTL", L[ fd_int; I"unistd.h"; I"fcntl.h"; S"fcntl"; V"F_GETFL"; ]; 369 | "TCPGRP", L[ fd_int; I"unistd.h"; S"tcgetpgrp"; S"tcsetpgrp"; ]; 370 | "EXECINFO", ANY[ 371 | [ I"execinfo.h"; S"backtrace"; S"backtrace_symbols"; ]; 372 | [ I"execinfo.h"; S"backtrace"; S"backtrace_symbols"; Ldlib ("cc", "-lexecinfo")]; 373 | ]; 374 | "SETENV", L[ I"stdlib.h"; S"setenv"; S"unsetenv"; ]; 375 | "CLEARENV", L[ I"stdlib.h"; S"clearenv"; ]; 376 | "MKDTEMP", L[ I"stdlib.h"; I"unistd.h"; S"mkdtemp"; ]; 377 | "MALLOC_INFO", L[ I"malloc.h"; S"malloc_info"; ]; 378 | "MALLOC_STATS", L[ I"malloc.h"; S"malloc_stats"; ]; 379 | "MEMALIGN", L[ I "stdlib.h"; S"posix_memalign"; ]; 380 | "ENDIAN", ANY[ 381 | [ 382 | I"endian.h"; 383 | D"htobe16"; D"htole16"; D"be16toh"; D"le16toh"; 384 | D"htobe32"; D"htole32"; D"be32toh"; D"le32toh"; 385 | D"htobe64"; D"htole64"; D"be64toh"; D"le64toh"; 386 | ]; 387 | [ 388 | I"sys/endian.h"; 389 | D"htobe16"; D"htole16"; 390 | D"htobe32"; D"htole32"; 391 | D"htobe64"; D"htole64"; 392 | ]; 393 | [ 394 | DEFINE "EXTUNIX_USE_OSBYTEORDER_H"; 395 | I"libkern/OSByteOrder.h"; 396 | D"OSSwapHostToBigInt32"; 397 | ]; 398 | [ 399 | DEFINE "EXTUNIX_USE_WINSOCK2_H"; 400 | I"winsock2.h"; 401 | S"htons"; S"ntohs"; 402 | S"htonl"; S"ntohl"; 403 | (* S"htonll"; S"ntohll"; 2020-01-06: not supported by mingw-w64 yet *) 404 | ] 405 | ]; 406 | "READ_CREDENTIALS", L[ fd_int; I"sys/types.h"; I"sys/socket.h"; D"SO_PEERCRED"; ]; 407 | "FEXECVE", L[ fd_int; I "unistd.h"; S"fexecve"; ]; 408 | "SENDMSG", ANY[ 409 | [ fd_int; I"sys/types.h"; I"sys/socket.h"; S"sendmsg"; S"recvmsg"; D"CMSG_SPACE"; ]; 410 | [ fd_int; I"sys/types.h"; I"sys/socket.h"; S"sendmsg"; S"recvmsg"; F("msghdr","msg_accrights"); ]; 411 | ]; 412 | "PREAD", L[ fd_int; I "unistd.h"; S"pread"; ]; 413 | "PWRITE", L[ fd_int; I "unistd.h"; S"pwrite"; ]; 414 | "READ", L[ fd_int; I "unistd.h"; S"read"; ]; 415 | "WRITE", L[ fd_int; I "unistd.h"; S"write"; ]; 416 | "MKSTEMPS", L[ fd_int; I "stdlib.h"; I "unistd.h"; S"mkstemps"; ]; 417 | "MKOSTEMPS", L[ fd_int; I "stdlib.h"; I "unistd.h"; S"mkostemps"; ]; 418 | "SETRESUID", L[ I"sys/types.h"; I"unistd.h"; S"setresuid"; S"setresgid" ]; 419 | "SYSCONF", L[ 420 | I "unistd.h"; 421 | S "sysconf"; 422 | (* check for standard values and extensions *) 423 | D "_SC_VERSION"; D "_SC_2_VERSION"; 424 | ]; 425 | "SPLICE", L[ fd_int; I "fcntl.h"; S"splice"; ]; 426 | "TEE", L[ fd_int; I "fcntl.h"; S"tee"; ]; 427 | "VMSPLICE", L[ fd_int; I "fcntl.h"; S"vmsplice"; ]; 428 | "SOCKOPT", ANY[ 429 | [ 430 | fd_int; 431 | I "sys/socket.h"; I "netinet/in.h"; I"netinet/tcp.h"; 432 | S"setsockopt"; S"getsockopt"; 433 | ]; 434 | [ 435 | I "winsock2.h"; I "ws2tcpip.h"; 436 | S"setsockopt"; S"getsockopt"; 437 | ] 438 | ]; 439 | "TCP_KEEPIDLE", ANY[ 440 | [ I "netinet/in.h"; I "netinet/tcp.h"; V "TCP_KEEPIDLE" ]; 441 | [ I "winsock2.h"; I "ws2tcpip.h"; IF ("!defined(TCP_KEEPIDLE) && defined(__MINGW32__)", "TCP_KEEPIDLE", "0x03") ]; 442 | [ D "__APPLE__"; I "netinet/in.h"; I "netinet/tcp.h"; V "TCP_KEEPALIVE" ]; 443 | ]; 444 | "TCP_KEEPCNT", ANY[ 445 | [ I "netinet/in.h"; I "netinet/tcp.h"; V "TCP_KEEPCNT" ]; 446 | [ I "winsock2.h"; I "ws2tcpip.h"; IF ("!defined(TCP_KEEPCNT) && defined(__MINGW32__)", "TCP_KEEPCNT", "0x10") ]; 447 | ]; 448 | "TCP_KEEPINTVL", ANY[ 449 | [ I "netinet/in.h"; I "netinet/tcp.h"; V "TCP_KEEPINTVL" ]; 450 | [ I "winsock2.h"; I "ws2tcpip.h"; IF ("!defined(TCP_KEEPINTVL) && defined(__MINGW32__)", "TCP_KEEPINTVL", "0x11") ]; 451 | ]; 452 | "SO_REUSEPORT", L[I"sys/socket.h"; V"SO_REUSEPORT"]; 453 | "POLL", L[ fd_int; I "poll.h"; S "poll"; D "POLLIN"; D "POLLOUT"; Z "POLLRDHUP" ]; 454 | "SYSINFO", L[ I"sys/sysinfo.h"; S"sysinfo"; F ("sysinfo","mem_unit")]; 455 | "MCHECK", L[ I"mcheck.h"; S"mtrace"; S"muntrace" ]; 456 | "MOUNT", L[ I"sys/mount.h"; S "mount"; S "umount2"; D "MS_REC" ]; 457 | "UNSHARE", L[ I"sched.h"; S "unshare"; D "CLONE_NEWPID"; D "CLONE_NEWUSER"]; 458 | "CHROOT", L[ I"unistd.h"; S "chroot"; ]; 459 | "SYSLOG", L[I"syslog.h"; S "syslog"; S "openlog"; S "closelog"; S "setlogmask"; D "LOG_PID"; D "LOG_CONS"; D "LOG_NDELAY"; D "LOG_ODELAY"; D "LOG_NOWAIT"; D "LOG_EMERG"; D "LOG_ALERT"; D "LOG_CRIT"; D "LOG_ERR"; D "LOG_WARNING"; D "LOG_NOTICE"; D "LOG_INFO"; D "LOG_DEBUG"]; 460 | "WAIT4", L[ 461 | I "sys/resource.h"; I "sys/time.h"; I "sys/types.h"; I "sys/wait.h"; 462 | DEFINE "CAML_INTERNALS"; S "wait4" 463 | ]; 464 | ] 465 | 466 | let () = 467 | let args0 = [ 468 | "-v", Arg.Unit (fun () -> verbose := 2), " Show code for failed tests"; 469 | "-q", Arg.Unit (fun () -> verbose := 0), " Do not show stderr from children"; 470 | ] in 471 | let args1 = List.map (fun (name,_) -> 472 | assert (not (String.contains name ' ')); 473 | "--disable-" ^ String.lowercase_ascii name, 474 | Arg.Unit (fun () -> disabled := name :: !disabled), 475 | " disable " ^ name) features 476 | in 477 | let args = Arg.align (args0 @ args1) in 478 | C.main ~args:args ~name:"extunix" (fun c -> main c features) 479 | -------------------------------------------------------------------------------- /discover/discover.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ygrek/extunix/e90bd03bbcdf84ccba6b749f727d487f4161aff8/discover/discover.mli -------------------------------------------------------------------------------- /discover/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name discover) 3 | (libraries dune.configurator)) 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) 2 | (name extunix) 3 | (generate_opam_files true) 4 | 5 | (package 6 | (name extunix) 7 | (depends 8 | (ocaml (>= 4.08)) 9 | (dune-configurator (and (>= 3.0) :build)) 10 | (ppxlib (and (>= 0.36.0) :build)) 11 | (ounit2 :with-test) 12 | base-bytes 13 | base-bigarray 14 | base-unix 15 | ) 16 | (synopsis "Collection of thin bindings to various low-level system API") 17 | (description 18 | "\| Motto: "Be to Unix, what extlib is to stdlib" 19 | "\| 20 | "\| * Implement thin C bindings that directly map to underlying system API. 21 | "\| * Provide common consistent ocaml interface: naming convention, exceptions. 22 | "\| * Simple to build - no extra dependencies. 23 | ) 24 | (license "LGPL-2.1-only WITH OCaml-LGPL-linking-exception") 25 | (authors 26 | "Andre Nathan" 27 | "Antonin Décimo" 28 | "Dmitry Grebeniuk" 29 | "François Bobot" 30 | "Gerd Stolpmann" 31 | "Goswin von Brederlow" 32 | "Joshua Smith" 33 | "Kaustuv Chaudhuri" 34 | "Markus W. Weissmann" 35 | "Mehdi Dogguy" 36 | "Niki Yoshiuchi" 37 | "Pierre Chambart" 38 | "Roman Vorobets" 39 | "Stéphane Glondu" 40 | "Sylvain Le Gall" 41 | "Teague Hansen" 42 | "ygrek" 43 | "Zhenya Lykhovyd" 44 | ) 45 | (maintainers "ygrek@autistici.org" "Antonin Décimo ") 46 | (source (github ygrek/extunix)) 47 | (tags ("org:ygrek"))) 48 | -------------------------------------------------------------------------------- /extunix.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Collection of thin bindings to various low-level system API" 4 | description: """ 5 | Motto: "Be to Unix, what extlib is to stdlib" 6 | 7 | * Implement thin C bindings that directly map to underlying system API. 8 | * Provide common consistent ocaml interface: naming convention, exceptions. 9 | * Simple to build - no extra dependencies. 10 | """ 11 | maintainer: ["ygrek@autistici.org" "Antonin Décimo "] 12 | authors: [ 13 | "Andre Nathan" 14 | "Antonin Décimo" 15 | "Dmitry Grebeniuk" 16 | "François Bobot" 17 | "Gerd Stolpmann" 18 | "Goswin von Brederlow" 19 | "Joshua Smith" 20 | "Kaustuv Chaudhuri" 21 | "Markus W. Weissmann" 22 | "Mehdi Dogguy" 23 | "Niki Yoshiuchi" 24 | "Pierre Chambart" 25 | "Roman Vorobets" 26 | "Stéphane Glondu" 27 | "Sylvain Le Gall" 28 | "Teague Hansen" 29 | "ygrek" 30 | "Zhenya Lykhovyd" 31 | ] 32 | license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" 33 | tags: ["org:ygrek"] 34 | homepage: "https://github.com/ygrek/extunix" 35 | bug-reports: "https://github.com/ygrek/extunix/issues" 36 | depends: [ 37 | "dune" {>= "3.0"} 38 | "ocaml" {>= "4.08"} 39 | "dune-configurator" {>= "3.0" & build} 40 | "ppxlib" {>= "0.36.0" & build} 41 | "ounit2" {with-test} 42 | "base-bytes" 43 | "base-bigarray" 44 | "base-unix" 45 | "odoc" {with-doc} 46 | ] 47 | build: [ 48 | ["dune" "subst"] {dev} 49 | [ 50 | "dune" 51 | "build" 52 | "-p" 53 | name 54 | "-j" 55 | jobs 56 | "@install" 57 | "@runtest" {with-test} 58 | "@doc" {with-doc} 59 | ] 60 | ] 61 | dev-repo: "git+https://github.com/ygrek/extunix.git" 62 | -------------------------------------------------------------------------------- /ppx_have/dune: -------------------------------------------------------------------------------- 1 | (copy_files ../src/config.ml) 2 | 3 | (library 4 | (name ppx_have) 5 | (modules Ppx_have Config) 6 | (kind ppx_rewriter) 7 | (libraries ppxlib) 8 | (preprocess 9 | (pps ppxlib.metaquot))) 10 | -------------------------------------------------------------------------------- /ppx_have/ppx_have.ml: -------------------------------------------------------------------------------- 1 | let all = ref false 2 | let funcs = Hashtbl.create 16 3 | 4 | let args_spec = 5 | [ 6 | ("--gen-all", Arg.Set all, "generate values from all [%%have ...] sections"); 7 | ] 8 | 9 | module ExtUnixConfig = Config 10 | open Ppxlib 11 | 12 | let check ~loc name = 13 | match ExtUnixConfig.feature name with 14 | | None -> Location.raise_errorf ~loc "Unregistered feature %s" name 15 | | Some have -> have 16 | 17 | let ident x = Ocaml_common.Location.mknoloc (lident x) 18 | 19 | (* Evaluating conditions *) 20 | 21 | let atom_of_expr ~loc expr = 22 | match expr.pexp_desc with 23 | | Pexp_construct ({ txt = Longident.Lident x; _ }, None) -> x 24 | | _ -> Location.raise_errorf ~loc "have: atom_of_expr" 25 | 26 | let conj_of_expr ~loc expr = 27 | match expr.pexp_desc with 28 | | Pexp_construct _ -> [ atom_of_expr ~loc expr ] 29 | | Pexp_tuple args -> List.map (atom_of_expr ~loc) args 30 | | _ -> Location.raise_errorf ~loc "have: conj_of_expr" 31 | 32 | let disj_of_expr ~loc expr = 33 | match expr.pexp_desc with 34 | | Pexp_construct _ -> [ [ atom_of_expr ~loc expr ] ] 35 | | Pexp_tuple args -> List.map (conj_of_expr ~loc) args 36 | | _ -> Location.raise_errorf ~loc "have: disj_of_expr" 37 | 38 | let eval_cond ~loc cond = 39 | match cond.pstr_desc with 40 | | Pstr_eval (expr, _attributes) -> 41 | List.exists (List.for_all (check ~loc)) (disj_of_expr ~loc expr) 42 | | _ -> Location.raise_errorf ~loc "have: eval_cond" 43 | 44 | (* have rule *) 45 | 46 | let invalid_external ~loc = 47 | let open Ast_builder.Default in 48 | let rec make_dummy_f ~loc body typ = 49 | match typ.ptyp_desc with 50 | | Ptyp_arrow (l, arg, ret) -> 51 | let arg = 52 | match l with Optional _ -> [%type: [%t arg] option] | _ -> arg 53 | in 54 | let e = make_dummy_f ~loc body ret in 55 | pexp_fun ~loc l None [%pat? (_ : [%t arg])] e 56 | | _ -> [%expr ([%e body] : [%t typ])] 57 | in 58 | let raise_not_available ~loc x = 59 | let e = pexp_constant ~loc (Pconst_string (x, loc, None)) in 60 | [%expr raise (Not_available [%e e])] 61 | in 62 | let externals_of = 63 | object 64 | inherit Ast_traverse.map as super 65 | 66 | method! structure_item x = 67 | match x.pstr_desc with 68 | | Pstr_primitive p -> 69 | let body = raise_not_available ~loc p.pval_name.txt in 70 | let expr = make_dummy_f ~loc body p.pval_type in 71 | let pat = ppat_var ~loc p.pval_name in 72 | let vb = value_binding ~loc ~pat ~expr in 73 | let vb = 74 | { vb with pvb_attributes = p.pval_attributes @ vb.pvb_attributes } 75 | in 76 | pstr_value ~loc Nonrecursive [ vb ] 77 | | _ -> super#structure_item x 78 | end 79 | in 80 | externals_of#structure_item 81 | 82 | let record_external have = 83 | let externals_of = 84 | object 85 | inherit Ast_traverse.iter as super 86 | 87 | method! structure_item x = 88 | match x.pstr_desc with 89 | | Pstr_primitive p -> Hashtbl.replace funcs p.pval_name.txt have 90 | | _ -> super#structure_item x 91 | end 92 | in 93 | externals_of#structure_item 94 | 95 | let have_constr ~loc = 96 | let have_constr = 97 | object 98 | inherit Ast_traverse.map as super 99 | 100 | method! constructor_declaration x = 101 | match super#constructor_declaration x with 102 | | { 103 | pcd_attributes = 104 | [ 105 | { 106 | attr_name = { txt = "have"; _ }; 107 | attr_payload = PStr (cond :: _); 108 | _; 109 | }; 110 | ]; 111 | _; 112 | } as x -> 113 | if eval_cond ~loc cond then x 114 | else 115 | { 116 | x with 117 | pcd_name = 118 | { x.pcd_name with txt = x.pcd_name.txt ^ "__Not_available" }; 119 | } 120 | | x -> x 121 | end 122 | in 123 | have_constr#structure_item 124 | 125 | let have_expand ~ctxt cond items = 126 | let loc = Expansion_context.Extension.extension_point_loc ctxt in 127 | let have = eval_cond ~loc cond in 128 | List.iter (record_external have) items; 129 | match (have, !all) with 130 | | true, true -> items 131 | | true, false -> List.map (have_constr ~loc) items 132 | | false, true -> List.map (invalid_external ~loc) items 133 | | false, false -> [] 134 | 135 | let have_extension = 136 | Extension.V3.declare_inline "have" Extension.Context.structure_item 137 | Ast_pattern.(pstr (__ ^:: __)) 138 | have_expand 139 | 140 | let have_rule = Context_free.Rule.extension have_extension 141 | 142 | (* show_me_the_money rule *) 143 | 144 | let show_me_the_money_expand ~ctxt doc = 145 | let loc = Expansion_context.Extension.extension_point_loc ctxt in 146 | let open Ast_builder.Default in 147 | let make_have () = 148 | Hashtbl.fold 149 | (fun func have acc -> 150 | let lhs = ppat_constant ~loc (Pconst_string (func, loc, None)) in 151 | let e = pexp_construct ~loc (ident (string_of_bool have)) None in 152 | case ~lhs ~guard:None ~rhs:[%expr Some [%e e]] :: acc) 153 | funcs 154 | [ case ~lhs:[%pat? _] ~guard:None ~rhs:[%expr None] ] 155 | in 156 | if !all then 157 | let expr = pexp_function_cases ~loc (make_have ()) in 158 | let pat = ppat_var ~loc (Ocaml_common.Location.mknoloc "have") in 159 | let vb = value_binding ~loc ~pat ~expr in 160 | let vb = { vb with pvb_attributes = doc :: vb.pvb_attributes } in 161 | [ pstr_value ~loc Nonrecursive [ vb ] ] 162 | else [] 163 | 164 | let show_me_the_money_extension = 165 | Extension.V3.declare_inline "show_me_the_money" 166 | Extension.Context.structure_item 167 | Ast_pattern.(pstr (pstr_attribute __ ^:: nil)) 168 | show_me_the_money_expand 169 | 170 | let show_me_the_money_rule = 171 | Context_free.Rule.extension show_me_the_money_extension 172 | 173 | let () = 174 | List.iter (fun (key, spec, doc) -> Driver.add_arg key spec ~doc) args_spec; 175 | let rules = [ have_rule; show_me_the_money_rule ] in 176 | Driver.register_transformation ~rules "ppx_have" 177 | -------------------------------------------------------------------------------- /src/TODO/ftruncate/ftruncate.ml: -------------------------------------------------------------------------------- 1 | (** Truncate file 2 | @author Sylvain Le Gall 3 | *) 4 | 5 | (**/**) 6 | 7 | external win32_ftruncate: Unix.file_descr -> int -> unit = 8 | "caml_ftruncate_win32" 9 | ;; 10 | (**/**) 11 | 12 | let ftruncate = 13 | if Sys.win32 then 14 | win32_ftruncate 15 | else 16 | Unix.ftruncate 17 | ;; 18 | 19 | module LargeFile = 20 | struct 21 | (**/**) 22 | external win32_ftruncate: Unix.file_descr -> int64 -> unit = 23 | "caml_ftruncate64_win32" 24 | (**/**) 25 | 26 | let ftruncate = 27 | if Sys.win32 then 28 | win32_ftruncate 29 | else 30 | Unix.LargeFile.ftruncate 31 | end;; 32 | -------------------------------------------------------------------------------- /src/TODO/ftruncate/ftruncateC.c: -------------------------------------------------------------------------------- 1 | 2 | /* 3 | * ftruncate C binding 4 | * 5 | * Copyright 2008-2009 Talend, Inc. 6 | * 7 | * License LGPL-2.1 with OCaml linking static exception 8 | * 9 | * For more information go to: www.talend.com 10 | * 11 | * author: Sylvain Le Gall 12 | * 13 | */ 14 | 15 | #include 16 | #include 17 | #include 18 | 19 | #ifdef WINDOWS 20 | 21 | static void caml_ftruncate_win32_error (void) 22 | { 23 | caml_win32_maperr(GetLastError()); 24 | caml_uerror("ftruncate", Val_unit); 25 | }; 26 | 27 | static __int64 caml_ftruncate_win32_lseek (HANDLE hFile, __int64 i64Pos, DWORD dwMoveMethod) 28 | { 29 | LARGE_INTEGER liRes; 30 | 31 | liRes.QuadPart = i64Pos; 32 | liRes.LowPart = SetFilePointer(hFile, liRes.LowPart, &liRes.HighPart, dwMoveMethod); 33 | if (liRes.LowPart == INVALID_SET_FILE_POINTER && 34 | GetLastError() != NO_ERROR) 35 | { 36 | caml_ftruncate_win32_error(); 37 | }; 38 | 39 | return liRes.QuadPart; 40 | }; 41 | 42 | static void caml_ftruncate_win32_do (HANDLE hFile, __int64 i64Len) 43 | { 44 | __int64 i64Cur = 0; 45 | 46 | /* Save actual file offset */ 47 | i64Cur = caml_ftruncate_win32_lseek(hFile, 0, FILE_CURRENT); 48 | 49 | /* Goto expected end */ 50 | caml_ftruncate_win32_lseek(hFile, i64Len, FILE_BEGIN); 51 | 52 | /* Set end */ 53 | if (!SetEndOfFile(hFile)) 54 | { 55 | caml_ftruncate_win32_error(); 56 | }; 57 | 58 | /* Restore file offset */ 59 | caml_ftruncate_win32_lseek(hFile, i64Cur, FILE_BEGIN); 60 | }; 61 | 62 | CAMLprim value caml_ftruncate_win32 (value vfd, value vlen) 63 | { 64 | CAMLparam2(vfd, vlen); 65 | caml_ftruncate_win32_do(Handle_val(vfd), Long_val(vlen)); 66 | CAMLreturn(Val_unit); 67 | } 68 | 69 | CAMLprim value caml_ftruncate64_win32 (value vfd, value vlen) 70 | { 71 | CAMLparam2(vfd, vlen); 72 | caml_ftruncate_win32_do(Handle_val(vfd), Int64_val(vlen)); 73 | CAMLreturn(Val_unit); 74 | } 75 | 76 | #else 77 | 78 | CAMLprim value caml_ftruncate_win32 (value vfd, value vlen) 79 | { 80 | CAMLparam2(vfd, vlen); 81 | caml_failwith("Not implemented"); 82 | CAMLreturn(Val_unit); 83 | } 84 | 85 | CAMLprim value caml_ftruncate64_win32 (value vfd, value vlen) 86 | { 87 | CAMLparam2(vfd, vlen); 88 | caml_failwith("Not implemented"); 89 | CAMLreturn(Val_unit); 90 | } 91 | 92 | #endif 93 | -------------------------------------------------------------------------------- /src/atfile.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_ATFILE 2 | #include "config.h" 3 | 4 | #if defined(EXTUNIX_HAVE_ATFILE) 5 | 6 | /* otherlibs/unix/cst2constr.h */ 7 | #if OCAML_VERSION_MAJOR >= 5 8 | # if OCAML_VERSION_MAJOR >= 2 9 | extern value caml_unix_cst_to_constr(int n, const int * tbl, int size, int deflt); 10 | # else 11 | extern value caml_unix_cst_to_constr(int n, int * tbl, int size, int deflt); 12 | # endif 13 | #else 14 | extern value cst_to_constr(int n, int * tbl, int size, int deflt); 15 | #define caml_unix_cst_to_constr cst_to_constr 16 | #endif 17 | 18 | static const int file_kind_table[] = { 19 | S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, S_IFLNK, S_IFIFO, S_IFSOCK 20 | }; 21 | 22 | #ifndef AT_EACCESS 23 | #define AT_EACCESS 0 24 | #endif 25 | 26 | #ifndef AT_SYMLINK_NOFOLLOW 27 | #define AT_SYMLINK_NOFOLLOW 0 28 | #endif 29 | 30 | #ifndef AT_SYMLINK_FOLLOW 31 | #define AT_SYMLINK_FOLLOW 0 32 | #endif 33 | 34 | #ifndef AT_NO_AUTOMOUNT 35 | #define AT_NO_AUTOMOUNT 0 36 | #endif 37 | 38 | static const int at_flags_table[] = { 39 | AT_EACCESS, AT_SYMLINK_NOFOLLOW, AT_REMOVEDIR, AT_SYMLINK_FOLLOW, AT_NO_AUTOMOUNT, 40 | }; 41 | 42 | static value stat_aux(/*int use_64,*/ struct stat *buf) 43 | { 44 | CAMLparam0(); 45 | CAMLlocal5(atime, mtime, ctime, offset, v); 46 | 47 | atime = caml_copy_double((double) buf->st_atime); 48 | mtime = caml_copy_double((double) buf->st_mtime); 49 | ctime = caml_copy_double((double) buf->st_ctime); 50 | offset = /*use_64 ? Val_file_offset(buf->st_size) :*/ Val_int (buf->st_size); 51 | v = caml_alloc_small(12, 0); 52 | Field (v, 0) = Val_int (buf->st_dev); 53 | Field (v, 1) = Val_int (buf->st_ino); 54 | Field (v, 2) = 55 | caml_unix_cst_to_constr(buf->st_mode & S_IFMT, file_kind_table, 56 | sizeof(file_kind_table) / sizeof(int), 0); 57 | Field (v, 3) = Val_int (buf->st_mode & 07777); 58 | Field (v, 4) = Val_int (buf->st_nlink); 59 | Field (v, 5) = Val_int (buf->st_uid); 60 | Field (v, 6) = Val_int (buf->st_gid); 61 | Field (v, 7) = Val_int (buf->st_rdev); 62 | Field (v, 8) = offset; 63 | Field (v, 9) = atime; 64 | Field (v, 10) = mtime; 65 | Field (v, 11) = ctime; 66 | CAMLreturn(v); 67 | } 68 | 69 | CAMLprim value caml_extunix_fstatat(value v_dirfd, value v_name, value v_flags) 70 | { 71 | CAMLparam3(v_dirfd, v_name, v_flags); 72 | int ret; 73 | int dirfd = Int_val(v_dirfd); 74 | struct stat buf; 75 | char* p = caml_stat_strdup(String_val(v_name)); 76 | int flags = caml_convert_flag_list(v_flags, at_flags_table); 77 | flags &= (AT_SYMLINK_NOFOLLOW | AT_NO_AUTOMOUNT); /* only allowed flags here */ 78 | 79 | caml_enter_blocking_section(); 80 | ret = fstatat(dirfd, p, &buf, flags); 81 | caml_leave_blocking_section(); 82 | caml_stat_free(p); 83 | if (ret != 0) caml_uerror("fstatat", v_name); 84 | if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG) 85 | caml_unix_error(EOVERFLOW, "fstatat", v_name); 86 | CAMLreturn(stat_aux(/*0,*/ &buf)); 87 | } 88 | 89 | CAMLprim value caml_extunix_unlinkat(value v_dirfd, value v_name, value v_flags) 90 | { 91 | CAMLparam3(v_dirfd, v_name, v_flags); 92 | int dirfd = Int_val(v_dirfd); 93 | char* p = caml_stat_strdup(String_val(v_name)); 94 | int ret = 0; 95 | int flags = caml_convert_flag_list(v_flags, at_flags_table); 96 | flags &= AT_REMOVEDIR; /* only allowed flag here */ 97 | 98 | caml_enter_blocking_section(); 99 | ret = unlinkat(dirfd, p, flags); 100 | caml_leave_blocking_section(); 101 | caml_stat_free(p); 102 | if (ret != 0) caml_uerror("unlinkat", v_name); 103 | CAMLreturn(Val_unit); 104 | } 105 | 106 | CAMLprim value caml_extunix_renameat(value v_oldfd, value v_oldname, value v_newfd, value v_newname) 107 | { 108 | CAMLparam4(v_oldfd, v_oldname, v_newfd, v_newname); 109 | int oldfd = Int_val(v_oldfd), newfd = Int_val(v_newfd); 110 | char *oldname = caml_stat_strdup(String_val(v_oldname)), 111 | *newname = caml_stat_strdup(String_val(v_newname)); 112 | caml_enter_blocking_section(); 113 | int ret = renameat(oldfd, oldname, newfd, newname); 114 | caml_leave_blocking_section(); 115 | caml_stat_free(newname); 116 | caml_stat_free(oldname); 117 | if (ret != 0) caml_uerror("renameat", v_oldname); 118 | CAMLreturn(Val_unit); 119 | } 120 | 121 | CAMLprim value caml_extunix_mkdirat(value v_dirfd, value v_name, value v_mode) 122 | { 123 | CAMLparam3(v_dirfd, v_name, v_mode); 124 | int dirfd = Int_val(v_dirfd), mode = Int_val(v_mode); 125 | char *name = caml_stat_strdup(String_val(v_name)); 126 | caml_enter_blocking_section(); 127 | int ret = mkdirat(dirfd, name, mode); 128 | caml_leave_blocking_section(); 129 | caml_stat_free(name); 130 | if (ret != 0) caml_uerror("mkdirat", v_name); 131 | CAMLreturn(Val_unit); 132 | } 133 | 134 | CAMLprim value caml_extunix_linkat(value v_olddirfd, value v_oldname, value v_newdirfd, value v_newname, value v_flags) 135 | { 136 | CAMLparam5(v_olddirfd, v_oldname, v_newdirfd, v_newname, v_flags); 137 | int olddirfd = Int_val(v_olddirfd), newdirfd = Int_val(v_newdirfd); 138 | char *oldname = caml_stat_strdup(String_val(v_oldname)), 139 | *newname = caml_stat_strdup(String_val(v_newname)); 140 | int ret = 0; 141 | int flags = caml_convert_flag_list(v_flags, at_flags_table); 142 | flags &= AT_SYMLINK_FOLLOW; /* only allowed flag here */ 143 | caml_enter_blocking_section(); 144 | ret = linkat(olddirfd, oldname, newdirfd, newname, flags); 145 | caml_leave_blocking_section(); 146 | caml_stat_free(newname); 147 | caml_stat_free(oldname); 148 | if (ret != 0) caml_uerror("linkat", v_oldname); 149 | CAMLreturn(Val_unit); 150 | } 151 | 152 | CAMLprim value caml_extunix_fchownat(value v_dirfd, value v_name, value v_owner, value v_group, value v_flags) 153 | { 154 | CAMLparam5(v_dirfd, v_name, v_owner, v_group, v_flags); 155 | int dirfd = Int_val(v_dirfd), owner = Int_val(v_owner), group = Int_val(v_group); 156 | char *name = caml_stat_strdup(String_val(v_name)); 157 | int ret = 0; 158 | int flags = caml_convert_flag_list(v_flags, at_flags_table); 159 | flags &= (AT_SYMLINK_NOFOLLOW /* | AT_EMPTY_PATH */); /* only allowed flag here */ 160 | caml_enter_blocking_section(); 161 | ret = fchownat(dirfd, name, owner, group, flags); 162 | caml_leave_blocking_section(); 163 | caml_stat_free(name); 164 | if (ret != 0) caml_uerror("fchownat", v_name); 165 | CAMLreturn(Val_unit); 166 | } 167 | 168 | CAMLprim value caml_extunix_fchmodat(value v_dirfd, value v_name, value v_mode, value v_flags) 169 | { 170 | CAMLparam4(v_dirfd, v_name, v_mode, v_flags); 171 | int dirfd = Int_val(v_dirfd), mode = Int_val(v_mode); 172 | char *name = caml_stat_strdup(String_val(v_name)); 173 | int ret = 0; 174 | int flags = caml_convert_flag_list(v_flags, at_flags_table); 175 | flags &= AT_SYMLINK_NOFOLLOW; /* only allowed flag here */ 176 | caml_enter_blocking_section(); 177 | ret = fchmodat(dirfd, name, mode, flags); 178 | caml_leave_blocking_section(); 179 | caml_stat_free(name); 180 | if (ret != 0) caml_uerror("fchmodat", v_name); 181 | CAMLreturn(Val_unit); 182 | } 183 | 184 | CAMLprim value caml_extunix_symlinkat(value v_path, value v_newdirfd, value v_newname) 185 | { 186 | CAMLparam3(v_path, v_newdirfd, v_newname); 187 | char *path = caml_stat_strdup(String_val(v_path)), 188 | *newname = caml_stat_strdup(String_val(v_newname)); 189 | int newdirfd = Int_val(v_newdirfd); 190 | caml_enter_blocking_section(); 191 | int ret = symlinkat(path, newdirfd, newname); 192 | caml_leave_blocking_section(); 193 | caml_stat_free(newname); 194 | caml_stat_free(path); 195 | if (ret != 0) caml_uerror("symlinkat", v_path); 196 | CAMLreturn(Val_unit); 197 | } 198 | 199 | CAMLprim value caml_extunix_openat(value v_dirfd, value v_path, value flags, value v_perm) 200 | { 201 | CAMLparam4(v_dirfd, v_path, flags, v_perm); 202 | int dirfd = Int_val(v_dirfd), perm = Int_val(v_perm); 203 | int ret, cv_flags; 204 | char *path = caml_stat_strdup(String_val(v_path));; 205 | 206 | cv_flags = extunix_open_flags(flags); 207 | /* open on a named FIFO can block (PR#1533) */ 208 | caml_enter_blocking_section(); 209 | ret = openat(dirfd, path, cv_flags, perm); 210 | caml_leave_blocking_section(); 211 | caml_stat_free(path); 212 | if (ret == -1) caml_uerror("openat", v_path); 213 | CAMLreturn (Val_int(ret)); 214 | } 215 | 216 | char *readlinkat_malloc (int dirfd, const char *filename) 217 | { 218 | int size = 100; 219 | int nchars; 220 | char *buffer = NULL; 221 | char *tmp; 222 | 223 | while (1) 224 | { 225 | tmp = caml_stat_resize_noexc (buffer, size); 226 | if (tmp == NULL) 227 | { 228 | caml_stat_free (buffer); /* if failed, dealloc is not performed */ 229 | return NULL; 230 | } 231 | buffer = tmp; 232 | nchars = readlinkat (dirfd, filename, buffer, size); 233 | if (nchars < 0) 234 | { 235 | caml_stat_free (buffer); 236 | return NULL; 237 | } 238 | if (nchars < size) 239 | { 240 | buffer[nchars] = '\0'; 241 | return buffer; 242 | } 243 | size *= 2; 244 | } 245 | } 246 | 247 | CAMLprim value caml_extunix_readlinkat(value v_dirfd, value v_name) 248 | { 249 | CAMLparam2(v_dirfd, v_name); 250 | CAMLlocal1(v_link); 251 | int dirfd = Int_val(v_dirfd); 252 | char* res; 253 | char* name = caml_stat_strdup(String_val(v_name)); 254 | 255 | caml_enter_blocking_section(); 256 | res = readlinkat_malloc(dirfd, name); 257 | caml_leave_blocking_section(); 258 | caml_stat_free(name); 259 | if (res == NULL) caml_uerror("readlinkat", v_name); 260 | v_link = caml_copy_string(res); 261 | caml_stat_free(res); 262 | CAMLreturn(v_link); 263 | } 264 | 265 | #endif 266 | -------------------------------------------------------------------------------- /src/bigarray.c: -------------------------------------------------------------------------------- 1 | #include "config.h" 2 | 3 | /* Copyright © 2012 Goswin von Brederlow */ 4 | 5 | CAMLprim value caml_extunixba_get_substr(value v_buf, value v_off, value v_len) 6 | { 7 | CAMLparam3(v_buf, v_off, v_len); 8 | CAMLlocal1(v_str); 9 | char *buf = (char*)Caml_ba_data_val(v_buf); 10 | size_t off = Long_val(v_off); 11 | size_t len = Long_val(v_len); 12 | v_str = caml_alloc_initialized_string(len, buf + off); 13 | CAMLreturn(v_str); 14 | } 15 | 16 | CAMLprim value caml_extunixba_set_substr(value v_buf, value v_off, value v_str) 17 | { 18 | CAMLparam3(v_buf, v_off, v_str); 19 | char *buf = (char*)Caml_ba_data_val(v_buf); 20 | size_t off = Long_val(v_off); 21 | size_t len = caml_string_length(v_str); 22 | const char *str = String_val(v_str); 23 | memcpy(buf + off, str, len); 24 | CAMLreturn(Val_unit); 25 | } 26 | -------------------------------------------------------------------------------- /src/common.c: -------------------------------------------------------------------------------- 1 | #include "config.h" 2 | #include 3 | 4 | /* otherlibs/unix/open.c */ 5 | 6 | #ifndef O_NONBLOCK 7 | #ifndef O_NDELAY 8 | #define O_NDELAY 0 9 | #endif 10 | #define O_NONBLOCK O_NDELAY 11 | #endif 12 | #ifndef O_NOCTTY 13 | #define O_NOCTTY 0 14 | #endif 15 | #ifndef O_DSYNC 16 | #define O_DSYNC 0 17 | #endif 18 | #ifndef O_SYNC 19 | #define O_SYNC 0 20 | #endif 21 | #ifndef O_RSYNC 22 | #define O_RSYNC 0 23 | #endif 24 | #ifndef O_CLOEXEC 25 | #define O_CLOEXEC 0 26 | #endif 27 | #ifndef O_KEEPEXEC 28 | #define O_KEEPEXEC 0 29 | #endif 30 | 31 | static const int open_flag_table[] = { 32 | O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, 33 | O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC, 0 /* O_SHARE_DELETE */, O_CLOEXEC, O_KEEPEXEC, 34 | }; 35 | 36 | int extunix_open_flags(value list) 37 | { 38 | int res; 39 | int flag; 40 | res = 0; 41 | while (list != Val_int(0)) 42 | { 43 | flag = Int_val(Field(list, 0)); 44 | if (flag >= 0 && (size_t)flag < sizeof(open_flag_table)/sizeof(open_flag_table[0])) /* new flags - ignore */ 45 | res |= open_flag_table[flag]; 46 | list = Field(list, 1); 47 | } 48 | return res; 49 | } 50 | -------------------------------------------------------------------------------- /src/common.h: -------------------------------------------------------------------------------- 1 | #define UNUSED(x) (void)(x) 2 | 3 | #include 4 | 5 | #if OCAML_VERSION < 41200 6 | #define Val_none Val_int(0) 7 | #define Some_val(v) Field(v, 0) 8 | #define Tag_some 0 9 | #define Is_none(v) ((v) == Val_none) 10 | #define Is_some(v) Is_block(v) 11 | #endif 12 | 13 | int extunix_open_flags(value); 14 | -------------------------------------------------------------------------------- /src/dirfd.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_DIRFD 3 | #include "config.h" 4 | 5 | #if defined(EXTUNIX_HAVE_DIRFD) 6 | 7 | CAMLprim value caml_extunix_dirfd(value v_dir) 8 | { 9 | CAMLparam1(v_dir); 10 | int fd = -1; 11 | DIR* dir = DIR_Val(v_dir); 12 | if (dir == (DIR *) NULL) caml_unix_error(EBADF, "dirfd", Nothing); 13 | fd = dirfd(dir); 14 | if (fd < 0) caml_uerror("dirfd", Nothing); 15 | CAMLreturn(Val_int(fd)); 16 | } 17 | 18 | #endif 19 | 20 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets config.h config.ml c_flags.sexp link_flags.sexp) 3 | (deps 4 | (:gen ../discover/discover.exe)) 5 | (action 6 | (run %{gen}))) 7 | 8 | (rule 9 | (action 10 | (progn 11 | (copy extUnix.pp.ml all.ml) 12 | (copy extUnix.pp.ml specific.ml)))) 13 | 14 | (library 15 | (name ExtUnix) 16 | (public_name extunix) 17 | (modules_without_implementation ExtUnix) 18 | (libraries unix bigarray bytes) 19 | (preprocess 20 | (per_module 21 | ((pps ppx_have --gen-all) 22 | All) 23 | ((pps ppx_have) 24 | Specific))) 25 | (c_library_flags 26 | :standard 27 | (:include link_flags.sexp)) 28 | (foreign_stubs 29 | (language c) 30 | (flags 31 | :standard 32 | (:include c_flags.sexp)) 33 | (names 34 | atfile 35 | bigarray 36 | common 37 | dirfd 38 | endian 39 | endianba 40 | execinfo 41 | fadvise 42 | fallocate 43 | fexecve 44 | fsync 45 | ioctl_siocgifconf 46 | malloc 47 | memalign 48 | mktemp 49 | mman 50 | mount 51 | poll 52 | pread_pwrite_ba 53 | ptrace 54 | pts 55 | read_cred 56 | realpath 57 | rename 58 | resource 59 | sendmsg 60 | signalfd 61 | sockopt 62 | splice 63 | statvfs 64 | stdlib 65 | sysconf 66 | sysinfo 67 | syslog 68 | time 69 | tty_ioctl 70 | uname 71 | unistd 72 | unshare 73 | wait4 74 | eventfd))) 75 | -------------------------------------------------------------------------------- /src/endian.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_ENDIAN 2 | #include "config.h" 3 | #include "endian_helper.h" 4 | 5 | #include 6 | 7 | /* Copyright © 2012 Goswin von Brederlow */ 8 | 9 | /* Convert an intX_t from one endianness to another */ 10 | #define CONV(name, type, conv, type_val, val_type) \ 11 | CAMLprim value caml_extunix_##name(value v_x) \ 12 | { \ 13 | type x = type_val(v_x); \ 14 | x = conv(x); \ 15 | return (val_type(x)); \ 16 | } 17 | 18 | /* Get an intX_t out of a string */ 19 | #define GET(name, type, conv, Val_type) \ 20 | CAMLprim value caml_extunix_get_##name(value v_str, value v_off) { \ 21 | const char *str = String_val(v_str); \ 22 | size_t off = Long_val(v_off); \ 23 | type x; \ 24 | memcpy(&x, str + off, sizeof(x)); \ 25 | x = conv(x); \ 26 | return (Val_type(x)); \ 27 | } 28 | 29 | /* Store an intX_t in a string */ 30 | #define SET(name, type, conv, Type_val) \ 31 | CAMLprim value caml_extunix_set_##name(value v_str, value v_off, value v_x) { \ 32 | unsigned char *str = Bytes_val(v_str); \ 33 | size_t off = Long_val(v_off); \ 34 | type x = Type_val(v_x); \ 35 | x = conv(x); \ 36 | memcpy(str + off, &x, sizeof(x)); \ 37 | return Val_unit; \ 38 | } 39 | 40 | #if defined(EXTUNIX_HAVE_ENDIAN) 41 | 42 | /* Big endian */ 43 | CONV(htobe16, uint16_t, htobe16, Long_val, Val_long) 44 | CONV(htobe16_signed, int16_t, htobe16, Long_val, Val_long) 45 | CONV(be16toh, uint16_t, be16toh, Long_val, Val_long) 46 | CONV(be16toh_signed, int16_t, be16toh, Long_val, Val_long) 47 | CONV(htobe31, uint32_t, htobe32, Long_val, Val_long) 48 | CONV(htobe31_signed, int32_t, htobe32, Long_val, Val_long) 49 | CONV(be31toh, uint32_t, be32toh, Long_val, Val_long) 50 | CONV(be31toh_signed, int32_t, be32toh, Long_val, Val_long) 51 | CONV(htobe32, int32_t, htobe32, Int32_val, caml_copy_int32) 52 | CONV(be32toh, int32_t, be32toh, Int32_val, caml_copy_int32) 53 | CONV(htobe64, int64_t, htobe64, Int64_val, caml_copy_int64) 54 | CONV(be64toh, int64_t, be64toh, Int64_val, caml_copy_int64) 55 | 56 | GET(bu16, uint16_t, be16toh, Val_long) 57 | GET(bs16, int16_t, be16toh, Val_long) 58 | GET(bu31, uint32_t, be32toh, Val_long) 59 | GET(bs31, int32_t, be32toh, Val_long) 60 | GET(bs32, int32_t, be32toh, caml_copy_int32) 61 | GET(bu63, uint64_t, be64toh, Val_long) 62 | GET(bs63, int64_t, be64toh, Val_long) 63 | GET(bs64, int64_t, be64toh, caml_copy_int64) 64 | 65 | SET(b16, uint16_t, htobe16, Long_val) 66 | SET(b31, uint32_t, htobe32, Long_val) 67 | SET(b32, uint32_t, htobe32, Int32_val) 68 | SET(b63, uint64_t, htobe64, Long_val) 69 | SET(b64, uint64_t, htobe64, Int64_val) 70 | 71 | /* Little endian */ 72 | CONV(htole16, uint16_t, htole16, Long_val, Val_long) 73 | CONV(htole16_signed, int16_t, htole16, Long_val, Val_long) 74 | CONV(le16toh, uint16_t, le16toh, Long_val, Val_long) 75 | CONV(le16toh_signed, int16_t, le16toh, Long_val, Val_long) 76 | CONV(htole31, uint32_t, htole32, Long_val, Val_long) 77 | CONV(htole31_signed, int32_t, htole32, Long_val, Val_long) 78 | CONV(le31toh, uint32_t, le32toh, Long_val, Val_long) 79 | CONV(le31toh_signed, int32_t, le32toh, Long_val, Val_long) 80 | CONV(htole32, int32_t, htole32, Int32_val, caml_copy_int32) 81 | CONV(le32toh, int32_t, le32toh, Int32_val, caml_copy_int32) 82 | CONV(htole64, int64_t, htole64, Int64_val, caml_copy_int64) 83 | CONV(le64toh, int64_t, le64toh, Int64_val, caml_copy_int64) 84 | 85 | GET(lu16, uint16_t, le16toh, Val_long) 86 | GET(ls16, int16_t, le16toh, Val_long) 87 | GET(lu31, uint32_t, le32toh, Val_long) 88 | GET(ls31, int32_t, le32toh, Val_long) 89 | GET(ls32, int32_t, le32toh, caml_copy_int32) 90 | GET(lu63, uint64_t, le64toh, Val_long) 91 | GET(ls63, int64_t, le64toh, Val_long) 92 | GET(ls64, int64_t, le64toh, caml_copy_int64) 93 | 94 | SET(l16, uint16_t, htole16, Long_val) 95 | SET(l31, uint32_t, htole32, Long_val) 96 | SET(l32, uint32_t, htole32, Int32_val) 97 | SET(l63, uint64_t, htole64, Long_val) 98 | SET(l64, uint64_t, htole64, Int64_val) 99 | 100 | #endif /* EXTUNIX_HAVE_ENDIAN */ 101 | 102 | /* Host endian */ 103 | #define id(x) x 104 | GET(u8, uint8_t, id, Val_long) 105 | GET(s8, int8_t, id, Val_long) 106 | GET(hu16, uint16_t, id, Val_long) 107 | GET(hs16, int16_t, id, Val_long) 108 | GET(hu31, uint32_t, id, Val_long) 109 | GET(hs31, int32_t, id, Val_long) 110 | GET(hs32, int32_t, id, caml_copy_int32) 111 | GET(hu63, uint64_t, id, Val_long) 112 | GET(hs63, int64_t, id, Val_long) 113 | GET(hs64, int64_t, id, caml_copy_int64) 114 | 115 | SET(8, uint8_t, id, Long_val) 116 | SET(h16, uint16_t, id, Long_val) 117 | SET(h31, uint32_t, id, Long_val) 118 | SET(h32, uint32_t, id, Int32_val) 119 | SET(h63, uint64_t, id, Long_val) 120 | SET(h64, uint64_t, id, Int64_val) 121 | -------------------------------------------------------------------------------- /src/endian_helper.h: -------------------------------------------------------------------------------- 1 | /* 2 | From https://gist.github.com/panzi/6856583 3 | // "License": Public Domain 4 | // I, Mathias Panzenböck, place this file hereby into the public domain. Use it at your own risk for whatever you like. 5 | // In case there are jurisdictions that don't support putting things in the public domain you can also consider it to 6 | // be "dual licensed" under the BSD, MIT and Apache licenses, if you want to. This code is trivial anyway. Consider it 7 | // an example on how to get the endian conversion functions on different platforms. 8 | */ 9 | 10 | /* Mac OS */ 11 | 12 | #if defined(EXTUNIX_USE_OSBYTEORDER_H) 13 | 14 | # define htobe16(x) OSSwapHostToBigInt16(x) 15 | # define htole16(x) OSSwapHostToLittleInt16(x) 16 | # define be16toh(x) OSSwapBigToHostInt16(x) 17 | # define le16toh(x) OSSwapLittleToHostInt16(x) 18 | 19 | # define htobe32(x) OSSwapHostToBigInt32(x) 20 | # define htole32(x) OSSwapHostToLittleInt32(x) 21 | # define be32toh(x) OSSwapBigToHostInt32(x) 22 | # define le32toh(x) OSSwapLittleToHostInt32(x) 23 | 24 | # define htobe64(x) OSSwapHostToBigInt64(x) 25 | # define htole64(x) OSSwapHostToLittleInt64(x) 26 | # define be64toh(x) OSSwapBigToHostInt64(x) 27 | # define le64toh(x) OSSwapLittleToHostInt64(x) 28 | 29 | #endif 30 | 31 | /* Windows */ 32 | 33 | #if defined(EXTUNIX_USE_WINSOCK2_H) 34 | 35 | # if BYTE_ORDER == LITTLE_ENDIAN 36 | 37 | # define htobe16(x) htons(x) 38 | # define htole16(x) (x) 39 | # define be16toh(x) ntohs(x) 40 | # define le16toh(x) (x) 41 | 42 | # define htobe32(x) htonl(x) 43 | # define htole32(x) (x) 44 | # define be32toh(x) ntohl(x) 45 | # define le32toh(x) (x) 46 | 47 | # if defined(__MINGW32__) 48 | # define htobe64(x) __builtin_bswap64(x) 49 | # define be64toh(x) __builtin_bswap64(x) 50 | # else 51 | # define htobe64(x) htonll(x) 52 | # define be64toh(x) ntohll(x) 53 | # endif 54 | # define htole64(x) (x) 55 | # define le64toh(x) (x) 56 | 57 | # elif BYTE_ORDER == BIG_ENDIAN 58 | 59 | /* that would be xbox 360 */ 60 | # define htobe16(x) (x) 61 | # define htole16(x) __builtin_bswap16(x) 62 | # define be16toh(x) (x) 63 | # define le16toh(x) __builtin_bswap16(x) 64 | 65 | # define htobe32(x) (x) 66 | # define htole32(x) __builtin_bswap32(x) 67 | # define be32toh(x) (x) 68 | # define le32toh(x) __builtin_bswap32(x) 69 | 70 | # define htobe64(x) (x) 71 | # define htole64(x) __builtin_bswap64(x) 72 | # define be64toh(x) (x) 73 | # define le64toh(x) __builtin_bswap64(x) 74 | 75 | # else 76 | 77 | # error byte order not supported 78 | 79 | # endif 80 | 81 | #endif 82 | 83 | /* various BSD */ 84 | 85 | #ifndef be16toh 86 | # define be16toh(x) betoh16(x) 87 | #endif 88 | 89 | #ifndef le16toh 90 | # define le16toh(x) letoh16(x) 91 | #endif 92 | 93 | #ifndef be32toh 94 | # define be32toh(x) betoh32(x) 95 | #endif 96 | 97 | #ifndef le32toh 98 | # define le32toh(x) letoh32(x) 99 | #endif 100 | 101 | #ifndef be64toh 102 | # define be64toh(x) betoh64(x) 103 | #endif 104 | 105 | #ifndef le64toh 106 | # define le64toh(x) letoh64(x) 107 | #endif 108 | -------------------------------------------------------------------------------- /src/endianba.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_ENDIAN 2 | #include "config.h" 3 | #include "endian_helper.h" 4 | 5 | #include 6 | 7 | /* Copyright © 2012 Goswin von Brederlow */ 8 | 9 | /* Get intX_t out of a buffer */ 10 | #define GET(name, type, conv, Val_type) \ 11 | CAMLprim value caml_extunixba_get_##name(value v_buf, value v_off) { \ 12 | int8_t *buf = (int8_t*)Caml_ba_data_val(v_buf); \ 13 | size_t off = Long_val(v_off); \ 14 | type x; \ 15 | memcpy(&x, buf + off, sizeof(x)); \ 16 | x = conv(x); \ 17 | return (Val_type(x)); \ 18 | } 19 | 20 | /* Store intX_t in a buffer */ 21 | #define SET(name, type, conv, Type_val) \ 22 | CAMLprim value caml_extunixba_set_##name(value v_buf, value v_off, value v_x) { \ 23 | int8_t *buf = (int8_t*)Caml_ba_data_val(v_buf); \ 24 | size_t off = Long_val(v_off); \ 25 | type x = Type_val(v_x); \ 26 | x = conv(x); \ 27 | memcpy(buf + off, &x, sizeof(x)); \ 28 | return Val_unit; \ 29 | } 30 | 31 | #if defined(EXTUNIX_HAVE_ENDIAN) 32 | 33 | /* Big endian */ 34 | GET(bu16, uint16_t, be16toh, Val_long) 35 | GET(bs16, int16_t, be16toh, Val_long) 36 | GET(bu31, uint32_t, be32toh, Val_long) 37 | GET(bs31, int32_t, be32toh, Val_long) 38 | GET(bs32, int32_t, be32toh, caml_copy_int32) 39 | GET(bu63, uint64_t, be64toh, Val_long) 40 | GET(bs63, int64_t, be64toh, Val_long) 41 | GET(bs64, int64_t, be64toh, caml_copy_int64) 42 | 43 | SET(b16, uint16_t, htobe16, Long_val) 44 | SET(b31, uint32_t, htobe32, Long_val) 45 | SET(b32, uint32_t, htobe32, Int32_val) 46 | SET(b63, uint64_t, htobe64, Long_val) 47 | SET(b64, uint64_t, htobe64, Int64_val) 48 | 49 | /* Little endian */ 50 | GET(lu16, uint16_t, le16toh, Val_long) 51 | GET(ls16, int16_t, le16toh, Val_long) 52 | GET(lu31, uint32_t, le32toh, Val_long) 53 | GET(ls31, int32_t, le32toh, Val_long) 54 | GET(ls32, int32_t, le32toh, caml_copy_int32) 55 | GET(lu63, uint64_t, le64toh, Val_long) 56 | GET(ls63, int64_t, le64toh, Val_long) 57 | GET(ls64, int64_t, le64toh, caml_copy_int64) 58 | 59 | SET(l16, uint16_t, htole16, Long_val) 60 | SET(l31, uint32_t, htole32, Long_val) 61 | SET(l32, uint32_t, htole32, Int32_val) 62 | SET(l63, uint64_t, htole64, Long_val) 63 | SET(l64, uint64_t, htole64, Int64_val) 64 | 65 | #endif /* EXTUNIX_HAVE_ENDIAN */ 66 | 67 | /* Host endian */ 68 | #define id(x) x 69 | GET( u8, uint8_t, id, Val_long) 70 | GET( s8, int8_t, id, Val_long) 71 | GET(hu16, uint16_t, id, Val_long) 72 | GET(hs16, int16_t, id, Val_long) 73 | GET(hu31, uint32_t, id, Val_long) 74 | GET(hs31, int32_t, id, Val_long) 75 | GET(hs32, int32_t, id, caml_copy_int32) 76 | GET(hu63, uint64_t, id, Val_long) 77 | GET(hs63, int64_t, id, Val_long) 78 | GET(hs64, int64_t, id, caml_copy_int64) 79 | 80 | SET( 8, uint8_t, id, Long_val) 81 | SET(h16, uint16_t, id, Long_val) 82 | SET(h31, uint32_t, id, Long_val) 83 | SET(h32, uint32_t, id, Int32_val) 84 | SET(h63, uint64_t, id, Long_val) 85 | SET(h64, uint64_t, id, Int64_val) 86 | -------------------------------------------------------------------------------- /src/eventfd.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_EVENTFD 3 | #include "config.h" 4 | 5 | #if defined(EXTUNIX_HAVE_EVENTFD) 6 | 7 | CAMLprim value caml_extunix_eventfd(value v_init) 8 | { 9 | CAMLparam1(v_init); 10 | int fd = eventfd(Int_val(v_init), 0); 11 | if (-1 == fd) caml_uerror("eventfd",Nothing); 12 | CAMLreturn(Val_int(fd)); 13 | } 14 | 15 | CAMLprim value caml_extunix_eventfd_read(value v_fd) 16 | { 17 | CAMLparam1(v_fd); 18 | eventfd_t v; 19 | if (-1 == eventfd_read(Int_val(v_fd), &v)) 20 | caml_uerror("eventfd_read",Nothing); 21 | CAMLreturn(caml_copy_int64(v)); 22 | } 23 | 24 | CAMLprim value caml_extunix_eventfd_write(value v_fd, value v_val) 25 | { 26 | CAMLparam2(v_fd, v_val); 27 | if (-1 == eventfd_write(Int_val(v_fd), Int64_val(v_val))) 28 | caml_uerror("eventfd_write",Nothing); 29 | CAMLreturn(Val_unit); 30 | } 31 | 32 | #endif 33 | 34 | -------------------------------------------------------------------------------- /src/execinfo.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_EXECINFO 3 | #include "config.h" 4 | 5 | #if defined(EXTUNIX_HAVE_EXECINFO) 6 | 7 | CAMLprim value caml_extunix_backtrace(value unit) 8 | { 9 | CAMLparam1(unit); 10 | CAMLlocal1(v_ret); 11 | 12 | void *buffer[100]; 13 | int nptrs = backtrace(buffer, 100); 14 | int j; 15 | char **strings = backtrace_symbols(buffer, nptrs); 16 | if (NULL == strings) 17 | caml_uerror("backtrace", Nothing); 18 | 19 | v_ret = caml_alloc_tuple(nptrs); 20 | for (j = 0; j < nptrs; j++) 21 | Store_field(v_ret,j,caml_copy_string(strings[j])); 22 | 23 | free(strings); 24 | CAMLreturn(v_ret); 25 | } 26 | 27 | #endif 28 | 29 | -------------------------------------------------------------------------------- /src/extUnix.mli: -------------------------------------------------------------------------------- 1 | (** ExtUnix *) 2 | 3 | module Specific = Specific 4 | (** Only functions available on this platform *) 5 | 6 | module All = All 7 | (** All functions, 8 | those not available on this platform will raise [Not_available] 9 | with function name as an argument *) 10 | 11 | module Config = Config 12 | (** Compile-time configuration information *) 13 | -------------------------------------------------------------------------------- /src/fadvise.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Binding to posix_fadvise 3 | * 4 | * Copyright 2008-2009 Talend, Inc. 5 | * 6 | * License LGPL-2.1 with OCaml linking static exception 7 | * 8 | * For more information go to: www.talend.com 9 | * 10 | * author: Sylvain Le Gall 11 | * 12 | */ 13 | 14 | #define EXTUNIX_WANT_FADVISE 15 | #include "config.h" 16 | 17 | #if defined(EXTUNIX_HAVE_FADVISE) 18 | 19 | static const int fadv_flags_table[] = 20 | { 21 | POSIX_FADV_NORMAL, 22 | POSIX_FADV_SEQUENTIAL, 23 | POSIX_FADV_RANDOM, 24 | POSIX_FADV_NOREUSE, 25 | POSIX_FADV_WILLNEED, 26 | POSIX_FADV_DONTNEED 27 | }; 28 | 29 | CAMLprim value caml_extunix_fadvise64(value vfd, value voff, value vlen, value vadvise) 30 | { 31 | int errcode = 0; 32 | int fd = -1; 33 | off64_t off = 0; 34 | off64_t len = 0; 35 | int advise = 0; 36 | 37 | CAMLparam4(vfd, voff, vlen, vadvise); 38 | 39 | fd = Int_val(vfd); 40 | off = Int64_val(voff); 41 | len = Int64_val(vlen); 42 | advise = fadv_flags_table[Int_val(vadvise)]; 43 | 44 | errcode = posix_fadvise64(fd, off, len, advise); 45 | 46 | if (errcode != 0) 47 | { 48 | caml_unix_error(errcode, "fadvise64", Nothing); 49 | }; 50 | 51 | CAMLreturn(Val_unit); 52 | } 53 | 54 | CAMLprim value caml_extunix_fadvise(value vfd, value voff, value vlen, value vadvise) 55 | { 56 | int errcode = 0; 57 | int fd = -1; 58 | off_t off = 0; 59 | off_t len = 0; 60 | int advise = 0; 61 | 62 | CAMLparam4(vfd, voff, vlen, vadvise); 63 | 64 | fd = Int_val(vfd); 65 | off = Long_val(voff); 66 | len = Long_val(vlen); 67 | advise = fadv_flags_table[Int_val(vadvise)]; 68 | 69 | errcode = posix_fadvise(fd, off, len, advise); 70 | 71 | if (errcode != 0) 72 | { 73 | caml_unix_error(errcode, "fadvise", Nothing); 74 | }; 75 | 76 | CAMLreturn(Val_unit); 77 | } 78 | 79 | #endif 80 | 81 | -------------------------------------------------------------------------------- /src/fallocate.c: -------------------------------------------------------------------------------- 1 | /* 2 | * posix_fallocate binding 3 | * 4 | * Copyright 2008-2009 Talend, Inc. 5 | * 6 | * License LGPL-2.1 with OCaml linking static exception 7 | * 8 | * For more information go to: www.talend.com 9 | * 10 | * author: Sylvain Le Gall 11 | * 12 | */ 13 | 14 | #define EXTUNIX_WANT_FALLOCATE 15 | #include "config.h" 16 | 17 | #if defined(EXTUNIX_HAVE_FALLOCATE) 18 | 19 | #if defined(_WIN32) 20 | 21 | static void caml_fallocate_error (void) 22 | { 23 | caml_win32_maperr(GetLastError()); 24 | caml_uerror("fallocate", Val_unit); 25 | } 26 | 27 | static __int64 caml_fallocate_lseek (HANDLE hFile, __int64 i64Pos, DWORD dwMoveMethod) 28 | { 29 | LARGE_INTEGER liRes; 30 | 31 | liRes.QuadPart = i64Pos; 32 | liRes.LowPart = SetFilePointer(hFile, liRes.LowPart, &liRes.HighPart, dwMoveMethod); 33 | if (liRes.LowPart == INVALID_SET_FILE_POINTER && 34 | GetLastError() != NO_ERROR) 35 | { 36 | caml_fallocate_error(); 37 | }; 38 | 39 | return liRes.QuadPart; 40 | } 41 | 42 | static void caml_fallocate_do (HANDLE hFile, __int64 i64Off, __int64 i64Len) 43 | { 44 | __int64 i64Cur = 0; 45 | LARGE_INTEGER liFileSize; 46 | 47 | /* Check that off + len > file size */ 48 | if (!GetFileSizeEx(hFile, &liFileSize)) 49 | { 50 | caml_fallocate_error(); 51 | }; 52 | 53 | if (i64Off + i64Len <= liFileSize.QuadPart) 54 | { 55 | return; 56 | }; 57 | 58 | /* Get the current position in the file */ 59 | i64Cur = caml_fallocate_lseek(hFile, 0, FILE_CURRENT); 60 | 61 | /* Go to the expected end of file */ 62 | caml_fallocate_lseek(hFile, i64Off, FILE_BEGIN); 63 | caml_fallocate_lseek(hFile, i64Len, FILE_CURRENT); 64 | 65 | /* Extend file */ 66 | if (!SetEndOfFile(hFile)) 67 | { 68 | caml_fallocate_error(); 69 | }; 70 | 71 | /* Restore initial file pointer position */ 72 | caml_fallocate_lseek(hFile, i64Cur, FILE_BEGIN); 73 | } 74 | 75 | CAMLprim value caml_extunix_fallocate64(value vfd, value voff, value vlen) 76 | { 77 | CAMLparam3(vfd, voff, vlen); 78 | 79 | caml_fallocate_do(Handle_val(vfd), Int64_val(voff), Int64_val(vlen)); 80 | 81 | CAMLreturn(Val_unit); 82 | } 83 | 84 | CAMLprim value caml_extunix_fallocate(value vfd, value voff, value vlen) 85 | { 86 | CAMLparam3(vfd, voff, vlen); 87 | 88 | caml_fallocate_do(Handle_val(vfd), Long_val(voff), Long_val(vlen)); 89 | 90 | CAMLreturn(Val_unit); 91 | } 92 | 93 | #else 94 | 95 | static void caml_fallocate_error (int errcode) 96 | { 97 | if (errcode != 0) 98 | { 99 | caml_unix_error(errcode, "fallocate", Nothing); 100 | }; 101 | } 102 | 103 | CAMLprim value caml_extunix_fallocate64(value vfd, value voff, value vlen) 104 | { 105 | int errcode = 0; 106 | int fd = -1; 107 | off64_t off = 0; 108 | off64_t len = 0; 109 | 110 | CAMLparam3(vfd, voff, vlen); 111 | 112 | fd = Int_val(vfd); 113 | off = Int64_val(voff); 114 | len = Int64_val(vlen); 115 | 116 | errcode = posix_fallocate64(fd, off, len); 117 | 118 | caml_fallocate_error(errcode); 119 | 120 | CAMLreturn(Val_unit); 121 | } 122 | 123 | CAMLprim value caml_extunix_fallocate(value vfd, value voff, value vlen) 124 | { 125 | int errcode = 0; 126 | int fd = -1; 127 | off_t off = 0; 128 | off_t len = 0; 129 | 130 | CAMLparam3(vfd, voff, vlen); 131 | 132 | fd = Int_val(vfd); 133 | off = Long_val(voff); 134 | len = Long_val(vlen); 135 | 136 | errcode = posix_fallocate(fd, off, len); 137 | 138 | caml_fallocate_error(errcode); 139 | 140 | CAMLreturn(Val_unit); 141 | } 142 | 143 | #endif /* _WIN32 */ 144 | #endif /* EXTUNIX_HAVE_FALLOCATE */ 145 | -------------------------------------------------------------------------------- /src/fexecve.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_FEXECVE 2 | 3 | #include "config.h" 4 | 5 | #if defined(EXTUNIX_HAVE_FEXECVE) 6 | 7 | /* Copyright © 2012 Andre Nathan */ 8 | 9 | static char ** 10 | array_of_value(value v) 11 | { 12 | CAMLparam1(v); 13 | char **arr; 14 | mlsize_t size, i; 15 | 16 | size = Wosize_val(v); 17 | arr = caml_stat_alloc((size + 1) * sizeof(char *)); 18 | for (i = 0; i < size; i++) 19 | arr[i] = (char *)String_val(Field(v, i)); 20 | arr[size] = NULL; 21 | 22 | CAMLreturnT (char **, arr); 23 | } 24 | 25 | CAMLprim value caml_extunix_fexecve(value fd_val, value argv_val, value envp_val) 26 | { 27 | CAMLparam3(fd_val, argv_val, envp_val); 28 | char **argv; 29 | char **envp; 30 | 31 | argv = array_of_value(argv_val); 32 | envp = array_of_value(envp_val); 33 | 34 | fexecve(Int_val(fd_val), argv, envp); 35 | 36 | caml_stat_free(argv); 37 | caml_stat_free(envp); 38 | caml_uerror("fexecve", Nothing); 39 | 40 | CAMLreturn (Val_unit); /* not reached */ 41 | } 42 | 43 | #endif /* EXTUNIX_HAVE_FEXECVE */ 44 | -------------------------------------------------------------------------------- /src/fsync.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_FSYNC 2 | #define EXTUNIX_WANT_FDATASYNC 3 | #define EXTUNIX_WANT_SYNC 4 | #define EXTUNIX_WANT_SYNCFS 5 | #include "config.h" 6 | 7 | #if defined(_WIN32) 8 | 9 | #if defined(EXTUNIX_HAVE_FSYNC) 10 | CAMLprim value caml_extunix_fsync(value v) 11 | { 12 | CAMLparam1(v); 13 | HANDLE h = INVALID_HANDLE_VALUE; 14 | int r = 0; 15 | if (KIND_HANDLE != Descr_kind_val(v)) 16 | caml_invalid_argument("fsync"); 17 | h = Handle_val(v); 18 | caml_enter_blocking_section(); 19 | r = FlushFileBuffers(h); 20 | caml_leave_blocking_section(); 21 | if (0 == r) 22 | caml_uerror("fsync",Nothing); 23 | CAMLreturn(Val_unit); 24 | } 25 | 26 | #if defined(EXTUNIX_HAVE_FDATASYNC) 27 | CAMLprim value caml_extunix_fdatasync(value v) 28 | { 29 | return caml_extunix_fsync(v); 30 | } 31 | #endif 32 | 33 | #endif /* EXTUNIX_HAVE_FSYNC */ 34 | 35 | #else /* _WIN32 */ 36 | 37 | #if defined(EXTUNIX_HAVE_FSYNC) 38 | CAMLprim value caml_extunix_fsync(value v_fd) 39 | { 40 | CAMLparam1(v_fd); 41 | int fd = Int_val(v_fd); 42 | int r = 0; 43 | caml_enter_blocking_section(); 44 | r = fsync(fd); 45 | caml_leave_blocking_section(); 46 | if (0 != r) 47 | caml_uerror("fsync",Nothing); 48 | CAMLreturn(Val_unit); 49 | } 50 | #endif 51 | 52 | #if defined(EXTUNIX_HAVE_FDATASYNC) 53 | CAMLprim value caml_extunix_fdatasync(value v_fd) 54 | { 55 | CAMLparam1(v_fd); 56 | int fd = Int_val(v_fd); 57 | int r = 0; 58 | caml_enter_blocking_section(); 59 | r = fdatasync(fd); 60 | caml_leave_blocking_section(); 61 | if (0 != r) 62 | caml_uerror("fdatasync",Nothing); 63 | CAMLreturn(Val_unit); 64 | } 65 | #endif 66 | 67 | #if defined(EXTUNIX_HAVE_SYNC) 68 | CAMLprim value caml_extunix_sync(value v_unit) 69 | { 70 | (void)v_unit; 71 | caml_enter_blocking_section(); 72 | sync(); 73 | caml_leave_blocking_section(); 74 | return Val_unit; 75 | } 76 | #endif 77 | 78 | #if defined(EXTUNIX_HAVE_SYNCFS) 79 | CAMLprim value caml_extunix_syncfs(value v_fd) 80 | { 81 | CAMLparam1(v_fd); 82 | int fd = Int_val(v_fd); 83 | int r = 0; 84 | caml_enter_blocking_section(); 85 | #if defined(EXTUNIX_USE_SYS_SYNCFS) 86 | r = syscall(SYS_syncfs, fd); 87 | #else 88 | r = syncfs(fd); 89 | #endif 90 | caml_leave_blocking_section(); 91 | if (0 != r) 92 | caml_uerror("syncfs",Nothing); 93 | CAMLreturn(Val_unit); 94 | } 95 | #endif 96 | 97 | #endif /* !_WIN32 */ 98 | -------------------------------------------------------------------------------- /src/ioctl_siocgifconf.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_SIOCGIFCONF 3 | #define EXTUNIX_WANT_INET_NTOA 4 | #define EXTUNIX_WANT_INET_NTOP 5 | 6 | #define EXTUNIX_WANT_IFADDRS 7 | #include "config.h" 8 | 9 | #if defined(EXTUNIX_HAVE_SIOCGIFCONF) 10 | 11 | CAMLprim value caml_extunix_ioctl_siocgifconf(value v_sock) 12 | { 13 | CAMLparam1(v_sock); 14 | CAMLlocal3(lst,item,cons); 15 | 16 | struct ifreq ifreqs[32]; 17 | struct ifconf ifconf; 18 | unsigned int i; 19 | 20 | lst = Val_emptylist; 21 | 22 | memset(&ifconf, 0, sizeof(ifconf)); 23 | ifconf.ifc_req = ifreqs; 24 | ifconf.ifc_len = sizeof(ifreqs); 25 | 26 | if (0 != ioctl(Int_val(v_sock), SIOCGIFCONF, (char *)&ifconf)) 27 | caml_uerror("ioctl(SIOCGIFCONF)", Nothing); 28 | 29 | for (i = 0; i < ifconf.ifc_len/sizeof(struct ifreq); ++i) 30 | { 31 | cons = caml_alloc(2, 0); 32 | item = caml_alloc(2, 0); 33 | Store_field(item, 0, caml_copy_string(ifreqs[i].ifr_name)); 34 | Store_field(item, 1, caml_copy_string(inet_ntoa(((struct sockaddr_in *)&ifreqs[i].ifr_addr)->sin_addr))); 35 | Store_field(cons, 0, item); /* head */ 36 | Store_field(cons, 1, lst); /* tail */ 37 | lst = cons; 38 | } 39 | 40 | CAMLreturn(lst); 41 | } 42 | 43 | #endif 44 | 45 | #if defined(EXTUNIX_HAVE_IFADDRS) 46 | 47 | CAMLprim value caml_extunix_getifaddrs(value v) 48 | { 49 | CAMLparam1(v); 50 | CAMLlocal3(lst,item,cons); 51 | 52 | struct ifaddrs *ifaddrs = NULL; 53 | struct ifaddrs *iter = NULL; 54 | char addr_str[INET6_ADDRSTRLEN]; 55 | 56 | lst = Val_emptylist; 57 | 58 | if (0 != getifaddrs(&ifaddrs)) 59 | { 60 | if (ifaddrs) freeifaddrs(ifaddrs); 61 | caml_uerror("getifaddrs", Nothing); 62 | } 63 | 64 | iter = ifaddrs; /* store head for further free */ 65 | 66 | while(iter != NULL) 67 | { 68 | if (iter->ifa_addr != NULL) 69 | { 70 | const sa_family_t family = iter->ifa_addr->sa_family; 71 | if (family == AF_INET || family == AF_INET6) 72 | { 73 | cons = caml_alloc(2, 0); 74 | item = caml_alloc(2, 0); 75 | Store_field(item, 0, caml_copy_string(iter->ifa_name)); 76 | if (family == AF_INET) 77 | { 78 | if (NULL == inet_ntop(family, &((struct sockaddr_in *)iter->ifa_addr)->sin_addr, addr_str, INET_ADDRSTRLEN)) 79 | caml_uerror("inet_ntop", Nothing); 80 | } 81 | else 82 | { 83 | if (NULL == inet_ntop(family, &((struct sockaddr_in6 *)iter->ifa_addr)->sin6_addr, addr_str, INET6_ADDRSTRLEN)) 84 | caml_uerror("inet_ntop", Nothing); 85 | } 86 | Store_field(item, 1, caml_copy_string(addr_str)); 87 | Store_field(cons, 0, item); /* head */ 88 | Store_field(cons, 1, lst); /* tail */ 89 | lst = cons; 90 | } 91 | } 92 | iter = iter->ifa_next; 93 | } 94 | 95 | freeifaddrs(ifaddrs); 96 | CAMLreturn(lst); 97 | } 98 | 99 | #endif 100 | -------------------------------------------------------------------------------- /src/malloc.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_MALLOC_INFO 3 | #define EXTUNIX_WANT_MALLOC_STATS 4 | #define EXTUNIX_WANT_MCHECK 5 | #include "config.h" 6 | 7 | #if defined(EXTUNIX_HAVE_MALLOC_STATS) 8 | 9 | CAMLprim value caml_extunix_malloc_stats(value v_unit) 10 | { 11 | UNUSED(v_unit); 12 | malloc_stats(); 13 | return Val_unit; 14 | } 15 | 16 | #endif 17 | 18 | #if defined(EXTUNIX_HAVE_MALLOC_INFO) 19 | 20 | #include 21 | 22 | CAMLprim value caml_extunix_malloc_info(value v_unit) 23 | { 24 | CAMLparam0(); 25 | CAMLlocal1(v_s); 26 | char* buf = NULL; 27 | size_t size; 28 | int r; 29 | FILE* f = open_memstream(&buf,&size); 30 | UNUSED(v_unit); 31 | if (NULL == f) 32 | caml_uerror("malloc_info", Nothing); 33 | r = malloc_info(0,f); 34 | fclose(f); 35 | if (0 != r) 36 | { 37 | free(buf); 38 | caml_uerror("malloc_info", Nothing); 39 | } 40 | v_s = caml_alloc_string(size); 41 | memcpy(Bp_val(v_s), buf, size); 42 | free(buf); 43 | CAMLreturn(v_s); 44 | } 45 | 46 | #endif 47 | 48 | #if defined(EXTUNIX_HAVE_MCHECK) 49 | 50 | CAMLprim value caml_extunix_mtrace(value v) 51 | { 52 | UNUSED(v); 53 | mtrace(); 54 | return Val_unit; 55 | } 56 | 57 | CAMLprim value caml_extunix_muntrace(value v) 58 | { 59 | UNUSED(v); 60 | muntrace(); 61 | return Val_unit; 62 | } 63 | 64 | #endif 65 | -------------------------------------------------------------------------------- /src/memalign.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_MEMALIGN 3 | #include "config.h" 4 | 5 | #if defined(EXTUNIX_HAVE_MEMALIGN) 6 | 7 | /* 8 | * Binding to posix_memalign 9 | * 10 | * Copyright 2012 Goswin von Brederlow 11 | * 12 | * License LGPL-2.1 with OCaml linking static exception 13 | * 14 | * For more information go to: www.talend.com 15 | * 16 | * author: Goswin von Brederlow 17 | * 18 | */ 19 | 20 | CAMLprim value caml_extunix_memalign(value valignment, value vsize) 21 | { 22 | CAMLparam2(valignment, vsize); 23 | 24 | size_t alignment; 25 | size_t size; 26 | int errcode; 27 | void *memptr; 28 | 29 | alignment = Int_val(valignment); 30 | size = Int_val(vsize); 31 | 32 | errcode = posix_memalign(&memptr, alignment, size); 33 | 34 | if (errcode != 0) 35 | { 36 | caml_unix_error(errcode, "memalign", Nothing); 37 | }; 38 | 39 | CAMLreturn(caml_ba_alloc_dims(CAML_BA_UINT8 | CAML_BA_C_LAYOUT | CAML_BA_MANAGED, 1, memptr, size)); 40 | } 41 | 42 | #endif 43 | -------------------------------------------------------------------------------- /src/mktemp.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_MKDTEMP 2 | #define EXTUNIX_WANT_MKSTEMPS 3 | #define EXTUNIX_WANT_MKOSTEMPS 4 | 5 | #include "config.h" 6 | 7 | #if defined(EXTUNIX_HAVE_MKDTEMP) 8 | 9 | CAMLprim value caml_extunix_mkdtemp(value v_path) 10 | { 11 | CAMLparam1(v_path); 12 | char* path = caml_stat_strdup(String_val(v_path)); 13 | char *ret; 14 | caml_enter_blocking_section(); 15 | ret = mkdtemp(path); 16 | caml_leave_blocking_section(); 17 | if (NULL == ret) 18 | { 19 | caml_stat_free(path); 20 | caml_uerror("mkdtemp", v_path); 21 | } 22 | v_path = caml_copy_string(ret); 23 | caml_stat_free(path); 24 | CAMLreturn(v_path); 25 | } 26 | 27 | #endif 28 | 29 | #if defined(EXTUNIX_HAVE_MKSTEMPS) 30 | 31 | CAMLprim value caml_extunix_internal_mkstemps(value v_template, value v_suffixlen) 32 | { 33 | CAMLparam2(v_template, v_suffixlen); 34 | unsigned char *template = Bytes_val(v_template); 35 | int suffixlen = Int_val(v_suffixlen); 36 | int ret; 37 | 38 | ret = mkstemps((char *)template, suffixlen); 39 | if (ret == -1) 40 | { 41 | caml_uerror("mkstemps", v_template); 42 | } 43 | CAMLreturn(Val_int(ret)); 44 | } 45 | 46 | #endif 47 | 48 | #if defined(EXTUNIX_HAVE_MKOSTEMPS) 49 | 50 | /* FIXME: also in atfile.c, move to common file */ 51 | #include 52 | 53 | #ifndef O_CLOEXEC 54 | # define O_CLOEXEC 0 55 | #endif 56 | 57 | CAMLprim value caml_extunix_internal_mkostemps(value v_template, value v_suffixlen, value v_flags) 58 | { 59 | CAMLparam3(v_template, v_suffixlen, v_flags); 60 | unsigned char *template = Bytes_val(v_template); 61 | int flags = extunix_open_flags(v_flags) | O_CLOEXEC; 62 | int suffixlen = Int_val(v_suffixlen); 63 | int ret; 64 | 65 | ret = mkostemps((char*) template, suffixlen, flags); 66 | if (ret == -1) 67 | { 68 | caml_uerror("mkostemps", v_template); 69 | } 70 | CAMLreturn(Val_int(ret)); 71 | } 72 | 73 | #endif 74 | -------------------------------------------------------------------------------- /src/mman.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_MLOCKALL 2 | #include "config.h" 3 | 4 | #if defined(EXTUNIX_HAVE_MLOCKALL) 5 | 6 | static const int mlockall_flags_table[] = { MCL_CURRENT, MCL_FUTURE }; 7 | 8 | CAMLprim value caml_extunix_mlockall(value v_flags) 9 | { 10 | CAMLparam1(v_flags); 11 | int flags = caml_convert_flag_list(v_flags, mlockall_flags_table); 12 | int ret = 0; 13 | 14 | caml_enter_blocking_section(); 15 | ret = mlockall(flags); 16 | caml_leave_blocking_section(); 17 | 18 | if (ret != 0) caml_uerror("mlockall", Nothing); 19 | 20 | CAMLreturn(Val_unit); 21 | } 22 | 23 | CAMLprim value caml_extunix_munlockall(value v_unit) 24 | { 25 | CAMLparam1(v_unit); 26 | int ret = 0; 27 | 28 | caml_enter_blocking_section(); 29 | ret = munlockall(); 30 | caml_leave_blocking_section(); 31 | 32 | if (ret != 0) caml_uerror("munlockall", Nothing); 33 | 34 | CAMLreturn(Val_unit); 35 | } 36 | 37 | #endif 38 | 39 | -------------------------------------------------------------------------------- /src/mount.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_MOUNT 2 | #include "config.h" 3 | 4 | #if defined(EXTUNIX_HAVE_MOUNT) 5 | 6 | static const int mountflags_table[] = { 7 | MS_RDONLY, MS_NOSUID, MS_NODEV, MS_NOEXEC, MS_SYNCHRONOUS, MS_REMOUNT, 8 | MS_MANDLOCK, MS_DIRSYNC, MS_NOATIME, MS_NODIRATIME, MS_BIND, MS_MOVE, 9 | MS_REC, MS_SILENT, MS_POSIXACL, MS_UNBINDABLE, MS_PRIVATE, MS_SLAVE, 10 | MS_SHARED, MS_RELATIME, MS_KERNMOUNT, MS_I_VERSION, MS_STRICTATIME, 11 | MS_NOUSER 12 | }; 13 | 14 | CAMLprim value caml_extunix_mount(value v_source, value v_target, 15 | value v_fstype, value v_mountflags, 16 | value v_data) 17 | { 18 | CAMLparam5(v_source, v_target, v_fstype, v_mountflags, v_data); 19 | int ret; 20 | char* p_source = caml_stat_strdup(String_val(v_source)); 21 | char* p_target = caml_stat_strdup(String_val(v_target)); 22 | char* p_fstype = caml_stat_strdup(String_val(v_fstype)); 23 | char* p_data = caml_stat_strdup(String_val(v_data)); 24 | 25 | int p_mountflags = caml_convert_flag_list(v_mountflags, mountflags_table); 26 | 27 | caml_enter_blocking_section(); 28 | ret = mount(p_source, p_target, p_fstype, p_mountflags, p_data); 29 | caml_leave_blocking_section(); 30 | 31 | caml_stat_free(p_source); 32 | caml_stat_free(p_target); 33 | caml_stat_free(p_fstype); 34 | caml_stat_free(p_data); 35 | 36 | if (ret != 0) caml_uerror("mount", v_target); 37 | CAMLreturn(Val_unit); 38 | } 39 | 40 | static const int umountflags_table[] = { 41 | MNT_FORCE, MNT_DETACH, MNT_EXPIRE, UMOUNT_NOFOLLOW, 42 | }; 43 | 44 | CAMLprim value caml_extunix_umount2(value v_target,value v_umountflags) 45 | { 46 | CAMLparam2(v_target, v_umountflags); 47 | int ret; 48 | char* p_target = caml_stat_strdup(String_val(v_target)); 49 | 50 | int p_umountflags = caml_convert_flag_list(v_umountflags, umountflags_table); 51 | 52 | caml_enter_blocking_section(); 53 | ret = umount2(p_target, p_umountflags); 54 | caml_leave_blocking_section(); 55 | 56 | caml_stat_free(p_target); 57 | 58 | if (ret != 0) caml_uerror("umount", v_target); 59 | CAMLreturn(Val_unit); 60 | } 61 | 62 | 63 | #endif 64 | -------------------------------------------------------------------------------- /src/poll.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_POLL 2 | #include "config.h" 3 | 4 | #if defined(EXTUNIX_HAVE_POLL) 5 | 6 | CAMLprim value caml_extunix_poll_constants(value v_unit) 7 | { 8 | value v = caml_alloc_tuple(7); 9 | UNUSED(v_unit); 10 | 11 | Field(v,0) = Val_int(POLLIN); 12 | Field(v,1) = Val_int(POLLPRI); 13 | Field(v,2) = Val_int(POLLOUT); 14 | Field(v,3) = Val_int(POLLERR); 15 | Field(v,4) = Val_int(POLLHUP); 16 | Field(v,5) = Val_int(POLLNVAL); 17 | Field(v,6) = Val_int(POLLRDHUP); 18 | 19 | return v; 20 | } 21 | 22 | CAMLprim value caml_extunix_poll(value v_fds, value v_n, value v_ms) 23 | { 24 | CAMLparam3(v_fds, v_n, v_ms); 25 | CAMLlocal3(v_l,v_tuple,v_cons); 26 | struct pollfd* fd = NULL; 27 | size_t n = Int_val(v_n); 28 | size_t i = 0; 29 | int result; 30 | int timeout = Double_val(v_ms) * 1000.f; 31 | 32 | if (Wosize_val(v_fds) < n) 33 | caml_invalid_argument("poll"); 34 | 35 | if (0 == n) 36 | CAMLreturn(Val_emptylist); 37 | 38 | fd = caml_stat_alloc(n * sizeof(struct pollfd)); 39 | 40 | for (i = 0; i < n; i++) 41 | { 42 | fd[i].fd = Int_val(Field(Field(v_fds,i),0)); 43 | fd[i].events = Int_val(Field(Field(v_fds,i),1)); 44 | fd[i].revents = 0; 45 | } 46 | 47 | caml_enter_blocking_section(); 48 | result = poll(fd, n, timeout); 49 | caml_leave_blocking_section(); 50 | 51 | if (result < 0) 52 | { 53 | caml_stat_free(fd); 54 | caml_uerror("poll",Nothing); 55 | } 56 | 57 | v_l = Val_emptylist; 58 | for (i = 0; i < n; i++) 59 | { 60 | if (fd[i].revents != 0) 61 | { 62 | v_tuple = caml_alloc_tuple(2); 63 | Store_field(v_tuple,0,Val_int(fd[i].fd)); 64 | Store_field(v_tuple,1,Val_int(fd[i].revents)); 65 | v_cons = caml_alloc_tuple(2); 66 | Store_field(v_cons,0,v_tuple); 67 | Store_field(v_cons,1,v_l); 68 | v_l = v_cons; 69 | } 70 | } 71 | 72 | caml_stat_free(fd); 73 | 74 | CAMLreturn(v_l); 75 | } 76 | 77 | #endif 78 | -------------------------------------------------------------------------------- /src/pread_pwrite_ba.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_PREAD 3 | #define EXTUNIX_WANT_PWRITE 4 | #include "config.h" 5 | 6 | enum mode_bits { 7 | BIT_ONCE = 1 << 0, 8 | BIT_NOERROR = 1 << 1, 9 | BIT_NOINTR = 1 << 2 10 | }; 11 | 12 | #if defined(EXTUNIX_HAVE_PREAD) 13 | 14 | /* Copyright © 2012 Goswin von Brederlow */ 15 | 16 | CAMLprim value caml_extunixba_pread_common(value v_fd, off_t off, value v_buf, int mode) { 17 | CAMLparam2(v_fd, v_buf); 18 | ssize_t ret; 19 | size_t fd = Int_val(v_fd); 20 | size_t len = caml_ba_byte_size(Caml_ba_array_val(v_buf)); 21 | size_t processed = 0; 22 | char *buf = (char*)Caml_ba_data_val(v_buf); 23 | 24 | while(len > 0) { 25 | caml_enter_blocking_section(); 26 | ret = pread(fd, buf, len, off); 27 | caml_leave_blocking_section(); 28 | if (ret == 0) break; 29 | if (ret == -1) { 30 | if (errno == EINTR && (mode & BIT_NOINTR)) continue; 31 | if (processed > 0) { 32 | if (errno == EAGAIN || errno == EWOULDBLOCK) break; 33 | if (mode & BIT_NOERROR) break; 34 | } 35 | caml_uerror("pread", Nothing); 36 | } 37 | processed += ret; 38 | buf += ret; 39 | off += ret; 40 | len -= ret; 41 | if (mode & BIT_ONCE) break; 42 | } 43 | 44 | CAMLreturn(Val_long(processed)); 45 | } 46 | 47 | value caml_extunixba_all_pread(value v_fd, value v_off, value v_buf) 48 | { 49 | off_t off = Long_val(v_off); 50 | return caml_extunixba_pread_common(v_fd, off, v_buf, BIT_NOINTR); 51 | } 52 | 53 | value caml_extunixba_single_pread(value v_fd, value v_off, value v_buf) 54 | { 55 | off_t off = Long_val(v_off); 56 | return caml_extunixba_pread_common(v_fd, off, v_buf, BIT_ONCE); 57 | } 58 | 59 | value caml_extunixba_pread(value v_fd, value v_off, value v_buf) 60 | { 61 | off_t off = Long_val(v_off); 62 | return caml_extunixba_pread_common(v_fd, off, v_buf, BIT_NOINTR | BIT_NOERROR); 63 | } 64 | 65 | value caml_extunixba_intr_pread(value v_fd, value v_off, value v_buf) 66 | { 67 | off_t off = Long_val(v_off); 68 | return caml_extunixba_pread_common(v_fd, off, v_buf, BIT_NOERROR); 69 | } 70 | 71 | value caml_extunixba_all_pread64(value v_fd, value v_off, value v_buf) 72 | { 73 | off_t off = Int64_val(v_off); 74 | return caml_extunixba_pread_common(v_fd, off, v_buf, BIT_NOINTR); 75 | } 76 | 77 | value caml_extunixba_single_pread64(value v_fd, value v_off, value v_buf) 78 | { 79 | off_t off = Int64_val(v_off); 80 | return caml_extunixba_pread_common(v_fd, off, v_buf, BIT_ONCE); 81 | } 82 | 83 | value caml_extunixba_pread64(value v_fd, value v_off, value v_buf) 84 | { 85 | off_t off = Int64_val(v_off); 86 | return caml_extunixba_pread_common(v_fd, off, v_buf, BIT_NOINTR | BIT_NOERROR); 87 | } 88 | 89 | value caml_extunixba_intr_pread64(value v_fd, value v_off, value v_buf) 90 | { 91 | off_t off = Int64_val(v_off); 92 | return caml_extunixba_pread_common(v_fd, off, v_buf, BIT_NOERROR); 93 | } 94 | #endif 95 | 96 | #if defined(EXTUNIX_HAVE_PWRITE) 97 | 98 | /* Copyright © 2012 Goswin von Brederlow */ 99 | 100 | CAMLprim value caml_extunixba_pwrite_common(value v_fd, off_t off, value v_buf, int mode) { 101 | CAMLparam2(v_fd, v_buf); 102 | ssize_t ret; 103 | size_t fd = Int_val(v_fd); 104 | size_t len = caml_ba_byte_size(Caml_ba_array_val(v_buf)); 105 | size_t processed = 0; 106 | char *buf = (char*)Caml_ba_data_val(v_buf); 107 | 108 | while(len > 0) { 109 | caml_enter_blocking_section(); 110 | ret = pwrite(fd, buf, len, off); 111 | caml_leave_blocking_section(); 112 | if (ret == 0) break; 113 | if (ret == -1) { 114 | if (errno == EINTR && (mode & BIT_NOINTR)) continue; 115 | if (processed > 0){ 116 | if (errno == EAGAIN || errno == EWOULDBLOCK) break; 117 | if (mode & BIT_NOERROR) break; 118 | } 119 | caml_uerror("pwrite", Nothing); 120 | } 121 | processed += ret; 122 | buf += ret; 123 | off += ret; 124 | len -= ret; 125 | if (mode & BIT_ONCE) break; 126 | } 127 | 128 | CAMLreturn(Val_long(processed)); 129 | } 130 | 131 | value caml_extunixba_all_pwrite(value v_fd, value v_off, value v_buf) 132 | { 133 | off_t off = Long_val(v_off); 134 | return caml_extunixba_pwrite_common(v_fd, off, v_buf, BIT_NOINTR); 135 | } 136 | 137 | value caml_extunixba_single_pwrite(value v_fd, value v_off, value v_buf) 138 | { 139 | off_t off = Long_val(v_off); 140 | return caml_extunixba_pwrite_common(v_fd, off, v_buf, BIT_ONCE); 141 | } 142 | 143 | value caml_extunixba_pwrite(value v_fd, value v_off, value v_buf) 144 | { 145 | off_t off = Long_val(v_off); 146 | return caml_extunixba_pwrite_common(v_fd, off, v_buf, BIT_NOINTR | BIT_NOERROR); 147 | } 148 | 149 | value caml_extunixba_intr_pwrite(value v_fd, value v_off, value v_buf) 150 | { 151 | off_t off = Long_val(v_off); 152 | return caml_extunixba_pwrite_common(v_fd, off, v_buf, BIT_NOERROR); 153 | } 154 | 155 | value caml_extunixba_all_pwrite64(value v_fd, value v_off, value v_buf) 156 | { 157 | off_t off = Int64_val(v_off); 158 | return caml_extunixba_pwrite_common(v_fd, off, v_buf, BIT_NOINTR); 159 | } 160 | 161 | value caml_extunixba_single_pwrite64(value v_fd, value v_off, value v_buf) 162 | { 163 | off_t off = Int64_val(v_off); 164 | return caml_extunixba_pwrite_common(v_fd, off, v_buf, BIT_ONCE); 165 | } 166 | 167 | value caml_extunixba_pwrite64(value v_fd, value v_off, value v_buf) 168 | { 169 | off_t off = Int64_val(v_off); 170 | return caml_extunixba_pwrite_common(v_fd, off, v_buf, BIT_NOINTR | BIT_NOERROR); 171 | } 172 | 173 | value caml_extunixba_intr_pwrite64(value v_fd, value v_off, value v_buf) 174 | { 175 | off_t off = Int64_val(v_off); 176 | return caml_extunixba_pwrite_common(v_fd, off, v_buf, BIT_NOERROR); 177 | } 178 | #endif 179 | 180 | #if defined(EXTUNIX_HAVE_READ) 181 | 182 | /* Copyright © 2012 Goswin von Brederlow */ 183 | 184 | CAMLprim value caml_extunixba_read_common(value v_fd, value v_buf, int mode) { 185 | CAMLparam2(v_fd, v_buf); 186 | ssize_t ret; 187 | size_t fd = Int_val(v_fd); 188 | size_t len = caml_ba_byte_size(Caml_ba_array_val(v_buf)); 189 | size_t processed = 0; 190 | char *buf = (char*)Caml_ba_data_val(v_buf); 191 | 192 | while(len > 0) { 193 | caml_enter_blocking_section(); 194 | ret = read(fd, buf, len); 195 | caml_leave_blocking_section(); 196 | if (ret == 0) break; 197 | if (ret == -1) { 198 | if (errno == EINTR && (mode & BIT_NOINTR)) continue; 199 | if (processed > 0) { 200 | if (errno == EAGAIN || errno == EWOULDBLOCK) break; 201 | if (mode & BIT_NOERROR) break; 202 | } 203 | caml_uerror("read", Nothing); 204 | } 205 | processed += ret; 206 | buf += ret; 207 | len -= ret; 208 | if (mode & BIT_ONCE) break; 209 | } 210 | 211 | CAMLreturn(Val_long(processed)); 212 | } 213 | 214 | value caml_extunixba_all_read(value v_fd, value v_buf) 215 | { 216 | return caml_extunixba_read_common(v_fd, v_buf, BIT_NOINTR); 217 | } 218 | 219 | value caml_extunixba_single_read(value v_fd, value v_buf) 220 | { 221 | return caml_extunixba_read_common(v_fd, v_buf, BIT_ONCE); 222 | } 223 | 224 | value caml_extunixba_read(value v_fd, value v_buf) 225 | { 226 | return caml_extunixba_read_common(v_fd, v_buf, BIT_NOINTR | BIT_NOERROR); 227 | } 228 | 229 | value caml_extunixba_intr_read(value v_fd, value v_buf) 230 | { 231 | return caml_extunixba_read_common(v_fd, v_buf, BIT_NOERROR); 232 | } 233 | #endif 234 | 235 | #if defined(EXTUNIX_HAVE_WRITE) 236 | 237 | /* Copyright © 2012 Goswin von Brederlow */ 238 | 239 | CAMLprim value caml_extunixba_write_common(value v_fd, value v_buf, int mode) { 240 | CAMLparam2(v_fd, v_buf); 241 | ssize_t ret; 242 | size_t fd = Int_val(v_fd); 243 | size_t len = caml_ba_byte_size(Caml_ba_array_val(v_buf)); 244 | size_t processed = 0; 245 | char *buf = (char*)Caml_ba_data_val(v_buf); 246 | 247 | while(len > 0) { 248 | caml_enter_blocking_section(); 249 | ret = write(fd, buf, len); 250 | caml_leave_blocking_section(); 251 | if (ret == 0) break; 252 | if (ret == -1) { 253 | if (errno == EINTR && (mode & BIT_NOINTR)) continue; 254 | if (processed > 0){ 255 | if (errno == EAGAIN || errno == EWOULDBLOCK) break; 256 | if (mode & BIT_NOERROR) break; 257 | } 258 | caml_uerror("write", Nothing); 259 | } 260 | processed += ret; 261 | buf += ret; 262 | len -= ret; 263 | if (mode & BIT_ONCE) break; 264 | } 265 | 266 | CAMLreturn(Val_long(processed)); 267 | } 268 | 269 | value caml_extunixba_all_write(value v_fd, value v_buf) 270 | { 271 | return caml_extunixba_write_common(v_fd, v_buf, BIT_NOINTR); 272 | } 273 | 274 | value caml_extunixba_single_write(value v_fd, value v_buf) 275 | { 276 | return caml_extunixba_write_common(v_fd, v_buf, BIT_ONCE); 277 | } 278 | 279 | value caml_extunixba_write(value v_fd, value v_buf) 280 | { 281 | return caml_extunixba_write_common(v_fd, v_buf, BIT_NOINTR | BIT_NOERROR); 282 | } 283 | 284 | value caml_extunixba_intr_write(value v_fd, value v_buf) 285 | { 286 | return caml_extunixba_write_common(v_fd, v_buf, BIT_NOERROR); 287 | } 288 | #endif 289 | 290 | -------------------------------------------------------------------------------- /src/ptrace.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_PTRACE 3 | #include "config.h" 4 | 5 | #if defined(EXTUNIX_HAVE_PTRACE) 6 | 7 | CAMLprim value caml_extunix_ptrace_traceme(value v_unit) 8 | { 9 | long r = ptrace(PTRACE_TRACEME, 0, 0, 0); 10 | UNUSED(v_unit); 11 | if (r != 0) 12 | caml_uerror("ptrace_traceme", Nothing); 13 | return Val_unit; 14 | } 15 | 16 | CAMLprim value caml_extunix_ptrace(value v_pid, value v_req) 17 | { 18 | CAMLparam2(v_pid, v_req); 19 | long r = 0; 20 | switch (Int_val(v_req)) 21 | { 22 | case 0 : r = ptrace(PTRACE_ATTACH, Int_val(v_pid), 0, 0); break; 23 | case 1 : r = ptrace(PTRACE_DETACH, Int_val(v_pid), 0, 0); break; 24 | default : caml_invalid_argument("ptrace"); 25 | } 26 | if (r != 0) 27 | caml_uerror("ptrace", Nothing); 28 | CAMLreturn(Val_unit); 29 | } 30 | 31 | CAMLprim value caml_extunix_ptrace_peekdata(value v_pid, value v_addr) 32 | { 33 | CAMLparam2(v_pid, v_addr); 34 | long r = ptrace(PTRACE_PEEKDATA,Int_val(v_pid), Nativeint_val(v_addr), 0); 35 | if (-1 == r && 0 != errno) 36 | caml_uerror("ptrace_peekdata",Nothing); 37 | CAMLreturn(caml_copy_nativeint(r)); 38 | } 39 | 40 | CAMLprim value caml_extunix_ptrace_peektext(value v_pid, value v_addr) 41 | { 42 | CAMLparam2(v_pid, v_addr); 43 | long r = ptrace(PTRACE_PEEKTEXT,Int_val(v_pid), Nativeint_val(v_addr), 0); 44 | if (-1 == r && 0 != errno) 45 | caml_uerror("ptrace_peektext",Nothing); 46 | CAMLreturn(caml_copy_nativeint(r)); 47 | } 48 | 49 | #endif 50 | 51 | -------------------------------------------------------------------------------- /src/pts.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_PTS 3 | #include "config.h" 4 | 5 | #if defined(EXTUNIX_HAVE_PTS) 6 | 7 | CAMLprim value caml_extunix_posix_openpt(value flags) 8 | { 9 | CAMLparam1(flags); 10 | int ret, cv_flags; 11 | cv_flags = extunix_open_flags(flags); 12 | ret = posix_openpt(cv_flags); 13 | if(ret == -1) 14 | caml_uerror("posix_openpt", Nothing); 15 | CAMLreturn(Val_int(ret)); 16 | } 17 | 18 | CAMLprim value caml_extunix_grantpt(value fd) 19 | { 20 | CAMLparam1(fd); 21 | if(grantpt(Int_val(fd)) == -1) 22 | caml_uerror("grantpt", Nothing); 23 | CAMLreturn(Val_unit); 24 | } 25 | 26 | CAMLprim value caml_extunix_unlockpt(value fd) 27 | { 28 | CAMLparam1(fd); 29 | if(unlockpt(Int_val(fd)) == -1) 30 | caml_uerror("unlockpt", Nothing); 31 | CAMLreturn(Val_unit); 32 | } 33 | 34 | CAMLprim value caml_extunix_ptsname(value fd) 35 | { 36 | CAMLparam1(fd); 37 | CAMLlocal1(ret); 38 | char *name = ptsname(Int_val(fd)); 39 | if(name == 0) 40 | caml_uerror("ptsname", Nothing); 41 | ret = caml_copy_string(name); 42 | CAMLreturn(ret); 43 | } 44 | 45 | 46 | #endif /* HAVE_PTS */ 47 | -------------------------------------------------------------------------------- /src/read_cred.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_READ_CREDENTIALS 2 | 3 | #include "config.h" 4 | 5 | #if defined(EXTUNIX_HAVE_READ_CREDENTIALS) 6 | 7 | /* Copyright © 2012 Andre Nathan */ 8 | 9 | CAMLprim value caml_extunix_read_credentials(value fd_val) 10 | { 11 | CAMLparam1(fd_val); 12 | CAMLlocal1(res); 13 | struct ucred crd; 14 | socklen_t crdlen = sizeof crd; 15 | int fd = Int_val(fd_val); 16 | 17 | if (getsockopt(fd, SOL_SOCKET, SO_PEERCRED, &crd, &crdlen) == -1) 18 | caml_uerror("read_credentials", Nothing); 19 | 20 | res = caml_alloc_tuple(3); 21 | Store_field(res, 0, Val_int(crd.pid)); 22 | Store_field(res, 1, Val_int(crd.uid)); 23 | Store_field(res, 2, Val_int(crd.gid)); 24 | CAMLreturn (res); 25 | } 26 | #endif /* EXTUNIX_HAVE_READ_CREDENTIALS */ 27 | -------------------------------------------------------------------------------- /src/realpath.c: -------------------------------------------------------------------------------- 1 | /**************************************************************************/ 2 | /* */ 3 | /* OCaml */ 4 | /* */ 5 | /* The OCaml programmers */ 6 | /* */ 7 | /* Copyright 2020 Institut National de Recherche en Informatique et */ 8 | /* en Automatique. */ 9 | /* */ 10 | /* All rights reserved. This file is distributed under the terms of */ 11 | /* the GNU Lesser General Public License version 2.1, with the */ 12 | /* special exception on linking described in the file LICENSE. */ 13 | /* */ 14 | /**************************************************************************/ 15 | 16 | #define EXTUNIX_WANT_REALPATH 17 | #include "config.h" 18 | 19 | #if defined(EXTUNIX_HAVE_REALPATH) 20 | 21 | #if !defined(_WIN32) 22 | 23 | CAMLprim value caml_extunix_realpath (value p) 24 | { 25 | CAMLparam1 (p); 26 | char *r; 27 | value rp; 28 | 29 | // caml_unix_check_path (p, "realpath"); 30 | r = realpath (String_val (p), NULL); 31 | if (r == NULL) { caml_uerror ("realpath", p); } 32 | rp = caml_copy_string (r); 33 | free (r); 34 | CAMLreturn (rp); 35 | } 36 | 37 | #else 38 | 39 | #include 40 | 41 | CAMLprim value caml_extunix_realpath (value p) 42 | { 43 | CAMLparam1 (p); 44 | HANDLE h; 45 | wchar_t *wp; 46 | wchar_t *wr; 47 | DWORD wr_len; 48 | value rp; 49 | 50 | // caml_unix_check_path (p, "realpath"); 51 | wp = caml_stat_strdup_to_utf16 (String_val (p)); 52 | h = CreateFile (wp, 0, 53 | FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, 54 | OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); 55 | caml_stat_free (wp); 56 | 57 | if (h == INVALID_HANDLE_VALUE) 58 | { 59 | caml_win32_maperr (GetLastError ()); 60 | caml_uerror ("realpath", p); 61 | } 62 | 63 | wr_len = GetFinalPathNameByHandle (h, NULL, 0, VOLUME_NAME_DOS); 64 | if (wr_len == 0) 65 | { 66 | caml_win32_maperr (GetLastError ()); 67 | CloseHandle (h); 68 | caml_uerror ("realpath", p); 69 | } 70 | 71 | wr = caml_stat_alloc ((wr_len + 1) * sizeof (wchar_t)); 72 | wr_len = GetFinalPathNameByHandle (h, wr, wr_len, VOLUME_NAME_DOS); 73 | 74 | if (wr_len == 0) 75 | { 76 | caml_win32_maperr (GetLastError ()); 77 | CloseHandle (h); 78 | caml_stat_free (wr); 79 | caml_uerror ("realpath", p); 80 | } 81 | 82 | rp = caml_copy_string_of_utf16 (wr); 83 | CloseHandle (h); 84 | caml_stat_free (wr); 85 | CAMLreturn (rp); 86 | } 87 | 88 | #endif 89 | #endif 90 | -------------------------------------------------------------------------------- /src/rename.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_RENAMEAT2 2 | #include "config.h" 3 | 4 | #if defined(EXTUNIX_HAVE_RENAMEAT2) 5 | 6 | #ifndef RENAME_WHITEOUT 7 | #define RENAME_WHITEOUT 0 8 | #endif 9 | 10 | static const int rename_flags_table[] = { 11 | RENAME_NOREPLACE, /* 0 */ 12 | RENAME_EXCHANGE, /* 1 */ 13 | RENAME_WHITEOUT, /* 2 */ 14 | }; 15 | 16 | #define RENAME_WHITEOUT_INDEX 2 17 | 18 | static void check_flag_list(value list) 19 | { 20 | for (/*nothing*/; list != Val_emptylist; list = Field(list, 1)) 21 | { 22 | #if !defined(EXTUNIX_HAVE_RENAME_WHITEOUT) 23 | if (RENAME_WHITEOUT_INDEX == Int_val(Field(list, 0))) 24 | caml_raise_with_string(*caml_named_value("ExtUnix.Not_available"), "RENAME_WHITEOUT"); 25 | #endif 26 | } 27 | } 28 | 29 | CAMLprim value caml_extunix_renameat2(value v_oldfd, value v_oldname, value v_newfd, value v_newname, value v_flags) 30 | { 31 | CAMLparam5(v_oldfd, v_oldname, v_newfd, v_newname, v_flags); 32 | check_flag_list(v_flags); 33 | int oldfd = Int_val(v_oldfd), newfd = Int_val(v_newfd); 34 | char *oldname = caml_stat_strdup(String_val(v_oldname)), 35 | *newname = caml_stat_strdup(String_val(v_newname)); 36 | int flags = caml_convert_flag_list(v_flags, rename_flags_table); 37 | caml_enter_blocking_section(); 38 | int ret = renameat2(oldfd, oldname, newfd, newname, flags); 39 | caml_leave_blocking_section(); 40 | caml_stat_free(oldname); 41 | caml_stat_free(newname); 42 | if (ret != 0) caml_uerror("renameat2", v_oldname); 43 | CAMLreturn(Val_unit); 44 | } 45 | #endif 46 | -------------------------------------------------------------------------------- /src/resource.c: -------------------------------------------------------------------------------- 1 | /******************************************************************************/ 2 | /* ocaml-posix-resource: POSIX resource operations */ 3 | /* */ 4 | /* Copyright (C) 2009 Sylvain Le Gall */ 5 | /* */ 6 | /* This library is free software; you can redistribute it and/or modify it */ 7 | /* under the terms of the GNU Lesser General Public License as published by */ 8 | /* the Free Software Foundation; either version 2.1 of the License, or (at */ 9 | /* your option) any later version; with the OCaml static compilation */ 10 | /* exception. */ 11 | /* */ 12 | /* This library is distributed in the hope that it will be useful, but */ 13 | /* WITHOUT ANY WARRANTY; without even the implied warranty of */ 14 | /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser */ 15 | /* General Public License for more details. */ 16 | /* */ 17 | /* You should have received a copy of the GNU Lesser General Public License */ 18 | /* along with this library; if not, write to the Free Software Foundation, */ 19 | /* Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ 20 | /******************************************************************************/ 21 | 22 | /* 23 | * POSIX resource for OCaml 24 | * 25 | * Author: Sylvain Le Gall 26 | * 27 | */ 28 | 29 | #define EXTUNIX_WANT_RESOURCE 30 | #include "config.h" 31 | 32 | #if defined(EXTUNIX_HAVE_RESOURCE) 33 | 34 | static void decode_which_prio(value vwprio, int *pwhich, id_t *pwho) 35 | { 36 | CAMLparam1(vwprio); 37 | 38 | assert(Is_block(vwprio) && Wosize_val(vwprio) == 1); 39 | 40 | *pwho=Long_val(Field(vwprio, 0)); 41 | 42 | switch(Tag_val(vwprio)) 43 | { 44 | case 0: 45 | *pwhich = PRIO_PROCESS; 46 | break; 47 | case 1: 48 | *pwhich = PRIO_PGRP; 49 | break; 50 | case 2: 51 | *pwhich = PRIO_USER; 52 | break; 53 | default: 54 | caml_invalid_argument("decode_which_prio"); 55 | } 56 | 57 | CAMLreturn0; 58 | } 59 | 60 | CAMLprim value caml_extunix_getpriority(value vwprio) 61 | { 62 | CAMLparam1(vwprio); 63 | int which; 64 | id_t who; 65 | int res = -1; 66 | 67 | decode_which_prio(vwprio, &which, &who); 68 | 69 | errno = 0; 70 | res = getpriority(which, who); 71 | if (res == -1 && errno != 0) 72 | { 73 | caml_uerror("getpriority", Nothing); 74 | } 75 | 76 | CAMLreturn(Val_int(res)); 77 | } 78 | 79 | CAMLprim value caml_extunix_setpriority(value vwprio, value vprio) 80 | { 81 | CAMLparam2(vwprio, vprio); 82 | int which; 83 | id_t who; 84 | 85 | decode_which_prio(vwprio, &which, &who); 86 | 87 | if (setpriority(which, who, Int_val(vprio)) != 0) 88 | { 89 | caml_uerror("setpriority", Nothing); 90 | } 91 | 92 | CAMLreturn(Val_unit); 93 | } 94 | 95 | #define RESOURCE_LEN 7 96 | 97 | static int resource_map[RESOURCE_LEN] = 98 | { 99 | RLIMIT_CORE, 100 | RLIMIT_CPU, 101 | RLIMIT_DATA, 102 | RLIMIT_FSIZE, 103 | RLIMIT_NOFILE, 104 | RLIMIT_STACK, 105 | RLIMIT_AS 106 | }; 107 | 108 | static int decode_resource(value vrsrc) 109 | { 110 | CAMLparam1(vrsrc); 111 | assert(Int_val(vrsrc) < RESOURCE_LEN && Int_val(vrsrc) >= 0); 112 | CAMLreturnT(int, resource_map[Int_val(vrsrc)]); 113 | } 114 | 115 | static value encode_limit(rlim_t v) 116 | { 117 | CAMLparam0(); 118 | CAMLlocal1(vres); 119 | 120 | if (v == RLIM_INFINITY) 121 | { 122 | vres = Val_int(0); 123 | } 124 | else 125 | { 126 | vres = caml_alloc(1, 0); 127 | Store_field(vres, 0, caml_copy_int64(v)); 128 | } 129 | 130 | CAMLreturn(vres); 131 | } 132 | 133 | static rlim_t decode_limit(value vchglimit) 134 | { 135 | CAMLparam1(vchglimit); 136 | rlim_t res = RLIM_INFINITY; 137 | 138 | if (Is_block(vchglimit)) 139 | { 140 | assert(Tag_val(vchglimit) == 0); 141 | res = Int64_val(Field(vchglimit, 0)); 142 | } 143 | 144 | CAMLreturnT(rlim_t, res); 145 | } 146 | 147 | CAMLprim value caml_extunix_getrlimit(value vrsrc) 148 | { 149 | CAMLparam1(vrsrc); 150 | CAMLlocal1(vres); 151 | struct rlimit rlmt; 152 | 153 | if (getrlimit(decode_resource(vrsrc), &rlmt) != 0) 154 | { 155 | caml_uerror("getrlimit", Nothing); 156 | } 157 | 158 | vres = caml_alloc(2, 0); 159 | Store_field(vres, 0, encode_limit(rlmt.rlim_cur)); 160 | Store_field(vres, 1, encode_limit(rlmt.rlim_max)); 161 | 162 | CAMLreturn(vres); 163 | } 164 | 165 | #pragma GCC diagnostic push 166 | #pragma GCC diagnostic ignored "-Wmissing-field-initializers" 167 | 168 | CAMLprim value caml_extunix_setrlimit(value vrsrc, value vslimit, value vhlimit) 169 | { 170 | CAMLparam3(vrsrc, vslimit, vhlimit); 171 | struct rlimit rlmt = { 0 }; 172 | 173 | rlmt.rlim_cur = decode_limit(vslimit); 174 | rlmt.rlim_max = decode_limit(vhlimit); 175 | 176 | if (setrlimit(decode_resource(vrsrc), &rlmt) != 0) 177 | { 178 | caml_uerror("setrlimit", Nothing); 179 | } 180 | 181 | CAMLreturn(Val_unit); 182 | } 183 | 184 | #pragma GCC diagnostic pop 185 | 186 | #endif /* EXTUNIX_HAVE_RESOURCE */ 187 | 188 | -------------------------------------------------------------------------------- /src/sendmsg.c: -------------------------------------------------------------------------------- 1 | /* Copyright © 2012 Andre Nathan */ 2 | 3 | /* 4 | * These functions are adapted from Stevens, Fenner and Rudoff, UNIX Network 5 | * Programming, Volume 1, Third Edition. We use CMSG_LEN instead of CMSG_SPACE 6 | * for the msg_controllen field of struct msghdr to avoid breaking LP64 7 | * systems (cf. Postfix source code). 8 | */ 9 | 10 | #define EXTUNIX_WANT_SENDMSG 11 | 12 | #include "config.h" 13 | 14 | #if defined(EXTUNIX_HAVE_SENDMSG) 15 | 16 | CAMLprim value caml_extunix_sendmsg(value fd_val, value sendfd_val, value data_val) 17 | { 18 | CAMLparam3(fd_val, sendfd_val, data_val); 19 | CAMLlocal1(data); 20 | size_t datalen; 21 | struct msghdr msg; 22 | struct iovec iov[1]; 23 | int fd = Int_val(fd_val); 24 | ssize_t ret; 25 | char *buf; 26 | 27 | #if defined(CMSG_SPACE) 28 | union { 29 | struct cmsghdr cmsg; /* for alignment */ 30 | char control[CMSG_SPACE(sizeof(int))]; /* sizeof sendfd */ 31 | } control_un; 32 | #endif 33 | 34 | memset(&msg, 0, sizeof msg); 35 | 36 | if (sendfd_val != Val_none) 37 | { 38 | int sendfd = Int_val(Some_val(sendfd_val)); 39 | #if defined(CMSG_SPACE) 40 | struct cmsghdr *cmsgp; 41 | 42 | msg.msg_control = control_un.control; 43 | msg.msg_controllen = CMSG_LEN(sizeof sendfd); 44 | 45 | cmsgp = CMSG_FIRSTHDR(&msg); 46 | cmsgp->cmsg_len = CMSG_LEN(sizeof sendfd); 47 | cmsgp->cmsg_level = SOL_SOCKET; 48 | cmsgp->cmsg_type = SCM_RIGHTS; 49 | *(int *)CMSG_DATA(cmsgp) = sendfd; 50 | #else 51 | msg.msg_accrights = (caddr_t)&sendfd; 52 | msg.msg_accrightslen = sizeof sendfd; 53 | #endif 54 | } 55 | 56 | datalen = caml_string_length(data_val); 57 | buf = caml_stat_alloc(datalen); 58 | memcpy(buf, String_val(data_val), datalen); 59 | 60 | iov[0].iov_base = buf; 61 | iov[0].iov_len = datalen; 62 | msg.msg_iov = iov; 63 | msg.msg_iovlen = 1; 64 | 65 | caml_enter_blocking_section(); 66 | ret = sendmsg(fd, &msg, 0); 67 | caml_leave_blocking_section(); 68 | 69 | caml_stat_free(buf); 70 | 71 | if (ret == -1) 72 | caml_uerror("sendmsg", Nothing); 73 | CAMLreturn (Val_unit); 74 | } 75 | 76 | CAMLprim value caml_extunix_recvmsg(value fd_val) 77 | { 78 | CAMLparam1(fd_val); 79 | CAMLlocal2(data, res); 80 | struct msghdr msg; 81 | int fd = Int_val(fd_val); 82 | int recvfd; 83 | ssize_t len; 84 | struct iovec iov[1]; 85 | char buf[4096]; 86 | 87 | #if defined(CMSG_SPACE) 88 | union { 89 | struct cmsghdr cmsg; /* just for alignment */ 90 | char control[CMSG_SPACE(sizeof recvfd)]; 91 | } control_un; 92 | struct cmsghdr *cmsgp; 93 | 94 | memset(&msg, 0, sizeof msg); 95 | msg.msg_control = control_un.control; 96 | msg.msg_controllen = CMSG_LEN(sizeof recvfd); 97 | #else 98 | msg.msg_accrights = (caddr_t)&recvfd; 99 | msg.msg_accrightslen = sizeof recvfd; 100 | #endif 101 | 102 | iov[0].iov_base = buf; 103 | iov[0].iov_len = sizeof buf; 104 | msg.msg_iov = iov; 105 | msg.msg_iovlen = 1; 106 | 107 | caml_enter_blocking_section(); 108 | len = recvmsg(fd, &msg, 0); 109 | caml_leave_blocking_section(); 110 | 111 | if (len == -1) 112 | caml_uerror("recvmsg", Nothing); 113 | 114 | res = caml_alloc(2, 0); 115 | 116 | #if defined(CMSG_SPACE) 117 | cmsgp = CMSG_FIRSTHDR(&msg); 118 | if (cmsgp == NULL) { 119 | Store_field(res, 0, Val_none); 120 | } else { 121 | CAMLlocal1(some_fd); 122 | if (cmsgp->cmsg_len != CMSG_LEN(sizeof recvfd)) 123 | caml_unix_error(EINVAL, "recvmsg", caml_copy_string("wrong descriptor size")); 124 | if (cmsgp->cmsg_level != SOL_SOCKET || cmsgp->cmsg_type != SCM_RIGHTS) 125 | caml_unix_error(EINVAL, "recvmsg", caml_copy_string("invalid protocol")); 126 | some_fd = caml_alloc(1, 0); 127 | Store_field(some_fd, 0, Val_int(*(int *)CMSG_DATA(cmsgp))); 128 | Store_field(res, 0, some_fd); 129 | } 130 | #else 131 | if (msg.msg_accrightslen != sizeof recvfd) { 132 | Store_field(res, 0, Val_none); 133 | } else { 134 | CAMLlocal1(some_fd); 135 | some_fd = caml_alloc(1, 0); 136 | Store_field(some_fd, 0, Val_int(recvfd)); 137 | Store_field(res, 0, some_fd); 138 | } 139 | #endif 140 | 141 | data = caml_alloc_initialized_string(len, buf); 142 | Store_field(res, 1, data); 143 | 144 | CAMLreturn (res); 145 | } 146 | 147 | #endif /* EXTUNIX_HAVE_SENDMSG */ 148 | -------------------------------------------------------------------------------- /src/signalfd.c: -------------------------------------------------------------------------------- 1 | /******************************************************************************/ 2 | /* signalfd stubs */ 3 | /* */ 4 | /* NO COPYRIGHT -- RELEASED INTO THE PUBLIC DOMAIN */ 5 | /* */ 6 | /* Author: Kaustuv Chaudhuri */ 7 | /******************************************************************************/ 8 | 9 | #define EXTUNIX_WANT_SIGNALFD 10 | #include "config.h" 11 | 12 | #if defined(EXTUNIX_HAVE_SIGNALFD) 13 | 14 | extern int caml_convert_signal_number(int signo); 15 | extern int caml_rev_convert_signal_number(int signo); 16 | 17 | CAMLprim 18 | value caml_extunix_signalfd(value vfd, value vsigs, value vflags, value v_unit) 19 | { 20 | CAMLparam4(vfd, vsigs, vflags, v_unit); 21 | int fd = ((Val_none == vfd) ? -1 : Int_val(Some_val(vfd))); 22 | int flags = 0; 23 | int ret = 0; 24 | sigset_t ss; 25 | sigemptyset (&ss); 26 | while (!Is_long (vsigs)) { 27 | int sig = caml_convert_signal_number (Int_val (Field (vsigs, 0))); 28 | if (sigaddset (&ss, sig) < 0) caml_uerror ("sigaddset", Nothing); 29 | vsigs = Field (vsigs, 1); 30 | } 31 | while (!Is_long (vflags)) { 32 | int f = Int_val (Field (vflags, 0)); 33 | if (SFD_NONBLOCK == f) flags |= SFD_NONBLOCK; 34 | if (SFD_CLOEXEC == f) flags |= SFD_CLOEXEC; 35 | vflags = Field (vflags, 1); 36 | } 37 | ret = signalfd (fd, &ss, flags); 38 | if (ret < 0) caml_uerror ("signalfd", Nothing); 39 | CAMLreturn (Val_int (ret)); 40 | } 41 | 42 | /* [HACK] improve these -- bytestream representation is OK */ 43 | static struct custom_operations ssi_ops = { 44 | "signalfd.signalfd_siginfo", 45 | custom_finalize_default, 46 | custom_compare_default, custom_hash_default, 47 | custom_serialize_default, custom_deserialize_default, 48 | #if defined(custom_compare_ext_default) 49 | custom_compare_ext_default, 50 | #endif 51 | #if defined(custom_fixed_length_default) 52 | custom_fixed_length_default, 53 | #endif 54 | }; 55 | 56 | #define SSI_SIZE sizeof(struct signalfd_siginfo) 57 | 58 | CAMLprim 59 | value caml_extunix_signalfd_read(value v_fd) 60 | { 61 | CAMLparam1(v_fd); 62 | CAMLlocal1(vret); 63 | int fd = Int_val(v_fd); 64 | struct signalfd_siginfo ssi; 65 | ssize_t nread = 0; 66 | caml_enter_blocking_section(); 67 | nread = read(fd, &ssi, SSI_SIZE); 68 | caml_leave_blocking_section(); 69 | if (nread != SSI_SIZE) 70 | caml_unix_error(EINVAL,"signalfd_read",Nothing); 71 | vret = caml_alloc_custom(&ssi_ops, SSI_SIZE, 0, 1); 72 | memcpy(Data_custom_val(vret),&ssi,SSI_SIZE); 73 | CAMLreturn(vret); 74 | } 75 | 76 | CAMLprim 77 | value caml_extunix_ssi_signo_sys(value vssi) 78 | { 79 | CAMLparam1(vssi); 80 | struct signalfd_siginfo *ssi = (void *)(Data_custom_val(vssi)); 81 | CAMLreturn(Val_int(caml_rev_convert_signal_number(ssi->ssi_signo))); 82 | } 83 | 84 | #define SSI_GET_FIELD(field,coerce) \ 85 | CAMLprim \ 86 | value caml_extunix_ssi_##field(value vssi) \ 87 | { \ 88 | CAMLparam1(vssi); \ 89 | struct signalfd_siginfo *ssi = (void *)Data_custom_val(vssi); \ 90 | CAMLreturn(coerce(ssi->ssi_##field)); \ 91 | } \ 92 | 93 | SSI_GET_FIELD( signo , caml_copy_int32 ) 94 | SSI_GET_FIELD( errno , caml_copy_int32 ) 95 | SSI_GET_FIELD( code , caml_copy_int32 ) 96 | SSI_GET_FIELD( pid , caml_copy_int32 ) 97 | SSI_GET_FIELD( uid , caml_copy_int32 ) 98 | SSI_GET_FIELD( fd , Val_int ) 99 | SSI_GET_FIELD( tid , caml_copy_int32 ) 100 | SSI_GET_FIELD( band , caml_copy_int32 ) 101 | SSI_GET_FIELD( overrun , caml_copy_int32 ) 102 | SSI_GET_FIELD( trapno , caml_copy_int32 ) 103 | SSI_GET_FIELD( status , caml_copy_int32 ) 104 | SSI_GET_FIELD( int , caml_copy_int32 ) 105 | SSI_GET_FIELD( ptr , caml_copy_int64 ) 106 | SSI_GET_FIELD( utime , caml_copy_int64 ) 107 | SSI_GET_FIELD( stime , caml_copy_int64 ) 108 | SSI_GET_FIELD( addr , caml_copy_int64 ) 109 | 110 | #endif /* EXTUNIX_HAVE_SIGNALFD */ 111 | -------------------------------------------------------------------------------- /src/sockopt.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_SOCKOPT 2 | #define EXTUNIX_WANT_TCP_KEEPIDLE 3 | #define EXTUNIX_WANT_TCP_KEEPCNT 4 | #define EXTUNIX_WANT_TCP_KEEPINTVL 5 | #include "config.h" 6 | 7 | #if defined(EXTUNIX_HAVE_SOCKOPT) 8 | 9 | #ifndef TCP_KEEPCNT 10 | #define TCP_KEEPCNT (-1) 11 | #endif 12 | 13 | #ifndef TCP_KEEPIDLE 14 | #if defined(__APPLE__) && defined(TCP_KEEPALIVE) 15 | #define TCP_KEEPIDLE (TCP_KEEPALIVE) 16 | #else 17 | #define TCP_KEEPIDLE (-1) 18 | #endif 19 | #endif 20 | 21 | #ifndef TCP_KEEPINTVL 22 | #define TCP_KEEPINTVL (-1) 23 | #endif 24 | 25 | #ifndef SO_REUSEPORT 26 | #define SO_REUSEPORT (-1) 27 | #endif 28 | 29 | #ifndef SO_ATTACH_BPF 30 | #define SO_ATTACH_BPF (-1) 31 | #endif 32 | 33 | #ifndef SO_ATTACH_REUSEPORT_EBPF 34 | #define SO_ATTACH_REUSEPORT_EBPF (-1) 35 | #endif 36 | 37 | #ifndef SO_DETACH_FILTER 38 | #define SO_DETACH_FILTER (-1) 39 | #endif 40 | 41 | #ifndef SO_DETACH_BPF 42 | #define SO_DETACH_BPF (-1) 43 | #endif 44 | 45 | #ifndef SO_LOCK_FILTER 46 | #define SO_LOCK_FILTER (-1) 47 | #endif 48 | 49 | struct option { 50 | int opt; 51 | int level; 52 | }; 53 | 54 | static struct option tcp_options[] = { 55 | { TCP_KEEPCNT, IPPROTO_TCP }, 56 | { TCP_KEEPIDLE, IPPROTO_TCP }, 57 | { TCP_KEEPINTVL, IPPROTO_TCP }, 58 | { SO_REUSEPORT, SOL_SOCKET }, 59 | { SO_ATTACH_BPF, SOL_SOCKET }, 60 | { SO_ATTACH_REUSEPORT_EBPF, SOL_SOCKET }, 61 | { SO_DETACH_FILTER, SOL_SOCKET }, 62 | { SO_DETACH_BPF, SOL_SOCKET }, 63 | { SO_LOCK_FILTER, SOL_SOCKET }, 64 | }; 65 | 66 | CAMLprim value caml_extunix_have_sockopt(value k) 67 | { 68 | if (Int_val(k) < 0 || (unsigned int)Int_val(k) >= sizeof(tcp_options) / sizeof(tcp_options[0])) 69 | { 70 | caml_invalid_argument("have_sockopt"); 71 | } 72 | 73 | return Val_bool(tcp_options[Int_val(k)].opt != -1); 74 | } 75 | 76 | CAMLprim value caml_extunix_setsockopt_int(value fd, value k, value v) 77 | { 78 | int optval = Int_val(v); 79 | socklen_t optlen = sizeof(optval); 80 | #ifdef _WIN32 81 | SOCKET s = INVALID_SOCKET; 82 | if (KIND_SOCKET != Descr_kind_val(fd)) 83 | caml_invalid_argument("setsockopt_int"); 84 | s = Socket_val(fd); 85 | #else 86 | int s = Int_val(fd); 87 | #endif 88 | 89 | if (Int_val(k) < 0 || (unsigned int)Int_val(k) >= sizeof(tcp_options) / sizeof(tcp_options[0])) 90 | { 91 | caml_invalid_argument("setsockopt_int"); 92 | } 93 | 94 | if (tcp_options[Int_val(k)].opt == -1) 95 | { 96 | caml_raise_not_found(); 97 | assert(0); 98 | } 99 | 100 | if (0 != setsockopt(s, tcp_options[Int_val(k)].level, tcp_options[Int_val(k)].opt, (void *)&optval, optlen)) 101 | { 102 | #ifdef _WIN32 103 | if (WSAGetLastError() == WSAENOPROTOOPT) { 104 | #else 105 | if (errno == ENOPROTOOPT) { 106 | #endif 107 | caml_raise_not_found(); 108 | assert(0); 109 | } 110 | caml_uerror("setsockopt_int", Nothing); 111 | } 112 | 113 | return Val_unit; 114 | } 115 | 116 | CAMLprim value caml_extunix_getsockopt_int(value fd, value k) 117 | { 118 | int optval; 119 | socklen_t optlen = sizeof(optval); 120 | #ifdef _WIN32 121 | SOCKET s = INVALID_SOCKET; 122 | if (KIND_SOCKET != Descr_kind_val(fd)) 123 | caml_invalid_argument("getsockopt_int"); 124 | s = Socket_val(fd); 125 | #else 126 | int s = Int_val(fd); 127 | #endif 128 | 129 | if (Int_val(k) < 0 || (unsigned int)Int_val(k) >= sizeof(tcp_options) / sizeof(tcp_options[0])) 130 | { 131 | caml_invalid_argument("getsockopt_int"); 132 | } 133 | 134 | if (tcp_options[Int_val(k)].opt == -1) 135 | { 136 | caml_raise_not_found(); 137 | assert(0); 138 | } 139 | 140 | if (0 != getsockopt(s, tcp_options[Int_val(k)].level, tcp_options[Int_val(k)].opt, (void *)&optval, &optlen)) 141 | { 142 | #ifdef _WIN32 143 | if (WSAGetLastError() == WSAENOPROTOOPT) { 144 | #else 145 | if (errno == ENOPROTOOPT) { 146 | #endif 147 | caml_raise_not_found(); 148 | assert(0); 149 | } 150 | caml_uerror("getsockopt_int", Nothing); 151 | } 152 | 153 | return Val_int(optval); 154 | } 155 | 156 | #endif 157 | -------------------------------------------------------------------------------- /src/splice.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_VMSPLICE 3 | #define EXTUNIX_WANT_SPLICE 4 | #define EXTUNIX_WANT_TEE 5 | #include "config.h" 6 | #include "common.h" 7 | 8 | #if defined(EXTUNIX_HAVE_SPLICE) || defined(EXTUNIX_HAVE_TEE) || defined(EXTUNIX_HAVE_VMSPLICE) 9 | static const int splice_flags_table[] = 10 | { 11 | SPLICE_F_MOVE, 12 | SPLICE_F_NONBLOCK, 13 | SPLICE_F_MORE, 14 | SPLICE_F_GIFT 15 | }; 16 | #endif 17 | 18 | #if defined(EXTUNIX_HAVE_SPLICE) 19 | CAMLprim value caml_extunix_splice(value v_fd_in, value v_off_in, value v_fd_out, value v_off_out, value v_len, value v_flags) 20 | { 21 | CAMLparam5(v_fd_in, v_off_in, v_fd_out, v_off_out, v_len); 22 | CAMLxparam1(v_flags); 23 | 24 | unsigned int flags = caml_convert_flag_list(v_flags, splice_flags_table); 25 | int fd_in = Int_val(v_fd_in); 26 | int fd_out = Int_val(v_fd_out); 27 | loff_t off_in; 28 | loff_t off_out; 29 | loff_t* off_in_p = NULL; 30 | loff_t* off_out_p = NULL; 31 | size_t len = Int_val(v_len); 32 | ssize_t ret; 33 | 34 | if(Is_some(v_off_in)) { off_in = Int_val(Some_val(v_off_in)); off_in_p = &off_in; } 35 | if(Is_some(v_off_out)) { off_out = Int_val(Some_val(v_off_out)); off_out_p = &off_out; } 36 | 37 | caml_enter_blocking_section(); 38 | ret = splice(fd_in, off_in_p, fd_out, off_out_p, len, flags); 39 | caml_leave_blocking_section(); 40 | 41 | if (ret == -1) 42 | caml_uerror("splice", Nothing); 43 | 44 | CAMLreturn(Val_long(ret)); 45 | } 46 | 47 | CAMLprim value caml_extunix_splice_bytecode(value * argv, int argn) 48 | { 49 | (void)argn; 50 | return caml_extunix_splice(argv[0], argv[1], argv[2], 51 | argv[3], argv[4], argv[5]); 52 | } 53 | 54 | #endif 55 | 56 | #if defined(EXTUNIX_HAVE_TEE) 57 | 58 | CAMLprim value caml_extunix_tee(value v_fd_in, value v_fd_out, value v_len, value v_flags) 59 | { 60 | CAMLparam4(v_fd_in, v_fd_out, v_len, v_flags); 61 | 62 | unsigned int flags = caml_convert_flag_list(v_flags, splice_flags_table); 63 | int fd_in = Int_val(v_fd_in); 64 | int fd_out = Int_val(v_fd_out); 65 | size_t len = Int_val(v_len); 66 | ssize_t ret; 67 | 68 | caml_enter_blocking_section(); 69 | ret = tee(fd_in, fd_out, len, flags); 70 | caml_leave_blocking_section(); 71 | 72 | if (ret == -1) 73 | caml_uerror("tee", Nothing); 74 | 75 | CAMLreturn(Val_long(ret)); 76 | } 77 | 78 | #endif 79 | 80 | 81 | #if defined(EXTUNIX_HAVE_VMSPLICE) 82 | 83 | CAMLprim value caml_extunixba_vmsplice(value v_fd_out, value v_iov, value v_flags) 84 | { 85 | CAMLparam3(v_fd_out, v_iov, v_flags); 86 | 87 | unsigned int flags = caml_convert_flag_list(v_flags, splice_flags_table); 88 | int fd_out = Int_val(v_fd_out); 89 | int size = Wosize_val(v_iov); 90 | struct iovec* iov = alloca(sizeof(struct iovec) * size); 91 | ssize_t ret; 92 | int i; 93 | value tmp; 94 | struct caml_ba_array* ba; 95 | int offset, length; 96 | 97 | for (i = 0; i < size; i++) 98 | { 99 | tmp = Field(v_iov,i); 100 | /* field 0 is a 'a carray8 (bigarray of 8-bit elements) 101 | field 1 is the offset in the bigarray 102 | field 2 is the length */ 103 | ba = Caml_ba_array_val(Field(tmp,0)); 104 | offset = Int_val(Field(tmp,1)); 105 | length = Int_val(Field(tmp,2)); 106 | if(offset + length > ba->dim[0]) 107 | caml_invalid_argument("vmsplice"); 108 | iov[i].iov_base = (char *) ba->data + offset; 109 | iov[i].iov_len = length; 110 | } 111 | 112 | caml_enter_blocking_section(); 113 | ret = vmsplice(fd_out, iov, size, flags); 114 | caml_leave_blocking_section(); 115 | 116 | if (ret == -1) 117 | caml_uerror("vmsplice", Nothing); 118 | 119 | CAMLreturn(Val_long(ret)); 120 | } 121 | 122 | #endif 123 | -------------------------------------------------------------------------------- /src/statvfs.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_STATVFS 2 | #include "config.h" 3 | 4 | #if defined(EXTUNIX_HAVE_STATVFS) || defined(EXTUNIX_HAVE_FSTATVFS) 5 | 6 | static const int st_flags_table[] = { 7 | #if defined(_WIN32) 8 | FILE_READ_ONLY_VOLUME 9 | #else 10 | ST_RDONLY, ST_NOSUID, ST_NODEV, ST_NOEXEC, ST_SYNCHRONOUS, 11 | ST_MANDLOCK, ST_WRITE, ST_APPEND, ST_IMMUTABLE, ST_NOATIME, 12 | ST_NODIRATIME, ST_RELATIME 13 | #endif 14 | }; 15 | 16 | static value convert_st_flags(unsigned long int f_flag) 17 | { 18 | CAMLparam0(); 19 | CAMLlocal2(list, tmp); 20 | 21 | unsigned int i; 22 | 23 | list = Val_emptylist; 24 | 25 | for (i = 0; i < sizeof(st_flags_table) / sizeof(st_flags_table[0]); i++) 26 | { 27 | if (f_flag & st_flags_table[i]) 28 | { 29 | tmp = caml_alloc_small(2, Tag_cons); 30 | Field(tmp, 0) = Val_int(i); 31 | Field(tmp, 1) = list; 32 | list = tmp; 33 | } 34 | } 35 | CAMLreturn(list); 36 | } 37 | #endif 38 | 39 | #if defined(EXTUNIX_HAVE_STATVFS) && defined(_WIN32) 40 | 41 | #include 42 | 43 | CAMLprim value caml_extunix_statvfs(value v_path) 44 | { 45 | CAMLparam1(v_path); 46 | CAMLlocal1(v_s); 47 | ULONG sectorsPerCluster = 0U, bytesPerSector = 0U, numberOfFreeClusters = 0U, 48 | totalNumberOfClusters = 0U, bsize = 0U, serialNumber = 0U, fileSystemFlags = 0U; 49 | ULONGLONG totalNumberOfFreeBytes = 0ULL; 50 | char_os *path = caml_stat_strdup_to_os(String_val(v_path)); 51 | BOOL rc; 52 | 53 | rc = GetDiskFreeSpace(path, §orsPerCluster, &bytesPerSector, 54 | &numberOfFreeClusters, &totalNumberOfClusters) 55 | && GetDiskFreeSpaceEx(path, NULL, NULL, 56 | (PULARGE_INTEGER) &totalNumberOfFreeBytes) 57 | && GetVolumeInformation(path, NULL, 0, &serialNumber, NULL, 58 | &fileSystemFlags, NULL, 0); 59 | caml_stat_free(path); 60 | 61 | if (!rc) 62 | { 63 | caml_uerror("statvfs", v_path); 64 | } 65 | 66 | bsize = bytesPerSector * sectorsPerCluster; 67 | 68 | v_s = caml_alloc(11, 0); 69 | Store_field(v_s, 0, Val_int(bsize)); /* Filesystem block size */ 70 | /* don't export s->f_frsize */ 71 | Store_field(v_s, 1, caml_copy_int64(totalNumberOfClusters)); /* Size of fs in bsize units */ 72 | Store_field(v_s, 2, caml_copy_int64(totalNumberOfFreeBytes / (ULONGLONG) bsize)); /* Number of free blocks */ 73 | Store_field(v_s, 3, caml_copy_int64(numberOfFreeClusters)); /* Number of free blocks for 74 | unprivileged users */ 75 | Store_field(v_s, 4, caml_copy_int64(LLONG_MAX)); /* Number of inodes */ 76 | Store_field(v_s, 5, caml_copy_int64(LLONG_MAX)); /* Number of free inodes */ 77 | Store_field(v_s, 6, caml_copy_int64(LLONG_MAX)); /* Number of free inodes for 78 | unprivileged users */ 79 | Store_field(v_s, 7, caml_copy_int64((ULONGLONG) serialNumber)); /* Filesystem ID */ 80 | Store_field(v_s, 8, Val_int(fileSystemFlags)); /* Mount flags (raw) */ 81 | Store_field(v_s, 9, convert_st_flags(fileSystemFlags)); /* Mount flags (decoded) */ 82 | Store_field(v_s, 10, Val_int(MAX_PATH)); /* Maximum filename length */ 83 | CAMLreturn(v_s); 84 | } 85 | 86 | #elif (defined(EXTUNIX_HAVE_STATVFS) || defined(EXTUNIX_HAVE_FSTATVFS)) && !defined(_WIN32) 87 | 88 | static value convert(struct statvfs* s) 89 | { 90 | CAMLparam0(); 91 | CAMLlocal1(v_s); 92 | 93 | v_s = caml_alloc(11,0); 94 | 95 | Store_field(v_s,0,Val_int(s->f_bsize)); 96 | /* don't export s->f_frsize */ 97 | Store_field(v_s,1,caml_copy_int64(s->f_blocks)); 98 | Store_field(v_s,2,caml_copy_int64(s->f_bfree)); 99 | Store_field(v_s,3,caml_copy_int64(s->f_bavail)); 100 | Store_field(v_s,4,caml_copy_int64(s->f_files)); 101 | Store_field(v_s,5,caml_copy_int64(s->f_ffree)); 102 | Store_field(v_s,6,caml_copy_int64(s->f_favail)); 103 | Store_field(v_s,7,caml_copy_int64(s->f_fsid)); 104 | Store_field(v_s,8,Val_int(s->f_flag)); 105 | Store_field(v_s,9,convert_st_flags(s->f_flag)); 106 | Store_field(v_s,10,Val_int(s->f_namemax)); 107 | 108 | CAMLreturn(v_s); 109 | } 110 | 111 | #if defined(EXTUNIX_HAVE_STATVFS) 112 | 113 | CAMLprim value caml_extunix_statvfs(value v_path) 114 | { 115 | CAMLparam1(v_path); 116 | struct statvfs s; 117 | 118 | if (0 != statvfs(String_val(v_path), &s)) 119 | { 120 | caml_uerror("statvfs",v_path); 121 | } 122 | 123 | CAMLreturn(convert(&s)); 124 | } 125 | 126 | #endif 127 | #if defined(EXTUNIX_HAVE_STATVFS) 128 | 129 | CAMLprim value caml_extunix_fstatvfs(value v_fd) 130 | { 131 | CAMLparam1(v_fd); 132 | struct statvfs s; 133 | 134 | if (0 != fstatvfs(Int_val(v_fd), &s)) 135 | { 136 | caml_uerror("fstatvfs",Nothing); 137 | } 138 | 139 | CAMLreturn(convert(&s)); 140 | } 141 | 142 | #endif 143 | #endif 144 | -------------------------------------------------------------------------------- /src/stdlib.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_SETENV 2 | #define EXTUNIX_WANT_CLEARENV 3 | #define EXTUNIX_WANT_MKDTEMP 4 | #include "config.h" 5 | 6 | #if defined(EXTUNIX_HAVE_SETENV) 7 | 8 | CAMLprim value caml_extunix_setenv(value v_name, value v_val, value v_overwrite) 9 | { 10 | CAMLparam3(v_name, v_val, v_overwrite); 11 | 12 | if (0 != setenv(String_val(v_name), String_val(v_val), Bool_val(v_overwrite))) 13 | { 14 | caml_uerror("setenv",v_name); 15 | } 16 | 17 | CAMLreturn(Val_unit); 18 | } 19 | 20 | CAMLprim value caml_extunix_unsetenv(value v_name) 21 | { 22 | CAMLparam1(v_name); 23 | 24 | if (0 != unsetenv(String_val(v_name))) 25 | { 26 | caml_uerror("unsetenv",v_name); 27 | } 28 | 29 | CAMLreturn(Val_unit); 30 | } 31 | 32 | #endif 33 | 34 | #if defined(EXTUNIX_HAVE_CLEARENV) 35 | 36 | CAMLprim value caml_extunix_clearenv(value v_unit) 37 | { 38 | UNUSED(v_unit); 39 | if (0 != clearenv()) 40 | { 41 | caml_uerror("clearenv", Nothing); 42 | } 43 | 44 | return Val_unit; 45 | } 46 | 47 | #endif 48 | -------------------------------------------------------------------------------- /src/sysconf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Binding to sysconf 3 | * 4 | * Copyright 2013 5 | * 6 | * License LGPL-2.1 with OCaml linking static exception 7 | * 8 | * author: Roman Vorobets 9 | * 10 | */ 11 | 12 | #define EXTUNIX_WANT_SYSCONF 13 | #include "config.h" 14 | 15 | #if defined(EXTUNIX_HAVE_SYSCONF) 16 | 17 | #ifndef _SC_PHYS_PAGES 18 | #define _SC_PHYS_PAGES (-1) 19 | #endif 20 | 21 | #ifndef _SC_AVPHYS_PAGES 22 | #define _SC_AVPHYS_PAGES (-1) 23 | #endif 24 | 25 | #ifndef _SC_NPROCESSORS_CONF 26 | #define _SC_NPROCESSORS_CONF (-1) 27 | #endif 28 | 29 | #ifndef _SC_NPROCESSORS_ONLN 30 | #define _SC_NPROCESSORS_ONLN (-1) 31 | #endif 32 | 33 | static const int caml_conf_table[] = 34 | { 35 | _SC_ARG_MAX, 36 | _SC_CHILD_MAX, 37 | _SC_HOST_NAME_MAX, 38 | _SC_LOGIN_NAME_MAX, 39 | _SC_CLK_TCK, 40 | _SC_OPEN_MAX, 41 | _SC_PAGESIZE, 42 | _SC_RE_DUP_MAX, 43 | _SC_STREAM_MAX, 44 | _SC_SYMLOOP_MAX, 45 | _SC_TTY_NAME_MAX, 46 | _SC_TZNAME_MAX, 47 | _SC_VERSION, 48 | _SC_LINE_MAX, 49 | _SC_2_VERSION, 50 | _SC_PHYS_PAGES, 51 | _SC_AVPHYS_PAGES, 52 | _SC_NPROCESSORS_CONF, 53 | _SC_NPROCESSORS_ONLN 54 | }; 55 | 56 | CAMLprim value caml_extunix_sysconf(value name) 57 | { 58 | CAMLparam1(name); 59 | long r = -1; 60 | int sc = caml_conf_table[Int_val(name)]; 61 | 62 | if (-1 == sc) 63 | { 64 | caml_raise_not_found(); 65 | assert(0); 66 | } 67 | 68 | r = sysconf(sc); 69 | 70 | if (-1 == r) 71 | { 72 | caml_uerror("sysconf", Nothing); 73 | } 74 | 75 | CAMLreturn(caml_copy_int64(r)); 76 | } 77 | 78 | #endif 79 | -------------------------------------------------------------------------------- /src/sysinfo.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_SYSINFO 3 | #include "config.h" 4 | 5 | #if defined(EXTUNIX_HAVE_SYSINFO) 6 | 7 | static value convert(struct sysinfo* s) 8 | { 9 | CAMLparam0(); 10 | CAMLlocal2(v,v_loads); 11 | 12 | v_loads = caml_alloc_tuple(3); 13 | 14 | Store_field(v_loads, 0, caml_copy_double(s->loads[0] / (float)(1 << SI_LOAD_SHIFT))); 15 | Store_field(v_loads, 1, caml_copy_double(s->loads[1] / (float)(1 << SI_LOAD_SHIFT))); 16 | Store_field(v_loads, 2, caml_copy_double(s->loads[2] / (float)(1 << SI_LOAD_SHIFT))); 17 | 18 | v = caml_alloc_tuple(12); 19 | 20 | Store_field(v, 0, Val_long(s->uptime)); 21 | Store_field(v, 1, v_loads); 22 | Store_field(v, 2, Val_long(s->totalram)); 23 | Store_field(v, 3, Val_long(s->freeram)); 24 | Store_field(v, 4, Val_long(s->sharedram)); 25 | Store_field(v, 5, Val_long(s->bufferram)); 26 | Store_field(v, 6, Val_long(s->totalswap)); 27 | Store_field(v, 7, Val_long(s->freeswap)); 28 | Store_field(v, 8, Val_int(s->procs)); 29 | Store_field(v, 9, Val_long(s->totalhigh)); 30 | Store_field(v, 10, Val_long(s->freehigh)); 31 | Store_field(v, 11, Val_int(s->mem_unit)); 32 | 33 | CAMLreturn(v); 34 | } 35 | 36 | CAMLprim value caml_extunix_sysinfo(value v_unit) 37 | { 38 | CAMLparam1(v_unit); 39 | struct sysinfo s; 40 | 41 | if (0 != sysinfo(&s)) 42 | { 43 | caml_uerror("sysinfo",Nothing); 44 | } 45 | 46 | CAMLreturn(convert(&s)); 47 | } 48 | 49 | CAMLprim value caml_extunix_uptime(value v_unit) 50 | { 51 | struct sysinfo s; 52 | UNUSED(v_unit); 53 | 54 | if (0 != sysinfo(&s)) 55 | { 56 | caml_uerror("sysinfo",Nothing); 57 | } 58 | 59 | return Val_int(s.uptime); 60 | } 61 | 62 | #endif 63 | -------------------------------------------------------------------------------- /src/syslog.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_SYSLOG 2 | #include "config.h" 3 | 4 | #if defined(EXTUNIX_HAVE_SYSLOG) 5 | 6 | static const int mask_table[] = { 7 | LOG_MASK(LOG_EMERG), LOG_MASK(LOG_ALERT), LOG_MASK(LOG_CRIT), 8 | LOG_MASK(LOG_ERR), LOG_MASK(LOG_WARNING), LOG_MASK(LOG_NOTICE), 9 | LOG_MASK(LOG_INFO), LOG_MASK(LOG_DEBUG) 10 | }; 11 | 12 | CAMLprim value caml_extunix_setlogmask(value v_level) 13 | { 14 | CAMLparam1(v_level); 15 | CAMLlocal2(cli, cons); 16 | int mask, nmask; 17 | size_t i; 18 | 19 | mask = caml_convert_flag_list(v_level, mask_table); 20 | 21 | caml_enter_blocking_section(); 22 | nmask = setlogmask(mask); 23 | caml_leave_blocking_section(); 24 | 25 | // generate list from mask (invers of "caml_convert_flag_list") 26 | cli = Val_emptylist; 27 | for (i = 0; i < (sizeof(mask_table) / sizeof(int)); i++) 28 | { 29 | if ((mask_table[i] & nmask) == mask_table[i]) 30 | { 31 | cons = caml_alloc(2, 0); 32 | 33 | Store_field(cons, 0, Val_int(i)); 34 | Store_field(cons, 1, cli); 35 | 36 | cli = cons; 37 | } 38 | } 39 | 40 | CAMLreturn(cli); 41 | } 42 | 43 | static const int option_table[] = { 44 | LOG_PID, LOG_CONS, LOG_NDELAY, LOG_ODELAY, LOG_NOWAIT 45 | }; 46 | 47 | static const int facility_table[] = { 48 | LOG_KERN, LOG_USER, LOG_MAIL, LOG_NEWS, LOG_UUCP, LOG_DAEMON, LOG_AUTH, 49 | LOG_CRON, LOG_LPR, LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3, 50 | LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7 51 | }; 52 | 53 | CAMLprim value caml_extunix_openlog(value v_ident, value v_option, value v_facility) 54 | { 55 | CAMLparam3(v_ident, v_option, v_facility); 56 | int option, facility; 57 | size_t index_facility; 58 | static char *ident = NULL; /* openlog does _not_ store ident -- keep a heap copy */ 59 | 60 | if (NULL != ident) 61 | { 62 | caml_stat_free(ident); 63 | ident = NULL; 64 | } 65 | 66 | ident = (Val_none == v_ident) ? NULL : caml_stat_strdup(String_val(Some_val(v_ident))); 67 | option = caml_convert_flag_list(v_option, option_table); 68 | index_facility = Int_val(v_facility); 69 | assert(index_facility < (sizeof(facility_table) / sizeof(int))); 70 | facility = facility_table[index_facility]; 71 | 72 | openlog(ident, option, facility); 73 | 74 | CAMLreturn(Val_unit); 75 | } 76 | 77 | CAMLprim value caml_extunix_closelog(void) 78 | { 79 | CAMLparam0(); 80 | closelog(); 81 | CAMLreturn(Val_unit); 82 | } 83 | 84 | static const int level_table[] = { 85 | LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, LOG_NOTICE, LOG_INFO, 86 | LOG_DEBUG 87 | }; 88 | 89 | CAMLprim value caml_extunix_syslog(value v_facility, value v_level, value v_string) 90 | { 91 | CAMLparam3(v_facility, v_level, v_string); 92 | int facility, level; 93 | size_t index_level, index_facility; 94 | char *str; 95 | 96 | facility = 0; 97 | if (Val_none != v_facility) 98 | { 99 | index_facility = Int_val(Some_val(v_facility)); 100 | assert(index_facility < (sizeof(facility_table) / sizeof(int))); 101 | facility = facility_table[index_facility]; 102 | } 103 | 104 | index_level = Int_val(v_level); 105 | assert(index_level < (sizeof(level_table) / sizeof(int))); 106 | level = level_table[index_level]; 107 | str = caml_stat_strdup(String_val(v_string)); 108 | 109 | caml_enter_blocking_section(); 110 | syslog(level | facility, "%s", str); 111 | caml_leave_blocking_section(); 112 | 113 | caml_stat_free(str); 114 | 115 | CAMLreturn(Val_unit); 116 | } 117 | 118 | #endif 119 | -------------------------------------------------------------------------------- /src/time.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_STRPTIME 2 | #define EXTUNIX_WANT_STRTIME 3 | #define EXTUNIX_WANT_TIMEZONE 4 | #define EXTUNIX_WANT_TIMEGM 5 | #include "config.h" 6 | 7 | 8 | #if defined(EXTUNIX_HAVE_STRPTIME) 9 | 10 | /* 11 | * http://caml.inria.fr/mantis/view.php?id=3851 12 | * Author: Joshua Smith 13 | */ 14 | 15 | /* from otherlibs/unix/gmtime.c */ 16 | static value alloc_tm(struct tm *tm) 17 | { 18 | value res; 19 | res = caml_alloc_small(9, 0); 20 | Field(res,0) = Val_int(tm->tm_sec); 21 | Field(res,1) = Val_int(tm->tm_min); 22 | Field(res,2) = Val_int(tm->tm_hour); 23 | Field(res,3) = Val_int(tm->tm_mday); 24 | Field(res,4) = Val_int(tm->tm_mon); 25 | Field(res,5) = Val_int(tm->tm_year); 26 | Field(res,6) = Val_int(tm->tm_wday); 27 | Field(res,7) = Val_int(tm->tm_yday); 28 | Field(res,8) = tm->tm_isdst ? Val_true : Val_false; 29 | return res; 30 | } 31 | 32 | #pragma GCC diagnostic push 33 | #pragma GCC diagnostic ignored "-Wmissing-field-initializers" 34 | 35 | CAMLprim value caml_extunix_strptime(value v_fmt, value v_s) 36 | { 37 | struct tm tm = { 0 }; 38 | if (NULL == strptime(String_val(v_s),String_val(v_fmt),&tm)) 39 | caml_unix_error(EINVAL, "strptime", v_s); 40 | return alloc_tm(&tm); 41 | } 42 | 43 | #pragma GCC diagnostic pop 44 | #endif 45 | 46 | #if defined(EXTUNIX_HAVE_STRTIME) || defined(EXTUNIX_HAVE_TIMEGM) 47 | 48 | static void fill_tm(struct tm* tm, value t) 49 | { 50 | tm->tm_sec = Int_val(Field(t, 0)); 51 | tm->tm_min = Int_val(Field(t, 1)); 52 | tm->tm_hour = Int_val(Field(t, 2)); 53 | tm->tm_mday = Int_val(Field(t, 3)); 54 | tm->tm_mon = Int_val(Field(t, 4)); 55 | tm->tm_year = Int_val(Field(t, 5)); 56 | tm->tm_wday = Int_val(Field(t, 6)); 57 | tm->tm_yday = Int_val(Field(t, 7)); 58 | tm->tm_isdst = Bool_val(Field(t, 8)); /* -1 */ 59 | } 60 | 61 | #endif 62 | 63 | #if defined(EXTUNIX_HAVE_STRTIME) 64 | 65 | CAMLprim value caml_extunix_asctime(value v_t) 66 | { 67 | CAMLparam1(v_t); 68 | struct tm tm; 69 | char_os buf[32]; /* user-supplied buffer which should have room for 70 | at least 26 bytes */ 71 | #if defined(_WIN32) 72 | errno_t err; 73 | #endif 74 | 75 | fill_tm(&tm, v_t); 76 | #if defined(_WIN32) 77 | if ((0 != (err = _wasctime_s(buf, sizeof(buf)/sizeof(buf[0]), &tm)))) { 78 | caml_win32_maperr(err); 79 | #else 80 | if (NULL == asctime_r(&tm, buf)) { 81 | #endif 82 | caml_uerror("asctime", Nothing); 83 | } 84 | CAMLreturn(caml_copy_string_of_os(buf)); 85 | } 86 | 87 | CAMLprim value caml_extunix_strftime(value v_fmt, value v_t) 88 | { 89 | CAMLparam2(v_fmt, v_t); 90 | struct tm tm; 91 | char_os buf[256]; 92 | #if defined(_WIN32) 93 | char_os *fmt; 94 | size_t rc; 95 | #endif 96 | 97 | fill_tm(&tm, v_t); 98 | #if defined(_WIN32) 99 | fmt = caml_stat_strdup_to_os(String_val(v_fmt)); 100 | rc = wcsftime(buf,sizeof(buf)/sizeof(buf[0]),fmt,&tm); 101 | caml_stat_free(fmt); 102 | if (0 == rc) 103 | #else 104 | if (0 == strftime(buf,sizeof(buf),String_val(v_fmt),&tm)) 105 | #endif 106 | caml_unix_error(EINVAL, "strftime", v_fmt); 107 | 108 | CAMLreturn(caml_copy_string_of_os(buf)); 109 | } 110 | 111 | CAMLprim value caml_extunix_tzname(value v_isdst) 112 | { 113 | CAMLparam1(v_isdst); 114 | int i = Bool_val(v_isdst) ? 1 : 0; 115 | #if defined(_WIN32) 116 | CAMLlocal1(tzname); 117 | size_t tznameSize; 118 | _tzset(); 119 | if (0 != _get_tzname(&tznameSize, NULL, 0, i)) 120 | caml_unix_error(EINVAL, "tzname", Nothing); 121 | tzname = caml_alloc_string(tznameSize); 122 | if (0 != _get_tzname(&tznameSize, (char *)String_val(tzname), 123 | tznameSize, i)) 124 | caml_unix_error(EINVAL, "tzname", Nothing); 125 | CAMLreturn(tzname); 126 | #else 127 | tzset(); 128 | CAMLreturn(caml_copy_string(tzname[i])); 129 | #endif 130 | } 131 | 132 | #endif 133 | 134 | #if defined(EXTUNIX_HAVE_TIMEZONE) 135 | 136 | CAMLprim value caml_extunix_timezone(value v_unit) 137 | { 138 | CAMLparam1(v_unit); 139 | CAMLlocal1(v); 140 | 141 | #if defined(_WIN32) 142 | long timezone; 143 | int daylight; 144 | _tzset(); 145 | if (0 != _get_timezone(&timezone)) 146 | caml_unix_error(EINVAL, "timezone", Nothing); 147 | if (0 != _get_daylight(&daylight)) 148 | caml_unix_error(EINVAL, "daylight", Nothing); 149 | #else 150 | tzset(); 151 | #endif 152 | 153 | v = caml_alloc_tuple(2); 154 | Store_field(v, 0, Val_long(timezone)); 155 | Store_field(v, 1, Val_bool(daylight != 0)); 156 | CAMLreturn(v); 157 | } 158 | 159 | #endif 160 | 161 | #if defined(EXTUNIX_HAVE_TIMEGM) 162 | 163 | CAMLprim value caml_extunix_timegm(value v_t) 164 | { 165 | CAMLparam1(v_t); 166 | struct tm tm; 167 | time_t t; 168 | 169 | fill_tm(&tm, v_t); 170 | #if defined(_WIN32) 171 | t = _mkgmtime(&tm); 172 | #else 173 | t = timegm(&tm); 174 | #endif 175 | 176 | CAMLreturn(caml_copy_double(t)); 177 | } 178 | 179 | #endif 180 | -------------------------------------------------------------------------------- /src/tty_ioctl.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright : (c) 2010, Stéphane Glondu 3 | */ 4 | 5 | #define EXTUNIX_WANT_TTY_IOCTL 6 | #include "config.h" 7 | 8 | #if defined(EXTUNIX_HAVE_TTY_IOCTL) 9 | 10 | /* FIXME implement separate interface for tcsetattr/tcgetattr */ 11 | CAMLprim value caml_extunix_crtscts(value mlfd) 12 | { 13 | CAMLparam1(mlfd); 14 | struct termios t; 15 | int r, fd = Int_val(mlfd); 16 | 17 | r = tcgetattr(fd, &t); 18 | if (0 == r) { 19 | t.c_cflag |= CRTSCTS; 20 | r = tcsetattr(fd, TCSANOW, &t); 21 | } 22 | if (0 != r) caml_uerror("crtscts",Nothing); 23 | CAMLreturn(Val_unit); 24 | } 25 | 26 | #define TTY_IOCTL_INT(cmd) \ 27 | CAMLprim value caml_extunix_ioctl_##cmd(value v_fd, value v_arg) \ 28 | { \ 29 | CAMLparam2(v_fd, v_arg); \ 30 | int arg = Int_val(v_arg); \ 31 | int r = ioctl(Int_val(v_fd), cmd, &arg); \ 32 | if (r < 0) caml_uerror("ioctl",caml_copy_string(#cmd)); \ 33 | CAMLreturn(Val_unit); \ 34 | } 35 | 36 | CAMLprim value caml_extunix_ioctl_TIOCGWINSZ(value v_fd) 37 | { 38 | CAMLparam1(v_fd); 39 | CAMLlocal1(result); 40 | 41 | struct winsize ws; 42 | 43 | int r = ioctl(Int_val(v_fd), TIOCGWINSZ, &ws); 44 | if (r < 0) { 45 | caml_uerror("ioctl", caml_copy_string("TIOCGWINSZ")); 46 | } 47 | 48 | result = caml_alloc_tuple(4); 49 | Store_field(result, 0, Val_int(ws.ws_col)); 50 | Store_field(result, 1, Val_int(ws.ws_row)); 51 | Store_field(result, 2, Val_int(ws.ws_xpixel)); 52 | Store_field(result, 3, Val_int(ws.ws_ypixel)); 53 | 54 | CAMLreturn(result); 55 | } 56 | 57 | CAMLprim value caml_extunix_ioctl_TIOCMGET(value v_fd) 58 | { 59 | CAMLparam1(v_fd); 60 | int arg = 0; 61 | int r = ioctl(Int_val(v_fd), TIOCMGET, &arg); 62 | if (r < 0) caml_uerror("ioctl",caml_copy_string("TIOCMGET")); 63 | CAMLreturn(Val_int(arg)); 64 | } 65 | 66 | TTY_IOCTL_INT(TIOCMSET) 67 | TTY_IOCTL_INT(TIOCMBIC) 68 | TTY_IOCTL_INT(TIOCMBIS) 69 | 70 | #endif 71 | -------------------------------------------------------------------------------- /src/uname.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_UNAME 3 | #include "config.h" 4 | 5 | #if defined(EXTUNIX_HAVE_UNAME) 6 | 7 | CAMLprim value caml_extunix_uname(value u) 8 | { 9 | struct utsname uname_data; 10 | 11 | CAMLparam1(u); 12 | CAMLlocal2(result, domainname); 13 | 14 | memset(&uname_data, 0, sizeof(uname_data)); 15 | 16 | if (uname(&uname_data) == 0) 17 | { 18 | result = caml_alloc(5, 0); 19 | Store_field(result, 0, caml_copy_string(&(uname_data.sysname[0]))); 20 | Store_field(result, 1, caml_copy_string(&(uname_data.nodename[0]))); 21 | Store_field(result, 2, caml_copy_string(&(uname_data.release[0]))); 22 | Store_field(result, 3, caml_copy_string(&(uname_data.version[0]))); 23 | Store_field(result, 4, caml_copy_string(&(uname_data.machine[0]))); 24 | } 25 | else 26 | { 27 | caml_uerror("uname",Nothing); 28 | } 29 | 30 | CAMLreturn(result); 31 | } 32 | 33 | #endif 34 | 35 | -------------------------------------------------------------------------------- /src/unistd.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_TTYNAME 2 | #define EXTUNIX_WANT_CTERMID 3 | #define EXTUNIX_WANT_PGID 4 | #define EXTUNIX_WANT_SETREUID 5 | #define EXTUNIX_WANT_SETRESUID 6 | #define EXTUNIX_WANT_FCNTL 7 | #define EXTUNIX_WANT_TCPGRP 8 | #define EXTUNIX_WANT_PREAD 9 | #define EXTUNIX_WANT_PWRITE 10 | #define EXTUNIX_WANT_READ 11 | #define EXTUNIX_WANT_WRITE 12 | #define EXTUNIX_WANT_GETTID 13 | #define EXTUNIX_WANT_CHROOT 14 | #include "config.h" 15 | 16 | #if defined(EXTUNIX_HAVE_TTYNAME) 17 | 18 | /* Copyright © 2010 Stéphane Glondu */ 19 | 20 | CAMLprim value caml_extunix_ttyname(value v_fd) 21 | { 22 | CAMLparam1(v_fd); 23 | char *r = ttyname(Int_val(v_fd)); 24 | if (r) { 25 | CAMLreturn(caml_copy_string(r)); 26 | } else { 27 | caml_uerror("ttyname", Nothing); 28 | } 29 | } 30 | 31 | #endif 32 | 33 | #if defined(EXTUNIX_HAVE_CTERMID) 34 | 35 | CAMLprim value caml_extunix_ctermid(value v_unit) 36 | { 37 | char buf[L_ctermid + 1]; 38 | UNUSED(v_unit); 39 | return caml_copy_string(ctermid(buf)); 40 | } 41 | 42 | #endif 43 | 44 | #if defined(EXTUNIX_HAVE_GETTID) 45 | 46 | CAMLprim value caml_extunix_gettid(value v_unit) 47 | { 48 | UNUSED(v_unit); 49 | #if defined(_WIN32) 50 | DWORD tid = 0; 51 | tid = GetCurrentThreadId(); 52 | #elif defined(EXTUNIX_USE_THREADID) 53 | uint64_t tid = 0; 54 | pthread_threadid_np(NULL, &tid); 55 | #elif defined(EXTUNIX_USE_THREAD_SELFID) 56 | pid_t tid = 0; 57 | tid = syscall(SYS_thread_selfid); 58 | #else 59 | pid_t tid = 0; 60 | tid = syscall(SYS_gettid); 61 | #endif 62 | return Val_int((int)tid); /* XXX truncating to int */ 63 | } 64 | 65 | #endif 66 | 67 | #if defined(EXTUNIX_HAVE_PGID) 68 | 69 | CAMLprim value caml_extunix_setpgid(value v_pid, value v_pgid) 70 | { 71 | CAMLparam2(v_pid, v_pgid); 72 | if (0 != setpgid(Int_val(v_pid), Int_val(v_pgid))) 73 | caml_uerror("setpgid",Nothing); 74 | CAMLreturn(Val_unit); 75 | } 76 | 77 | CAMLprim value caml_extunix_getpgid(value v_pid) 78 | { 79 | CAMLparam1(v_pid); 80 | int pgid = getpgid(Int_val(v_pid)); 81 | if (pgid < 0) 82 | caml_uerror("getpgid",Nothing); 83 | CAMLreturn(Val_int(pgid)); 84 | } 85 | 86 | CAMLprim value caml_extunix_getsid(value v_pid) 87 | { 88 | CAMLparam1(v_pid); 89 | int sid = getsid(Int_val(v_pid)); 90 | if (sid < 0) 91 | caml_uerror("getsid",Nothing); 92 | CAMLreturn(Val_int(sid)); 93 | } 94 | 95 | #endif 96 | 97 | #if defined(EXTUNIX_HAVE_SETREUID) 98 | 99 | CAMLprim value caml_extunix_setreuid(value v_ruid, value v_euid) 100 | { 101 | CAMLparam2(v_ruid,v_euid); 102 | int r = setreuid(Int_val(v_ruid), Int_val(v_euid)); 103 | if (r < 0) 104 | caml_uerror("setreuid", Nothing); 105 | CAMLreturn(Val_unit); 106 | } 107 | 108 | CAMLprim value caml_extunix_setregid(value v_rgid, value v_egid) 109 | { 110 | CAMLparam2(v_rgid,v_egid); 111 | int r = setregid(Int_val(v_rgid), Int_val(v_egid)); 112 | if (r < 0) 113 | caml_uerror("setregid", Nothing); 114 | CAMLreturn(Val_unit); 115 | } 116 | 117 | #endif 118 | 119 | #if defined(EXTUNIX_HAVE_SETRESUID) 120 | 121 | CAMLprim value caml_extunix_setresuid(value r, value e, value s) 122 | { 123 | CAMLparam3(r, e, s); 124 | uid_t ruid = Int_val(r); 125 | uid_t euid = Int_val(e); 126 | uid_t suid = Int_val(s); 127 | 128 | if (setresuid(ruid, euid, suid) != 0) 129 | caml_uerror("setresuid", Nothing); 130 | CAMLreturn(Val_unit); 131 | } 132 | 133 | CAMLprim value caml_extunix_setresgid(value r, value e, value s) 134 | { 135 | CAMLparam3(r, e, s); 136 | gid_t rgid = Int_val(r); 137 | gid_t egid = Int_val(e); 138 | gid_t sgid = Int_val(s); 139 | 140 | if (setresgid(rgid, egid, sgid) == -1) 141 | caml_uerror("setresgid", Nothing); 142 | CAMLreturn(Val_unit); 143 | } 144 | 145 | #endif /* EXTUNIX_HAVE_SETRESUID */ 146 | 147 | #if defined(EXTUNIX_HAVE_FCNTL) 148 | 149 | CAMLprim value caml_extunix_is_open_descr(value v_fd) 150 | { 151 | int r = fcntl(Int_val(v_fd), F_GETFL); 152 | if (-1 == r) 153 | { 154 | if (EBADF == errno) return Val_false; 155 | caml_uerror("fcntl", Nothing); 156 | }; 157 | return Val_true; 158 | } 159 | 160 | #endif 161 | 162 | #if defined(EXTUNIX_HAVE_TCPGRP) 163 | 164 | CAMLprim value caml_extunix_tcgetpgrp(value v_fd) 165 | { 166 | int pgid = tcgetpgrp(Int_val(v_fd)); 167 | if (-1 == pgid) 168 | caml_uerror("tcgetpgrp", Nothing); 169 | return Val_int(pgid); 170 | } 171 | 172 | CAMLprim value caml_extunix_tcsetpgrp(value v_fd, value v_pgid) 173 | { 174 | int r = tcsetpgrp(Int_val(v_fd), Int_val(v_pgid)); 175 | if (-1 == r) 176 | caml_uerror("tcsetpgrp", Nothing); 177 | return Val_int(r); 178 | } 179 | 180 | #endif 181 | 182 | enum mode_bits { 183 | BIT_ONCE = 1 << 0, 184 | BIT_NOERROR = 1 << 1, 185 | BIT_NOINTR = 1 << 2 186 | }; 187 | 188 | #if defined(EXTUNIX_HAVE_PREAD) 189 | 190 | /* Copyright © 2012 Goswin von Brederlow */ 191 | 192 | CAMLprim value caml_extunix_pread_common(value v_fd, off_t off, value v_buf, value v_ofs, value v_len, int mode) { 193 | CAMLparam4(v_fd, v_buf, v_ofs, v_len); 194 | ssize_t ret; 195 | size_t fd = Int_val(v_fd); 196 | size_t ofs = Long_val(v_ofs); 197 | size_t len = Long_val(v_len); 198 | size_t processed = 0; 199 | char iobuf[UNIX_BUFFER_SIZE]; 200 | 201 | while(len > 0) { 202 | size_t numbytes = (len > UNIX_BUFFER_SIZE) ? UNIX_BUFFER_SIZE : len; 203 | caml_enter_blocking_section(); 204 | ret = pread(fd, iobuf, numbytes, off); 205 | caml_leave_blocking_section(); 206 | if (ret == 0) break; 207 | if (ret == -1) { 208 | if (errno == EINTR && (mode & BIT_NOINTR)) continue; 209 | if (processed > 0) { 210 | if (errno == EAGAIN || errno == EWOULDBLOCK) break; 211 | if (mode & BIT_NOERROR) break; 212 | } 213 | caml_uerror("pread", Nothing); 214 | } 215 | memcpy(&Byte(v_buf, ofs), iobuf, ret); 216 | processed += ret; 217 | off += ret; 218 | ofs += ret; 219 | len -= ret; 220 | if (mode & BIT_ONCE) break; 221 | } 222 | 223 | CAMLreturn(Val_long(processed)); 224 | } 225 | 226 | value caml_extunix_all_pread(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 227 | { 228 | off_t off = Long_val(v_off); 229 | return caml_extunix_pread_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOINTR); 230 | } 231 | 232 | value caml_extunix_single_pread(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 233 | { 234 | off_t off = Long_val(v_off); 235 | return caml_extunix_pread_common(v_fd, off, v_buf, v_ofs, v_len, BIT_ONCE); 236 | } 237 | 238 | value caml_extunix_pread(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 239 | { 240 | off_t off = Long_val(v_off); 241 | return caml_extunix_pread_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOINTR | BIT_NOERROR); 242 | } 243 | 244 | value caml_extunix_intr_pread(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 245 | { 246 | off_t off = Long_val(v_off); 247 | return caml_extunix_pread_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOERROR); 248 | } 249 | 250 | value caml_extunix_all_pread64(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 251 | { 252 | off_t off = Int64_val(v_off); 253 | return caml_extunix_pread_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOINTR); 254 | } 255 | 256 | value caml_extunix_single_pread64(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 257 | { 258 | off_t off = Int64_val(v_off); 259 | return caml_extunix_pread_common(v_fd, off, v_buf, v_ofs, v_len, BIT_ONCE); 260 | } 261 | 262 | value caml_extunix_pread64(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 263 | { 264 | off_t off = Int64_val(v_off); 265 | return caml_extunix_pread_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOINTR | BIT_NOERROR); 266 | } 267 | 268 | value caml_extunix_intr_pread64(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 269 | { 270 | off_t off = Int64_val(v_off); 271 | return caml_extunix_pread_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOERROR); 272 | } 273 | #endif 274 | 275 | #if defined(EXTUNIX_HAVE_PWRITE) 276 | 277 | /* Copyright © 2012 Goswin von Brederlow */ 278 | 279 | CAMLprim value caml_extunix_pwrite_common(value v_fd, off_t off, value v_buf, value v_ofs, value v_len, int mode) { 280 | CAMLparam4(v_fd, v_buf, v_ofs, v_len); 281 | ssize_t ret; 282 | size_t fd = Int_val(v_fd); 283 | size_t ofs = Long_val(v_ofs); 284 | size_t len = Long_val(v_len); 285 | size_t processed = 0; 286 | char iobuf[UNIX_BUFFER_SIZE]; 287 | 288 | while(len > 0) { 289 | size_t numbytes = (len > UNIX_BUFFER_SIZE) ? UNIX_BUFFER_SIZE : len; 290 | memcpy(iobuf, &Byte(v_buf, ofs), numbytes); 291 | caml_enter_blocking_section(); 292 | ret = pwrite(fd, iobuf, numbytes, off); 293 | caml_leave_blocking_section(); 294 | if (ret == 0) break; 295 | if (ret == -1) { 296 | if (errno == EINTR && (mode & BIT_NOINTR)) continue; 297 | if (processed > 0){ 298 | if (errno == EAGAIN || errno == EWOULDBLOCK) break; 299 | if (mode & BIT_NOERROR) break; 300 | } 301 | caml_uerror("pwrite", Nothing); 302 | } 303 | processed += ret; 304 | off += ret; 305 | ofs += ret; 306 | len -= ret; 307 | if (mode & BIT_ONCE) break; 308 | } 309 | 310 | CAMLreturn(Val_long(processed)); 311 | } 312 | 313 | value caml_extunix_all_pwrite(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 314 | { 315 | off_t off = Long_val(v_off); 316 | return caml_extunix_pwrite_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOINTR); 317 | } 318 | 319 | value caml_extunix_single_pwrite(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 320 | { 321 | off_t off = Long_val(v_off); 322 | return caml_extunix_pwrite_common(v_fd, off, v_buf, v_ofs, v_len, BIT_ONCE); 323 | } 324 | 325 | value caml_extunix_pwrite(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 326 | { 327 | off_t off = Long_val(v_off); 328 | return caml_extunix_pwrite_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOINTR | BIT_NOERROR); 329 | } 330 | 331 | value caml_extunix_intr_pwrite(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 332 | { 333 | off_t off = Long_val(v_off); 334 | return caml_extunix_pwrite_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOERROR); 335 | } 336 | 337 | value caml_extunix_all_pwrite64(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 338 | { 339 | off_t off = Int64_val(v_off); 340 | return caml_extunix_pwrite_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOINTR); 341 | } 342 | 343 | value caml_extunix_single_pwrite64(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 344 | { 345 | off_t off = Int64_val(v_off); 346 | return caml_extunix_pwrite_common(v_fd, off, v_buf, v_ofs, v_len, BIT_ONCE); 347 | } 348 | 349 | value caml_extunix_pwrite64(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 350 | { 351 | off_t off = Int64_val(v_off); 352 | return caml_extunix_pwrite_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOINTR | BIT_NOERROR); 353 | } 354 | 355 | value caml_extunix_intr_pwrite64(value v_fd, value v_off, value v_buf, value v_ofs, value v_len) 356 | { 357 | off_t off = Int64_val(v_off); 358 | return caml_extunix_pwrite_common(v_fd, off, v_buf, v_ofs, v_len, BIT_NOERROR); 359 | } 360 | #endif 361 | 362 | #if defined(EXTUNIX_HAVE_READ) 363 | 364 | /* Copyright © 2012 Goswin von Brederlow */ 365 | 366 | CAMLprim value caml_extunix_read_common(value v_fd, value v_buf, value v_ofs, value v_len, int mode) { 367 | CAMLparam4(v_fd, v_buf, v_ofs, v_len); 368 | ssize_t ret; 369 | size_t fd = Int_val(v_fd); 370 | size_t ofs = Long_val(v_ofs); 371 | size_t len = Long_val(v_len); 372 | size_t processed = 0; 373 | char iobuf[UNIX_BUFFER_SIZE]; 374 | 375 | while(len > 0) { 376 | size_t numbytes = (len > UNIX_BUFFER_SIZE) ? UNIX_BUFFER_SIZE : len; 377 | caml_enter_blocking_section(); 378 | ret = read(fd, iobuf, numbytes); 379 | caml_leave_blocking_section(); 380 | if (ret == 0) break; 381 | if (ret == -1) { 382 | if (errno == EINTR && (mode & BIT_NOINTR)) continue; 383 | if (processed > 0) { 384 | if (errno == EAGAIN || errno == EWOULDBLOCK) break; 385 | if (mode & BIT_NOERROR) break; 386 | } 387 | caml_uerror("read", Nothing); 388 | } 389 | memcpy(&Byte(v_buf, ofs), iobuf, ret); 390 | processed += ret; 391 | ofs += ret; 392 | len -= ret; 393 | if (mode & BIT_ONCE) break; 394 | } 395 | 396 | CAMLreturn(Val_long(processed)); 397 | } 398 | 399 | value caml_extunix_all_read(value v_fd, value v_buf, value v_ofs, value v_len) 400 | { 401 | return caml_extunix_read_common(v_fd, v_buf, v_ofs, v_len, BIT_NOINTR); 402 | } 403 | 404 | value caml_extunix_single_read(value v_fd, value v_buf, value v_ofs, value v_len) 405 | { 406 | return caml_extunix_read_common(v_fd, v_buf, v_ofs, v_len, BIT_ONCE); 407 | } 408 | 409 | value caml_extunix_read(value v_fd, value v_buf, value v_ofs, value v_len) 410 | { 411 | return caml_extunix_read_common(v_fd, v_buf, v_ofs, v_len, BIT_NOINTR | BIT_NOERROR); 412 | } 413 | 414 | value caml_extunix_intr_read(value v_fd, value v_buf, value v_ofs, value v_len) 415 | { 416 | return caml_extunix_read_common(v_fd, v_buf, v_ofs, v_len, BIT_NOERROR); 417 | } 418 | #endif 419 | 420 | #if defined(EXTUNIX_HAVE_WRITE) 421 | 422 | /* Copyright © 2012 Goswin von Brederlow */ 423 | 424 | CAMLprim value caml_extunix_write_common(value v_fd, value v_buf, value v_ofs, value v_len, int mode) { 425 | CAMLparam4(v_fd, v_buf, v_ofs, v_len); 426 | ssize_t ret; 427 | size_t fd = Int_val(v_fd); 428 | size_t ofs = Long_val(v_ofs); 429 | size_t len = Long_val(v_len); 430 | size_t processed = 0; 431 | char iobuf[UNIX_BUFFER_SIZE]; 432 | 433 | while(len > 0) { 434 | size_t numbytes = (len > UNIX_BUFFER_SIZE) ? UNIX_BUFFER_SIZE : len; 435 | memcpy(iobuf, &Byte(v_buf, ofs), numbytes); 436 | caml_enter_blocking_section(); 437 | ret = write(fd, iobuf, numbytes); 438 | caml_leave_blocking_section(); 439 | if (ret == 0) break; 440 | if (ret == -1) { 441 | if (errno == EINTR && (mode & BIT_NOINTR)) continue; 442 | if (processed > 0){ 443 | if (errno == EAGAIN || errno == EWOULDBLOCK) break; 444 | if (mode & BIT_NOERROR) break; 445 | } 446 | caml_uerror("write", Nothing); 447 | } 448 | processed += ret; 449 | ofs += ret; 450 | len -= ret; 451 | if (mode & BIT_ONCE) break; 452 | } 453 | 454 | CAMLreturn(Val_long(processed)); 455 | } 456 | 457 | value caml_extunix_all_write(value v_fd, value v_buf, value v_ofs, value v_len) 458 | { 459 | return caml_extunix_write_common(v_fd, v_buf, v_ofs, v_len, BIT_NOINTR); 460 | } 461 | 462 | value caml_extunix_single_write(value v_fd, value v_buf, value v_ofs, value v_len) 463 | { 464 | return caml_extunix_write_common(v_fd, v_buf, v_ofs, v_len, BIT_ONCE); 465 | } 466 | 467 | value caml_extunix_write(value v_fd, value v_buf, value v_ofs, value v_len) 468 | { 469 | return caml_extunix_write_common(v_fd, v_buf, v_ofs, v_len, BIT_NOINTR | BIT_NOERROR); 470 | } 471 | 472 | value caml_extunix_intr_write(value v_fd, value v_buf, value v_ofs, value v_len) 473 | { 474 | return caml_extunix_write_common(v_fd, v_buf, v_ofs, v_len, BIT_NOERROR); 475 | } 476 | #endif 477 | 478 | #if defined(EXTUNIX_HAVE_CHROOT) 479 | 480 | CAMLprim value caml_extunix_chroot(value v_path) 481 | { 482 | CAMLparam1(v_path); 483 | int ret; 484 | char* p_path = caml_stat_strdup(String_val(v_path)); 485 | 486 | caml_enter_blocking_section(); 487 | ret = chroot(p_path); 488 | caml_leave_blocking_section(); 489 | 490 | caml_stat_free(p_path); 491 | 492 | if (ret != 0) caml_uerror("chroot", v_path); 493 | CAMLreturn(Val_unit); 494 | } 495 | 496 | #endif 497 | -------------------------------------------------------------------------------- /src/unshare.c: -------------------------------------------------------------------------------- 1 | 2 | #define EXTUNIX_WANT_UNSHARE 3 | #include "config.h" 4 | 5 | #if defined(EXTUNIX_HAVE_UNSHARE) 6 | 7 | static const int umountflags_table[] = { 8 | CLONE_FS, CLONE_FILES, CLONE_NEWNS, CLONE_SYSVSEM, CLONE_NEWUTS, 9 | CLONE_NEWIPC, CLONE_NEWUSER, CLONE_NEWPID, CLONE_NEWNET 10 | }; 11 | 12 | CAMLprim value caml_extunix_unshare(value v_cloneflags) 13 | { 14 | CAMLparam1(v_cloneflags); 15 | int ret; 16 | 17 | int p_cloneflags = caml_convert_flag_list(v_cloneflags, umountflags_table); 18 | 19 | caml_enter_blocking_section(); 20 | ret = unshare(p_cloneflags); 21 | caml_leave_blocking_section(); 22 | 23 | if (ret != 0) caml_uerror("unshare", Nothing); 24 | CAMLreturn(Val_unit); 25 | } 26 | 27 | #endif 28 | 29 | -------------------------------------------------------------------------------- /src/wait4.c: -------------------------------------------------------------------------------- 1 | #define EXTUNIX_WANT_WAIT4 2 | #include "config.h" 3 | 4 | #if defined(EXTUNIX_HAVE_WAIT4) 5 | 6 | static value alloc_wait4_return(int pid, int status, struct rusage *rusage) { 7 | CAMLparam0(); 8 | CAMLlocal3(res, st, ru); 9 | 10 | if (pid == 0) 11 | status = 0; 12 | 13 | if (WIFEXITED(status)) { 14 | st = caml_alloc_small(1, 0); 15 | Store_field(st, 0, Val_int(WEXITSTATUS(status))); 16 | } else if (WIFSTOPPED(status)) { 17 | st = caml_alloc_small(1, 2); 18 | Store_field(st, 0, 19 | Val_int(caml_rev_convert_signal_number(WSTOPSIG(status)))); 20 | } else { 21 | st = caml_alloc_small(1, 1); 22 | Store_field(st, 0, 23 | Val_int(caml_rev_convert_signal_number(WTERMSIG(status)))); 24 | } 25 | 26 | ru = caml_alloc(3, 0); 27 | Store_field(ru, 0, 28 | caml_copy_double((double)rusage->ru_utime.tv_sec + 29 | (double)rusage->ru_utime.tv_usec / 1e6)); 30 | Store_field(ru, 1, 31 | caml_copy_double((double)rusage->ru_stime.tv_sec + 32 | (double)rusage->ru_stime.tv_usec / 1e6)); 33 | Store_field(ru, 2, caml_copy_int64(rusage->ru_maxrss)); 34 | 35 | res = caml_alloc_tuple(3); 36 | Store_field(res, 0, Val_int(pid)); 37 | Store_field(res, 1, st); 38 | Store_field(res, 2, ru); 39 | 40 | CAMLreturn(res); 41 | } 42 | 43 | static const int wait_flag_table[] = {WNOHANG, WUNTRACED}; 44 | 45 | CAMLprim value caml_extunix_wait4(value vwait_flags, value vpid_req) { 46 | CAMLparam2(vwait_flags, vpid_req); 47 | int pid, wstatus, options; 48 | struct rusage rusage; 49 | int pid_req = Int_val(vpid_req); 50 | 51 | options = caml_convert_flag_list(vwait_flags, wait_flag_table); 52 | caml_enter_blocking_section(); 53 | pid = wait4(pid_req, &wstatus, options, &rusage); 54 | caml_leave_blocking_section(); 55 | if (pid == -1) 56 | caml_uerror("wait4", Nothing); 57 | CAMLreturn(alloc_wait4_return(pid, wstatus, &rusage)); 58 | } 59 | #endif 60 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names test testba) 3 | (libraries extunix ounit2 str)) 4 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | open OUnit 4 | open ExtUnix.All 5 | 6 | let with_unix_error f () = 7 | try 8 | f () 9 | with 10 | | Unix.Unix_error(e,f,a) -> 11 | let message = sprintf "Unix_error : %s(%s) : %s" f a (Unix.error_message e) in 12 | skip_if (e = Unix.ENOSYS) message; (* libc may raise Not implemented, not an error in extunix *) 13 | assert_failure message 14 | 15 | let require feature = 16 | match have feature with 17 | | None -> assert false 18 | | Some present -> skip_if (not present) (sprintf "%S is not available" feature) 19 | 20 | let printer x = x 21 | 22 | let test_eventfd () = 23 | require "eventfd"; 24 | let e = eventfd 2 in 25 | assert_equal 2L (eventfd_read e); 26 | eventfd_write e 3L; 27 | assert_equal 3L (eventfd_read e) 28 | 29 | let test_uname () = 30 | require "uname"; 31 | let t = uname () in 32 | let _s: string = Uname.to_string t in 33 | () 34 | 35 | let test_fadvise () = 36 | require "fadvise"; 37 | let (name,ch) = Filename.open_temp_file "extunix" "test" in 38 | try 39 | fadvise (Unix.descr_of_out_channel ch) 0 0 POSIX_FADV_NORMAL; 40 | LargeFile.fadvise (Unix.descr_of_out_channel ch) 0L 0L POSIX_FADV_SEQUENTIAL; 41 | close_out ch; 42 | Unix.unlink name 43 | with exn -> close_out_noerr ch; Unix.unlink name; raise exn 44 | 45 | let test_fallocate () = 46 | require "fallocate"; 47 | let (name,ch) = Filename.open_temp_file "extunix" "test" in 48 | try 49 | let fd = Unix.descr_of_out_channel ch in 50 | fallocate fd 0 1; 51 | LargeFile.fallocate fd 1L 1L; 52 | assert_equal (Unix.fstat fd).Unix.st_size 2; 53 | close_out_noerr ch; 54 | Unix.unlink name 55 | with exn -> close_out_noerr ch; Unix.unlink name; raise exn 56 | 57 | (* Copied from oUnit.ml *) 58 | (* Utility function to manipulate test *) 59 | let rec test_decorate g tst = 60 | match tst with 61 | | TestCase f -> 62 | TestCase (g f) 63 | | TestList tst_lst -> 64 | TestList (List.map (test_decorate g) tst_lst) 65 | | TestLabel (str, tst) -> 66 | TestLabel (str, test_decorate g tst) 67 | 68 | let test_unistd = 69 | [ 70 | "ttyname" >:: begin fun () -> 71 | require "ttyname"; 72 | if Unix.isatty Unix.stdin then ignore (ttyname Unix.stdin); 73 | if Unix.isatty Unix.stdout then ignore (ttyname Unix.stdout); 74 | end; 75 | "ctermid" >:: (fun () -> require "ctermid"; ignore (ctermid ())); 76 | "pgid" >:: begin fun () -> 77 | require "getpgid"; 78 | assert_equal (getsid 0) (getsid (Unix.getpid ())); 79 | let pgid = getpgid 0 in 80 | setpgid 0 0; 81 | assert_equal (getpgid 0) (Unix.getpid ()); 82 | setpgid 0 pgid; 83 | assert_equal (getpgid 0) pgid; 84 | end; 85 | "fcntl" >:: begin fun () -> 86 | require "is_open_descr"; 87 | assert (is_open_descr Unix.stdin); 88 | assert (is_open_descr Unix.stdout); 89 | end; 90 | "int_of_file_descr" >:: begin fun () -> 91 | try 92 | assert (Unix.stdout = (file_descr_of_int (int_of_file_descr Unix.stdout))) 93 | with 94 | Not_available _ -> skip_if true "int_of_file_descr" 95 | end 96 | ] 97 | 98 | let test_realpath () = 99 | require "realpath"; 100 | if Sys.win32 then begin 101 | assert_equal ~printer (Unix.getcwd ()) (realpath {|.\|}); 102 | assert_equal ~printer (Unix.getcwd ()) (realpath {|.\.\.\\.\|}); 103 | assert_equal ~printer {|C:\|} (realpath {|C:\\\|}); 104 | assert_equal ~printer {|C:\|} (realpath {|C:\..\..\|}) 105 | end else begin 106 | assert_equal ~printer (Unix.getcwd ()) (realpath "."); 107 | assert_equal ~printer (Unix.getcwd ()) (realpath "./././/./"); 108 | assert_equal ~printer "/" (realpath "///"); 109 | assert_equal ~printer "/" (realpath "/../../") 110 | end; 111 | () 112 | 113 | let test_signalfd () = 114 | require "signalfd"; 115 | let pid = Unix.getpid () in 116 | let (_:int list) = Unix.sigprocmask Unix.SIG_BLOCK [Sys.sigusr1; Sys.sigusr2] in 117 | let fd = signalfd ~sigs:[Sys.sigusr1] ~flags:[] () in 118 | Unix.kill pid Sys.sigusr1; 119 | let fd = signalfd ~fd ~sigs:[Sys.sigusr1; Sys.sigusr2] ~flags:[] () in 120 | Unix.set_nonblock fd; 121 | let printer = string_of_int in 122 | assert_equal ~printer Sys.sigusr1 (ssi_signo_sys (signalfd_read fd)); 123 | Unix.kill pid Sys.sigusr2; 124 | assert_equal ~printer Sys.sigusr2 (ssi_signo_sys (signalfd_read fd)); 125 | Unix.close fd 126 | 127 | let test_resource = 128 | let all_resources = 129 | [ 130 | RLIMIT_CORE; 131 | RLIMIT_CPU; 132 | RLIMIT_DATA; 133 | RLIMIT_FSIZE; 134 | (* RLIMIT_NOFILE; *) (* too fragile to test on CI *) 135 | RLIMIT_STACK; 136 | RLIMIT_AS; 137 | ] 138 | in 139 | let test_setrlimit r = 140 | require "setrlimit"; 141 | let test soft hard = 142 | setrlimit r ~soft ~hard; 143 | let (soft',hard') = getrlimit r in 144 | assert_equal ~printer:Rlimit.to_string ~msg:"soft limit" ~cmp:Rlimit.eq soft soft'; 145 | assert_equal ~printer:Rlimit.to_string ~msg:"hard limit" ~cmp:Rlimit.eq hard hard'; 146 | in 147 | let (soft,hard) = getrlimit r in 148 | assert_bool "soft <= hard" (Rlimit.le soft hard); 149 | test hard hard; 150 | test soft hard; 151 | match hard with 152 | | Some 0L -> () 153 | | None -> test soft soft 154 | | Some n -> let lim = Some (Int64.pred n) in test lim lim 155 | in 156 | let test_setrlimit r = 157 | (string_of_resource r) >:: (fun () -> test_setrlimit r) 158 | in 159 | [ 160 | "setrlimit" >::: (List.rev_map test_setrlimit all_resources); 161 | "getpriority" >:: (fun () -> require "getpriority"; let (_:int) = getpriority (PRIO_PROCESS (Unix.getpid ())) in ()); 162 | "setpriority" >:: (fun () -> 163 | require "setpriority"; 164 | let me = PRIO_PROCESS (Unix.getpid ()) in 165 | let prio = getpriority me in 166 | setpriority me (prio + 1); 167 | assert_equal ~printer:string_of_int (prio + 1) (getpriority me)); 168 | ] 169 | 170 | let test_strtime () = 171 | require "strptime"; 172 | assert_equal ~printer "2010/12/14" (strftime "%Y/%m/%d" (strptime "%Y-%m-%d" "2010-12-14")); 173 | let tm = Unix.localtime (Unix.gettimeofday ()) in 174 | let (_:string) = asctime tm in 175 | let (_:string) = tzname tm.Unix.tm_isdst in 176 | () 177 | 178 | let test_pts () = 179 | require "posix_openpt"; 180 | let master = 181 | try 182 | Some (posix_openpt [Unix.O_RDWR]) 183 | with 184 | Unix.Unix_error (Unix.EPERM, _, _) -> None 185 | in 186 | match master with 187 | | None -> skip_if true "posix_openpt EPERM" 188 | | Some master -> 189 | grantpt master; 190 | unlockpt master; 191 | let name = ptsname master in 192 | let slave = Unix.openfile name [Unix.O_RDWR; Unix.O_NOCTTY] 0 in 193 | let test = "test" in 194 | let len = Unix.write_substring slave test 0 (String.length test) in 195 | let str = 196 | let b = Bytes.create len in 197 | assert_equal (Unix.read master b 0 len) len; 198 | Bytes.unsafe_to_string b 199 | in 200 | assert_equal str test; 201 | () 202 | 203 | let test_execinfo () = 204 | require "backtrace"; 205 | (* Disabled - may not work out of the box on all archs or even segfault *) 206 | (* assert_bool "backtrace" ([||] <> backtrace ()) *) 207 | (* let (_:string array) = backtrace () in *) 208 | () 209 | 210 | let test_statvfs () = 211 | require "statvfs"; 212 | let st = statvfs (if Sys.win32 then "C:\\" else ".") in 213 | assert_bool "blocks" (st.f_blocks >= st.f_bfree && st.f_bfree >= st.f_bavail); 214 | assert_bool "inodes" (st.f_files >= st.f_ffree && st.f_ffree >= st.f_favail); 215 | assert_bool "bsize" (st.f_bsize > 0) 216 | 217 | let test_setenv () = 218 | require "setenv"; 219 | let k = "EXTUNIX_TEST_VAR" in 220 | let v = string_of_float (Unix.gettimeofday ()) in 221 | setenv k k true; 222 | assert_equal ~printer k (Unix.getenv k); 223 | setenv k v false; 224 | assert_equal ~printer k (Unix.getenv k); 225 | setenv k v true; 226 | assert_equal ~printer v (Unix.getenv k); 227 | unsetenv k; 228 | unsetenv k; 229 | assert_raises Not_found (fun () -> Unix.getenv k) 230 | 231 | let test_mkdtemp () = 232 | require "mkdtemp"; 233 | let name = "extunix_test_XXXXXX" in 234 | let tmpl = Filename.concat (Filename.get_temp_dir_name ()) name in 235 | let d1 = mkdtemp tmpl in 236 | let d2 = mkdtemp tmpl in 237 | try 238 | assert_bool "different" (d1 <> d2); 239 | assert_bool "d1 exists" ((Unix.stat d1).Unix.st_kind = Unix.S_DIR); 240 | assert_bool "d2 exists" ((Unix.stat d2).Unix.st_kind = Unix.S_DIR); 241 | Unix.rmdir d1; 242 | Unix.rmdir d2 243 | with exn -> Unix.rmdir d1; Unix.rmdir d2; raise exn 244 | 245 | let test_endian () = 246 | require "uint16_from_host"; 247 | require "uint16_to_host"; 248 | require "int16_from_host"; 249 | require "int16_to_host"; 250 | require "uint31_from_host"; 251 | require "uint31_to_host"; 252 | require "int31_from_host"; 253 | require "int31_to_host"; 254 | require "int32_from_host"; 255 | require "int32_to_host"; 256 | require "int64_from_host"; 257 | require "int64_to_host"; 258 | let module B = BigEndian in 259 | let module L = LittleEndian in 260 | let u16 = 0xABCD in 261 | let i16 = -0x1234 in 262 | let i32 = 0x89ABCDEFl in 263 | let i64 = 0x0123456789ABCDEFL in 264 | assert (B.uint16_to_host (B.uint16_from_host u16) = u16); 265 | assert (B.int16_to_host (B.int16_from_host i16) = i16); 266 | assert (L.uint16_to_host (L.uint16_from_host u16) = u16); 267 | assert (L.int16_to_host (L.int16_from_host i16) = i16); 268 | assert (B.uint16_from_host u16 <> L.uint16_from_host u16); 269 | assert (B.uint16_to_host u16 <> L.uint16_to_host u16); 270 | assert (B.int16_from_host i16 <> L.int16_from_host i16); 271 | assert (B.int16_to_host i16 <> L.int16_to_host i16); 272 | assert (B.int32_to_host (B.int32_from_host i32) = i32); 273 | assert (L.int32_to_host (L.int32_from_host i32) = i32); 274 | assert (B.int32_from_host i32 <> L.int32_from_host i32); 275 | assert (B.int32_to_host i32 <> L.int32_to_host i32); 276 | assert (B.int64_to_host (B.int64_from_host i64) = i64); 277 | assert (L.int64_to_host (L.int64_from_host i64) = i64); 278 | assert (B.int64_from_host i64 <> L.int64_from_host i64); 279 | assert (B.int64_to_host i64 <> L.int64_to_host i64) 280 | 281 | let test_endian_string () = 282 | require "unsafe_get_int8"; 283 | require "unsafe_get_int16"; 284 | require "unsafe_get_int31"; 285 | require "unsafe_get_int32"; 286 | require "unsafe_get_int64"; 287 | require "unsafe_get_uint8"; 288 | require "unsafe_get_uint16"; 289 | require "unsafe_get_uint31"; 290 | require "unsafe_get_uint63"; 291 | require "unsafe_get_int63"; 292 | require "unsafe_set_uint8"; 293 | require "unsafe_set_uint16"; 294 | require "unsafe_set_uint31"; 295 | require "unsafe_set_int8"; 296 | require "unsafe_set_int16"; 297 | require "unsafe_set_int31"; 298 | require "unsafe_set_int32"; 299 | require "unsafe_set_uint63"; 300 | require "unsafe_set_int63"; 301 | require "unsafe_set_int64"; 302 | let module B = BigEndian in 303 | let module L = LittleEndian in 304 | let src = (* FF FF FEDC FEDC FEDCBA98 FEDCBA9876543210 *) 305 | "\255\255\254\220\254\220\254\220\186\152\254\220\186\152\118\084\050\016" 306 | in 307 | assert_equal (B.get_uint8 src 0) 0xFF; 308 | assert_equal (B.get_int8 src 1) (-0x01); 309 | assert_equal (B.get_uint16 src 2) 0xFEDC; 310 | assert_equal (B.get_int16 src 4) (-0x0124); 311 | assert_equal (B.get_int32 src 6) (0xFEDCBA98l); 312 | assert_equal (B.get_int64 src 10) (0xFEDCBA9876543210L); 313 | assert_equal (L.get_uint8 src 0) 0xFF; 314 | assert_equal (L.get_int8 src 1) (-0x01); 315 | assert_equal (L.get_uint16 src 2) 0xDCFE; 316 | assert_equal (L.get_int16 src 4) (-0x2302); 317 | assert_equal (L.get_int32 src 6) (0x98BADCFEl); 318 | assert_equal (L.get_int64 src 10) (0x1032547698BADCFEL); 319 | assert_equal (B.get_uint31 src 6) (Int64.to_int 0xFEDCBA98L); 320 | assert_equal (B.get_int31 src 6) (Int64.to_int 0x7FFFFFFFFEDCBA98L); 321 | assert_equal (B.get_int31 src 6) (-0x1234568); 322 | assert_equal (B.get_uint63 src 10) (Int64.to_int 0x7EDCBA9876543210L); 323 | assert_equal (B.get_int63 src 10) (Int64.to_int 0x7EDCBA9876543210L); 324 | assert_equal (B.get_int63 src 10) (Int64.to_int (-0x123456789ABCDF0L)); 325 | assert_equal (L.get_uint31 src 6) (Int64.to_int 0x98BADCFEL); 326 | assert_equal (L.get_int31 src 6) (Int64.to_int 0x7FFFFFFF98BADCFEL); 327 | assert_equal (L.get_int31 src 6) (-0x67452302); 328 | assert_equal (L.get_uint63 src 10) (Int64.to_int 0x1032547698BADCFEL); 329 | assert_equal (L.get_int63 src 10) (Int64.to_int 0x1032547698BADCFEL); 330 | assert_equal (L.get_int63 src 10) (Int64.to_int (-0x6FCDAB8967452302L)); 331 | let b = Bytes.create 18 in 332 | B.set_uint8 b 0 0xFF; 333 | B.set_int8 b 1 (-0x01); 334 | B.set_uint16 b 2 0xFEDC; 335 | B.set_uint16 b 4 (-0x0124); 336 | B.set_int32 b 6 (0xFEDCBA98l); 337 | B.set_int64 b 10 (0xFEDCBA9876543210L); 338 | assert_equal (Bytes.unsafe_to_string b) src; 339 | let l = Bytes.create 18 in 340 | L.set_uint8 l 0 0xFF; 341 | L.set_int8 l 1 (-0x01); 342 | L.set_uint16 l 2 0xDCFE; 343 | L.set_uint16 l 4 (-0x2302); 344 | L.set_int32 l 6 (0x98BADCFEl); 345 | L.set_int64 l 10 (0x1032547698BADCFEL); 346 | assert_equal (Bytes.unsafe_to_string l) src 347 | 348 | let test_read_credentials () = 349 | require "read_credentials"; 350 | let (_fd1, fd2) = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in 351 | let (pid, uid, gid) = Unix.getpid (), Unix.getuid (), Unix.getgid () in 352 | assert_equal (read_credentials fd2) (pid, uid, gid) 353 | 354 | let test_fexecve () = 355 | require "fexecve"; 356 | let s1, s2 = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in 357 | match Unix.fork () with 358 | | 0 -> 359 | Unix.dup2 s2 Unix.stdout; 360 | Unix.close s1; 361 | Unix.close s2; 362 | let fd = Unix.openfile "/bin/echo" [Unix.O_RDONLY] 0 in 363 | fexecve fd [| "/bin/echo"; "-n"; "fexecve" |] [| |] 364 | | pid -> 365 | Unix.close s2; 366 | let wpid, _ = Unix.wait () in 367 | assert_equal wpid pid; 368 | let str = 369 | let b = Bytes.create 7 in 370 | assert_equal (Unix.read s1 b 0 7) 7; 371 | Bytes.unsafe_to_string b 372 | in 373 | assert_equal "fexecve" str; 374 | Unix.close s1 375 | 376 | let test_sendmsg () = 377 | require "sendmsg"; 378 | let (s1, s2) = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in 379 | match Unix.fork () with 380 | | 0 -> 381 | Unix.close s1; 382 | let fd = Unix.openfile "/bin/ls" [Unix.O_RDONLY] 0 in 383 | let st = Unix.fstat fd in 384 | sendmsg s2 ~sendfd:fd (sprintf "%d" st.Unix.st_ino); 385 | Unix.close fd; 386 | Unix.close s2; 387 | | _pid -> 388 | Unix.close s2; 389 | let (some_fd, msg) = recvmsg_fd s1 in 390 | Unix.close s1; 391 | match some_fd with 392 | | None -> assert_failure "no fd" 393 | | Some fd -> 394 | let st = Unix.fstat fd in 395 | assert_equal (int_of_string msg) st.Unix.st_ino; 396 | Unix.close fd 397 | 398 | let cmp_bytes str c text = 399 | for i = 0 to Bytes.length str - 1 do 400 | if Bytes.get str i <> c 401 | then assert_failure text; 402 | done 403 | 404 | let test_pread () = 405 | require "unsafe_pread"; 406 | let name = Filename.temp_file "extunix" "pread" in 407 | let fd = 408 | Unix.openfile name [Unix.O_RDWR] 0 409 | in 410 | try 411 | let size = 65536 in (* Must be larger than UNIX_BUFFER_SIZE (16384) *) 412 | let s = String.make size 'x' in 413 | assert_equal (Unix.write_substring fd s 0 size) size; 414 | let t = Bytes.make size ' ' in 415 | assert_equal (pread fd 0 t 0 size) size; 416 | cmp_bytes t 'x' "pread read bad data"; 417 | assert_equal (single_pread fd 0 t 0 size) size; 418 | cmp_bytes t 'x' "single_pread read bad data"; 419 | let t = Bytes.make size ' ' in 420 | assert_equal (LargeFile.pread fd Int64.zero t 0 size) size; 421 | cmp_bytes t 'x' "Largefile.pread read bad data"; 422 | assert_equal (LargeFile.single_pread fd Int64.zero t 0 size) size; 423 | cmp_bytes t 'x' "Largefile.single_pread read bad data"; 424 | Unix.close fd; 425 | Unix.unlink name 426 | with exn -> Unix.close fd; Unix.unlink name; raise exn 427 | 428 | let test_pwrite () = 429 | require "unsafe_pwrite"; 430 | let name = Filename.temp_file "extunix" "pwrite" in 431 | let fd = 432 | Unix.openfile name [Unix.O_RDWR] 0 433 | in 434 | let read dst = 435 | assert_equal (Unix.lseek fd 0 Unix.SEEK_SET) 0; 436 | let rec loop off = function 437 | | 0 -> () 438 | | size -> 439 | let len = Unix.read fd dst off size 440 | in 441 | loop (off + len) (size - len) 442 | in 443 | loop 0 (Bytes.length dst) 444 | in 445 | try 446 | let size = 65536 in (* Must be larger than UNIX_BUFFER_SIZE (16384) *) 447 | let s = String.make size 'x' in 448 | assert_equal (pwrite fd 0 s 0 size) size; 449 | let t = Bytes.make size ' ' in 450 | read t; 451 | cmp_bytes t 'x' "pwrite wrote bad data"; 452 | assert_equal (single_pwrite fd 0 s 0 size) size; 453 | read t; 454 | cmp_bytes t 'x' "single_pwrite wrote bad data"; 455 | let s = String.make size 'y' in 456 | assert_equal (LargeFile.pwrite fd Int64.zero s 0 size) size; 457 | let t = Bytes.make size ' ' in 458 | read t; 459 | cmp_bytes t 'y' "Largefile.pwrite wrote bad data"; 460 | assert_equal (LargeFile.single_pwrite fd Int64.zero s 0 size) size; 461 | read t; 462 | cmp_bytes t 'y' "Largefile.single_pwrite wrote bad data"; 463 | Unix.close fd; 464 | Unix.unlink name 465 | with exn -> Unix.close fd; Unix.unlink name; raise exn 466 | 467 | let test_read () = 468 | require "unsafe_read"; 469 | let name = Filename.temp_file "extunix" "read" in 470 | let fd = 471 | Unix.openfile name [Unix.O_RDWR] 0 472 | in 473 | try 474 | let size = 65536 in (* Must be larger than UNIX_BUFFER_SIZE (16384) *) 475 | let s = String.make size 'x' in 476 | assert_equal (Unix.write_substring fd s 0 size) size; 477 | let t = Bytes.make size ' ' in 478 | assert_equal (Unix.lseek fd 0 Unix.SEEK_SET) 0; 479 | assert_equal (read fd t 0 size) size; 480 | cmp_bytes t 'x' "read read bad data"; 481 | assert_equal (Unix.lseek fd 0 Unix.SEEK_SET) 0; 482 | assert_equal (single_read fd t 0 size) size; 483 | cmp_bytes t 'x' "single_read read bad data"; 484 | Unix.close fd; 485 | Unix.unlink name 486 | with exn -> Unix.close fd; Unix.unlink name; raise exn 487 | 488 | let test_write () = 489 | require "unsafe_write"; 490 | let name = Filename.temp_file "extunix" "write" in 491 | let fd = 492 | Unix.openfile name [Unix.O_RDWR] 0 493 | in 494 | let read dst = 495 | assert_equal (Unix.lseek fd 0 Unix.SEEK_SET) 0; 496 | let rec loop off = function 497 | | 0 -> () 498 | | size -> 499 | let len = Unix.read fd dst off size 500 | in 501 | loop (off + len) (size - len) 502 | in 503 | loop 0 (Bytes.length dst) 504 | in 505 | try 506 | let size = 65536 in (* Must be larger than UNIX_BUFFER_SIZE (16384) *) 507 | let s = String.make size 'x' in 508 | assert_equal (write fd s 0 size) size; 509 | let t = Bytes.make size ' ' in 510 | read t; 511 | cmp_bytes t 'x' "write wrote bad data"; 512 | assert_equal (single_write fd s 0 size) size; 513 | read t; 514 | cmp_bytes t 'x' "single_write wrote bad data"; 515 | Unix.close fd; 516 | Unix.unlink name 517 | with exn -> Unix.close fd; Unix.unlink name; raise exn 518 | 519 | let test_mkstemp () = 520 | require "internal_mkstemps"; 521 | let (_fd, name) = mkstemp ~suffix:"mkstemp" "extunix" in 522 | Unix.unlink name 523 | 524 | let test_mkostemp () = 525 | require "internal_mkostemps"; 526 | let (_fd, name) = mkostemp ~suffix:"mkstemp" ~flags:[Unix.O_APPEND] "extunix" in 527 | Unix.unlink name 528 | 529 | let test_memalign () = 530 | require "memalign"; 531 | ignore (memalign 512 512); 532 | ignore (memalign 1024 2048); 533 | ignore (memalign 2048 16384); 534 | ignore (memalign 4096 65536) 535 | 536 | let test_sockopt () = 537 | require "setsockopt_int"; 538 | require "getsockopt_int"; 539 | let fd = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 540 | let test msg opt v = 541 | try 542 | setsockopt_int fd opt v; 543 | assert_equal ~printer:string_of_int ~msg v (getsockopt_int fd opt) 544 | with 545 | Not_available _ -> skip_if true msg 546 | in 547 | Unix.setsockopt fd Unix.SO_KEEPALIVE true; 548 | test "TCP_KEEPCNT" TCP_KEEPCNT 5; 549 | test "TCP_KEEPIDLE" TCP_KEEPIDLE 30; 550 | test "TCP_KEEPINTVL" TCP_KEEPINTVL 10; 551 | Unix.close fd 552 | 553 | let test_sendmsg_bin () = 554 | require "sendmsg"; 555 | let test_msg = "test\x00message\x01" in 556 | let (s,s') = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in 557 | match Unix.fork () with 558 | | 0 -> 559 | Unix.close s'; 560 | sendmsg s ~sendfd:Unix.stdout test_msg; 561 | sendfd ~sock:s ~fd:Unix.stdout 562 | | _ -> 563 | Unix.close s; 564 | let (fd1,msg) = recvmsg_fd s' in 565 | assert_equal ~printer:(sprintf "%S") test_msg msg; 566 | match fd1 with 567 | | None -> assert_failure "expected fd, got nothing" 568 | | Some fd1 -> 569 | Unix.close fd1; 570 | let fd2 = recvfd s' in 571 | Unix.close fd2 572 | 573 | let test_sysinfo () = 574 | require "sysinfo"; 575 | let t = sysinfo () in 576 | let (_:int) = t.uptime in 577 | () 578 | 579 | let test_splice () = 580 | require "splice"; 581 | let pipe_out, pipe_in = Unix.pipe ~cloexec:true () in 582 | let name = Filename.temp_file "extunix" "test" in 583 | let fd = Unix.openfile name [O_RDWR; O_CREAT; O_CLOEXEC] 0o666 in 584 | Unix.ftruncate fd (4096 * 2); 585 | assert_equal (Unix.write_substring fd "test0123456789" 0 14) 14; 586 | let n = splice fd (Some 4) pipe_in None 10 [] in 587 | assert(n = 10); 588 | let n = splice pipe_out None fd (Some 4096) 10 [] in 589 | assert(n = 10); 590 | let b = Bytes.create 13 in 591 | let _ = Unix.lseek fd 4096 SEEK_SET in 592 | let n = Unix.read fd b 0 13 in 593 | assert(n = 13); 594 | assert_equal(Bytes.to_string b) "0123456789\000\000\000"; 595 | Unix.close fd; 596 | Unix.unlink name; 597 | Unix.close pipe_out; 598 | Unix.close pipe_in; 599 | () 600 | 601 | let test_wait4 () = 602 | require "wait4"; 603 | let pid = Unix.fork () in 604 | if pid = 0 then exit 42 605 | else 606 | let waited_pid, status, _ = wait4 [] pid in 607 | assert ( 608 | let expect_pid = waited_pid = pid 609 | and expect_exit = match status with Unix.WEXITED 42 -> true | _ -> false in 610 | expect_pid && expect_exit ) 611 | 612 | let () = 613 | let wrap test = 614 | with_unix_error (fun () -> test (); Gc.compact ()) 615 | in 616 | let tests = ("tests" >::: [ 617 | "eventfd" >:: test_eventfd; 618 | "uname" >:: test_uname; 619 | "fadvise" >:: test_fadvise; 620 | "fallocate" >:: test_fallocate; 621 | "unistd" >::: test_unistd; 622 | "realpath" >:: test_realpath; 623 | "signalfd" >:: test_signalfd; 624 | "resource" >::: test_resource; 625 | "strtime" >:: test_strtime; 626 | "pts" >:: test_pts; 627 | "execinfo" >:: test_execinfo; 628 | "statvfs" >:: test_statvfs; 629 | "setenv" >:: test_setenv; 630 | "mkdtemp" >:: test_mkdtemp; 631 | "endian" >:: test_endian; 632 | "endian_string" >:: test_endian_string; 633 | "read_credentials" >:: test_read_credentials; 634 | "fexecve" >:: test_fexecve; 635 | "sendmsg" >:: test_sendmsg; 636 | "pread" >:: test_pread; 637 | "pwrite" >:: test_pwrite; 638 | "read" >:: test_read; 639 | "write" >:: test_write; 640 | "mkstemp" >:: test_mkstemp; 641 | "mkostemp" >:: test_mkostemp; 642 | "memalign" >:: test_memalign; 643 | "sockopt" >:: test_sockopt; 644 | "sendmsg_bin" >:: test_sendmsg_bin; 645 | "sysinfo" >:: test_sysinfo; 646 | "splice" >:: test_splice; 647 | "wait4" >:: test_wait4; 648 | ]) in 649 | ignore (run_test_tt_main (test_decorate wrap tests)) 650 | -------------------------------------------------------------------------------- /test/test_user_namespace.ml: -------------------------------------------------------------------------------- 1 | 2 | open ExtUnix.All 3 | 4 | let mkdir ?(perm=0o750) dir = 5 | if not (Sys.file_exists dir) then Unix.mkdir dir perm 6 | 7 | let mount_inside ~dir ~src ~tgt ?(fstype="") ~flags ?(data="") () = 8 | let tgt = Filename.concat dir tgt in 9 | mkdir tgt; 10 | mount ~source:src ~target:tgt ~fstype flags ~data 11 | 12 | let mount_base dir = 13 | mount_inside ~dir ~src:"proc" ~tgt:"proc" ~fstype:"proc" 14 | ~flags:[MS_NOSUID; MS_NOEXEC; MS_NODEV] (); 15 | mount_inside ~dir ~src:"/sys" ~tgt:"sys" ~flags:[MS_BIND; MS_REC] (); 16 | mount_inside ~dir ~src:"/dev" ~tgt:"dev" ~flags:[MS_BIND; MS_REC] (); 17 | 18 | mount_inside ~dir ~src:"tmpfs" ~tgt:"dev/shm" ~fstype:"tmpfs" 19 | ~flags:[MS_NOSUID; MS_STRICTATIME; MS_NODEV] 20 | ~data:"mode=1777" (); 21 | 22 | mount_inside ~dir ~src:"tmpfs" ~tgt:"run" ~fstype:"tmpfs" 23 | ~flags:[MS_NOSUID; MS_STRICTATIME; MS_NODEV] 24 | ~data:"mode=755" (); 25 | 26 | (* for aptitude *) 27 | mkdir (Filename.concat dir "/run/lock") 28 | 29 | let do_chroot dest = 30 | Sys.chdir dest; 31 | chroot "."; 32 | Sys.chdir "/" 33 | 34 | let read_in_file fmt = 35 | Printf.ksprintf (fun file -> 36 | let c = open_in file in 37 | let v = input_line c in 38 | close_in c; 39 | v 40 | ) fmt 41 | 42 | 43 | let test_userns_availability () = 44 | let unpriviledge_userns_clone = 45 | "/proc/sys/kernel/unprivileged_userns_clone" in 46 | if Sys.file_exists unpriviledge_userns_clone then begin 47 | let v = read_in_file "%s" unpriviledge_userns_clone in 48 | if v <> "1" then begin 49 | Printf.eprintf "This kernel is configured to disable unpriviledge user\ 50 | namespace: %s must be 1\n" unpriviledge_userns_clone; 51 | exit 1 52 | end 53 | end 54 | 55 | let write_in_file fmt = 56 | Printf.ksprintf (fun file -> 57 | Printf.ksprintf (fun towrite -> 58 | try 59 | let cout = open_out file in 60 | output_string cout towrite; 61 | close_out cout 62 | with _ -> 63 | Printf.eprintf "Error during write of %s in %s\n" 64 | towrite file; 65 | exit 1 66 | ) 67 | ) fmt 68 | 69 | let command fmt = Printf.ksprintf (fun cmd -> Sys.command cmd = 0) fmt 70 | 71 | let command_no_fail ?(error=(fun () -> ())) fmt = 72 | Printf.ksprintf (fun cmd -> 73 | let c = Sys.command cmd in 74 | if c <> 0 then begin 75 | Printf.eprintf "Error during: %s\n%!" cmd; 76 | error (); 77 | exit 1; 78 | end 79 | ) fmt 80 | 81 | (** {2 GPG} *) 82 | 83 | let download_keyid = "0xBAEFF88C22F6E216" 84 | let download_keyserver = "hkp://pool.sks-keyservers.net" 85 | 86 | type gpg_t = 87 | | GPGNotAvailable 88 | | GPGAvailable of string 89 | 90 | 91 | let gpg_setup ~dir = 92 | let command_raise fmt = 93 | Printf.ksprintf (fun cmd -> 94 | Printf.ksprintf (fun msg -> 95 | let c = Sys.command cmd in 96 | if c <> 0 then begin 97 | Printf.eprintf "%s\n%!" msg; 98 | raise Exit 99 | end 100 | ) 101 | ) fmt 102 | in 103 | try 104 | command_raise 105 | "which gpg >/dev/null 2>&1" 106 | "The program gpg is not present: can't validate download"; 107 | let gpg_dir = Filename.concat dir "gpg" in 108 | mkdir ~perm:0o700 gpg_dir; 109 | command_raise 110 | "GNUPGHOME=%S gpg --keyserver %s --recv-keys %s > /dev/null 2>&1;" 111 | gpg_dir download_keyserver download_keyid 112 | "Can't download gpg key data: can't validate download"; 113 | GPGAvailable gpg_dir 114 | with Exit -> 115 | GPGNotAvailable 116 | 117 | let gpg_check file = function 118 | | GPGNotAvailable -> () 119 | | GPGAvailable gpg_dir -> 120 | command_no_fail 121 | ~error:(fun () -> Printf.eprintf "Invalid signature for %s\n%!" file) 122 | "GNUPGHOME=%S gpg --verify %S > /dev/null 2>&1" gpg_dir (file^".asc") 123 | 124 | (** {2 Download image} *) 125 | (** use lxc download template facilities *) 126 | 127 | let download_compat_level=2 128 | let download_server = "images.linuxcontainers.org" 129 | 130 | let download ?(quiet=true) fmt = 131 | Printf.ksprintf (fun src -> 132 | Printf.ksprintf (fun dst -> 133 | command "wget -T 30 %s https://%s/%s -O %S %s" 134 | (if quiet then "-q" else "") 135 | download_server src dst 136 | (if quiet then ">/dev/null 2>&1" else "") 137 | ) 138 | ) fmt 139 | 140 | let download_index ~dir ~gpg = 141 | let index = Filename.concat dir "index" in 142 | let url_index = "meta/1.0/index-user" in 143 | Printf.printf "Download the index: %!"; 144 | if not (download 145 | "%s.%i" url_index download_compat_level 146 | "%s" index 147 | && download 148 | "%s.%i.asc" url_index download_compat_level 149 | "%s.asc" index) then 150 | if not (download "%s" url_index "%s" index 151 | && download 152 | "%s.asc" url_index 153 | "%s.asc" index) then begin 154 | Printf.eprintf "error.\n%!"; 155 | exit 1; 156 | end; 157 | gpg_check index gpg; 158 | Printf.printf "done.\n%!"; 159 | index 160 | 161 | let semicomma = Str.regexp_string ";" 162 | 163 | (** return download build and directory url *) 164 | let find_image ~distr ~release ~arch index = 165 | let cin = open_in index in 166 | let rec aux () = 167 | match Str.split semicomma (input_line cin) with 168 | | [d;r;a;_;db;u] when d = distr && r = release && a = arch -> 169 | close_in cin; db,u 170 | | _ -> aux () in 171 | try 172 | aux () 173 | with End_of_file -> close_in cin; 174 | Printf.eprintf "Can't find url in index corresponding to %s %s %s\n%!" 175 | distr release arch; 176 | exit 1 177 | 178 | let download_rootfs_meta ~dir ~gpg (build_id,url) = 179 | let build_id_file = Filename.concat dir "build_id" in 180 | let rootfs_tar = Filename.concat dir "rootfs.tar.xz" in 181 | let meta_tar = Filename.concat dir "meta.tar.xz" in 182 | if not (Sys.file_exists build_id_file) 183 | || read_in_file "%s" build_id_file <> build_id then begin 184 | if Sys.file_exists build_id_file then Unix.unlink build_id_file; 185 | Printf.printf "Downloading rootfs.\n%!"; 186 | if not (download ~quiet:false "%s/rootfs.tar.xz" url "%s/rootfs.tar.xz" dir 187 | && download "%s/rootfs.tar.xz.asc" url "%s/rootfs.tar.xz.asc" dir 188 | && download "%s/meta.tar.xz" url "%s/meta.tar.xz" dir 189 | && download "%s/meta.tar.xz.asc" url "%s/meta.tar.xz.asc" dir) 190 | then begin Printf.printf "error.\n%!"; exit 1 end; 191 | gpg_check rootfs_tar gpg; 192 | gpg_check meta_tar gpg; 193 | write_in_file "%s" build_id_file "%s" build_id 194 | end; 195 | rootfs_tar, meta_tar 196 | 197 | (** {2 User namespace} *) 198 | type userns_idmap = 199 | | KeepUser 200 | (** Put only the current user (uid,gid) as root in the userns *) 201 | | IdMap of int * int 202 | (** IdMap(id,rangeid): Map [1;rangeid] (uid,gid) in the userns to 203 | [id,id+rangeid] (current user is root in the userns) *) 204 | 205 | let set_usermap idmap pid = 206 | let curr_uid = Unix.getuid () in 207 | let curr_gid = Unix.getgid () in 208 | (* write_in_file "/proc/%i/setgroups" pid "deny"; *) 209 | match idmap with 210 | | KeepUser -> 211 | write_in_file "/proc/%i/uid_map" pid "0 %i 1" curr_uid; 212 | write_in_file "/proc/%i/gid_map" pid "0 %i 1" curr_gid; 213 | | IdMap(id,rangeid) -> 214 | (* Printf.printf "pid: %i, mine: %i\n%!" pid (Unix.getpid ()); *) 215 | let error () = ignore (Unix.kill pid 9); exit 1 in 216 | command_no_fail ~error 217 | "newuidmap %i 0 %i 1 1 %i %i" pid curr_uid id rangeid; 218 | command_no_fail ~error 219 | "newgidmap %i 0 %i 1 1 %i %i" pid curr_gid id rangeid 220 | 221 | let goto_child ~exec_in_parent = 222 | let fin,fout = Unix.pipe () in 223 | match Unix.fork () with 224 | | -1 -> Printf.eprintf "Fork failed\n%!"; exit 1 225 | | 0 -> (* child *) 226 | Unix.close fout; 227 | ignore (Unix.read fin (Bytes.create 1) 0 1); 228 | Unix.close fin 229 | | pid -> 230 | Unix.close fin; 231 | (exec_in_parent pid: unit); 232 | ignore (Unix.write fout (Bytes.create 1) 0 1); 233 | Unix.close fout; 234 | let _, status = Unix.waitpid [] pid in 235 | match status with 236 | | Unix.WEXITED s -> exit s 237 | | Unix.WSIGNALED s -> Unix.kill (Unix.getpid ()) s; assert false 238 | | Unix.WSTOPPED _ -> assert false 239 | 240 | let exec_in_child (type a) f = 241 | let fin,fout = Unix.pipe () in 242 | match Unix.fork () with 243 | | -1 -> Printf.eprintf "Fork failed\n%!"; exit 1 244 | | 0 -> (* child *) 245 | Unix.close fout; 246 | let cin = Unix.in_channel_of_descr fin in 247 | let arg = (Marshal.from_channel cin : a) in 248 | close_in cin; 249 | f arg; 250 | exit 0 251 | | pid -> 252 | Unix.close fin; 253 | let cout = Unix.out_channel_of_descr fout in 254 | let call_in_child (arg:a) = 255 | Marshal.to_channel cout arg []; 256 | close_out cout; 257 | let _, status = Unix.waitpid [] pid in 258 | match status with 259 | | Unix.WEXITED 0 -> () 260 | | Unix.WEXITED s -> exit s 261 | | Unix.WSIGNALED s -> Unix.kill (Unix.getpid ()) s; assert false 262 | | Unix.WSTOPPED _ -> assert false 263 | in 264 | call_in_child 265 | 266 | let exec_now_in_child f arg = 267 | match Unix.fork () with 268 | | -1 -> Printf.eprintf "Fork failed\n%!"; exit 1 269 | | 0 -> (* child *) 270 | f arg; 271 | exit 0 272 | | pid -> 273 | let _, status = Unix.waitpid [] pid in 274 | match status with 275 | | Unix.WEXITED 0 -> () 276 | | Unix.WEXITED s -> exit s 277 | | Unix.WSIGNALED s -> Unix.kill (Unix.getpid ()) s; assert false 278 | | Unix.WSTOPPED _ -> assert false 279 | 280 | let just_goto_child () = 281 | match Unix.fork () with 282 | | -1 -> Printf.eprintf "Fork failed\n%!"; exit 1 283 | | 0 -> (* child *) () 284 | | pid -> 285 | let _, status = Unix.waitpid [] pid in 286 | match status with 287 | | Unix.WEXITED s -> exit s 288 | | Unix.WSIGNALED s -> Unix.kill (Unix.getpid ()) s; assert false 289 | | Unix.WSTOPPED _ -> assert false 290 | 291 | 292 | let go_in_userns idmap = 293 | (* the usermap can be set only completely outside the namespace, so we 294 | keep a child for doing that when we have a pid completely inside the 295 | namespace *) 296 | let call_set_usermap = exec_in_child (set_usermap idmap) in 297 | unshare [ CLONE_NEWNS; 298 | CLONE_NEWIPC; 299 | CLONE_NEWPID; 300 | CLONE_NEWUTS; 301 | CLONE_NEWUSER; 302 | ]; 303 | (* only the child will be in the new pid namespace, the parent is in 304 | an intermediary state not interesting *) 305 | goto_child ~exec_in_parent:call_set_usermap 306 | (* Printf.printf "User: %i (%i)\n%!" (Unix.getuid ()) (Unix.geteuid ()); *) 307 | (* Printf.printf "Pid: %i\n%!" (Unix.getpid ()); *) 308 | (* Printf.printf "User: %i (%i)\n%!" (Unix.getuid ()) (Unix.geteuid ()); *) 309 | 310 | let create_rootfs ~distr ~release ~arch testdir = 311 | let rootfsdir = Filename.concat testdir "rootfs" in 312 | if not (Sys.file_exists rootfsdir) then begin 313 | let gpg = gpg_setup ~dir:testdir in 314 | let index = download_index ~dir:testdir ~gpg in 315 | let url = 316 | find_image ~distr ~release ~arch index in 317 | let rootfs, meta = download_rootfs_meta ~dir:testdir ~gpg url in 318 | let metadir = Filename.concat testdir "meta" in 319 | command_no_fail "rm -rf %S" metadir; 320 | mkdir metadir; 321 | command_no_fail "tar Jxf %S -C %S" meta metadir; 322 | mkdir ~perm:0o750 rootfsdir; 323 | let error () = 324 | Printf.printf "error\n%!"; 325 | command_no_fail "rm -rf %S" rootfsdir in 326 | let exclude = Filename.concat metadir "excludes-user" in 327 | Printf.printf "Uncompressing rootfs:%!"; 328 | if Sys.file_exists exclude 329 | then command_no_fail ~error 330 | "tar Jxf %S -C %S --exclude-from %S \ 331 | --numeric-owner --preserve-permissions --preserve-order --same-owner" 332 | rootfs rootfsdir exclude 333 | else command_no_fail ~error "tar Jxf %S -C %S" rootfs rootfsdir; 334 | Printf.printf "done.\n%!"; 335 | end; 336 | rootfsdir 337 | 338 | let idmap, (cmd,arg), testdir, setuid, setgid, arch, distr, release = 339 | let open Arg in 340 | let testdir = ref "userns_test" in 341 | let idmap_id = ref (-1) in 342 | let idmap_rangeid = ref (-1) in 343 | let command = ref [] in 344 | let setuid = ref 0 in 345 | let setgid = ref 0 in 346 | let arch = ref "amd64" in 347 | let distr = ref "debian" in 348 | let release = ref "jessie" in 349 | parse (align [ 350 | "--dir", 351 | Set_string testdir, 352 | "dir Directory to use for the test \ 353 | (dir/rootfs is used for root directory)"; 354 | "--idmap", 355 | Tuple [Set_int idmap_id;Set_int idmap_rangeid], 356 | "id_range maps additionally uid/gid [1;range] to [id;id+range]\n\t\ 357 | you need a configured /etc/subuid (man subuid)"; 358 | "--uid", 359 | Set_int setuid, 360 | "uid Execute the command as this uid inside the user namespace"; 361 | "--gid", 362 | Set_int setgid, 363 | "gid Execute the command as this gid inside the user namespace"; 364 | "--arch", 365 | Set_string arch, 366 | "arch Specify the architecture of the image \ 367 | (eg. amd64, i386, armel,armhf)"; 368 | "--distr", 369 | Tuple [Set_string distr; Set_string release], 370 | "distr_release Specify the distribution and release of the image \ 371 | (eg. centos 6, debian jessie, ubuntu precise, gentoo current)"; 372 | "--", 373 | Rest (fun s -> command := s::!command), 374 | "Instead of running /bin/bash in the usernamespace, run the given command" 375 | ]) 376 | (fun _ -> raise (Bad "no anonymous option")) 377 | "Test for user-namespace: you need linux at least 3.18. \ 378 | In the user-namespace the\n\ 379 | current user is root. Use LXC download template facilities for getting\n\ 380 | the root filesystem."; 381 | let idmap = 382 | match !idmap_id, !idmap_rangeid with 383 | | (-1), _ | _, (-1) -> KeepUser 384 | | id, range -> IdMap(id,range) 385 | in 386 | let command = 387 | match List.rev !command with 388 | | [] -> "/bin/bash",[|"bash"|] 389 | | (cmd::_) as l -> cmd, Array.of_list l in 390 | idmap, command, !testdir, !setuid, !setgid, !arch, !distr, !release 391 | 392 | let () = 393 | if Unix.getuid () = 0 then begin 394 | Printf.eprintf "This program shouldn't be run as root!\n%!"; 395 | exit 1 396 | end; 397 | Unix.handle_unix_error begin fun () -> 398 | test_userns_availability (); 399 | mkdir ~perm:0o750 testdir; 400 | go_in_userns idmap; 401 | let rootfsdir = create_rootfs ~arch ~distr ~release testdir in 402 | command_no_fail "cp /etc/resolv.conf %S" 403 | (Filename.concat rootfsdir "etc/resolv.conf"); 404 | (* make the mount private and mount basic directories *) 405 | mount_base rootfsdir; 406 | (* chroot in the directory *) 407 | do_chroot rootfsdir; 408 | (* group must be changed before uid... *) 409 | setresgid setgid setgid setgid; 410 | setresuid setuid setuid setuid; 411 | let path = 412 | (if setuid = 0 then "/usr/local/sbin:/usr/sbin:/sbin:" else "")^ 413 | "/usr/local/bin:/usr/bin:/bin" in 414 | Unix.putenv "PATH" path; 415 | Unix.execv cmd arg 416 | end () 417 | -------------------------------------------------------------------------------- /test/testba.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open ExtUnix.All.BA 3 | module LargeFile = ExtUnix.All.LargeFile.BA 4 | 5 | let with_unix_error f () = 6 | try 7 | f () 8 | with 9 | | Unix.Unix_error(e,f,a) -> 10 | let message = Printf.sprintf "Unix_error : %s(%s) : %s" f a (Unix.error_message e) in 11 | skip_if (e = Unix.ENOSYS) message; (* libc may raise Not implemented, not an error in extunix *) 12 | assert_failure message 13 | 14 | let require feature = 15 | match ExtUnix.All.have feature with 16 | | None -> assert false 17 | | Some present -> skip_if (not present) (Printf.sprintf "%S is not available" feature) 18 | 19 | let test_endian_bigarray () = 20 | require "unsafe_get_int8"; 21 | require "unsafe_get_int16"; 22 | require "unsafe_get_int31"; 23 | require "unsafe_get_int32"; 24 | require "unsafe_get_int64"; 25 | require "unsafe_get_uint8"; 26 | require "unsafe_get_uint16"; 27 | require "unsafe_get_uint31"; 28 | require "unsafe_get_uint63"; 29 | require "unsafe_get_int63"; 30 | require "unsafe_set_uint8"; 31 | require "unsafe_set_uint16"; 32 | require "unsafe_set_uint31"; 33 | require "unsafe_set_int8"; 34 | require "unsafe_set_int16"; 35 | require "unsafe_set_int31"; 36 | require "unsafe_set_int32"; 37 | require "unsafe_set_uint63"; 38 | require "unsafe_set_int63"; 39 | require "unsafe_set_int64"; 40 | let module B = BigEndian in 41 | let module L = LittleEndian in 42 | let src = Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.c_layout 18 in 43 | ignore (List.fold_left (fun off x -> Bigarray.Array1.set src off x; off + 1) 44 | 0 45 | [0xFF; 46 | 0xFF; 47 | 0xFE; 0xDC; 48 | 0xFE; 0xDC; 49 | 0xFE; 0xDC; 0xBA; 0x98; 50 | 0xFE; 0xDC; 0xBA; 0x98; 0x76; 0x54; 0x32; 0x10]); 51 | assert_equal (B.get_uint8 src 0) 0xFF; 52 | assert_equal (B.get_int8 src 1) (-0x01); 53 | assert_equal (B.get_uint16 src 2) 0xFEDC; 54 | assert_equal (B.get_int16 src 4) (-0x0124); 55 | assert_equal (B.get_int32 src 6) (0xFEDCBA98l); 56 | assert_equal (B.get_int64 src 10) (0xFEDCBA9876543210L); 57 | assert_equal (L.get_uint8 src 0) 0xFF; 58 | assert_equal (L.get_int8 src 1) (-0x01); 59 | assert_equal (L.get_uint16 src 2) 0xDCFE; 60 | assert_equal (L.get_int16 src 4) (-0x2302); 61 | assert_equal (L.get_int32 src 6) (0x98BADCFEl); 62 | assert_equal (L.get_int64 src 10) (0x1032547698BADCFEL); 63 | assert_equal (B.get_uint31 src 6) (Int64.to_int 0xFEDCBA98L); 64 | assert_equal (B.get_int31 src 6) (Int64.to_int 0x7FFFFFFFFEDCBA98L); 65 | assert_equal (B.get_int31 src 6) (-0x1234568); 66 | assert_equal (B.get_uint63 src 10) (Int64.to_int 0x7EDCBA9876543210L); 67 | assert_equal (B.get_int63 src 10) (Int64.to_int 0x7EDCBA9876543210L); 68 | assert_equal (B.get_int63 src 10) (Int64.to_int (-0x123456789ABCDF0L)); 69 | assert_equal (L.get_uint31 src 6) (Int64.to_int 0x98BADCFEL); 70 | assert_equal (L.get_int31 src 6) (Int64.to_int 0x7FFFFFFF98BADCFEL); 71 | assert_equal (L.get_int31 src 6) (-0x67452302); 72 | assert_equal (L.get_uint63 src 10) (Int64.to_int 0x1032547698BADCFEL); 73 | assert_equal (L.get_int63 src 10) (Int64.to_int 0x1032547698BADCFEL); 74 | assert_equal (L.get_int63 src 10) (Int64.to_int (-0x6FCDAB8967452302L)); 75 | let b = Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.c_layout 18 in 76 | B.set_uint8 b 0 0xFF; 77 | B.set_int8 b 1 (-0x01); 78 | B.set_uint16 b 2 0xFEDC; 79 | B.set_uint16 b 4 (-0x0124); 80 | B.set_int32 b 6 (0xFEDCBA98l); 81 | B.set_int64 b 10 (0xFEDCBA9876543210L); 82 | assert_equal b src; 83 | let l = Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.c_layout 18 in 84 | L.set_uint8 l 0 0xFF; 85 | L.set_int8 l 1 (-0x01); 86 | L.set_uint16 l 2 0xDCFE; 87 | L.set_uint16 l 4 (-0x2302); 88 | L.set_int32 l 6 (0x98BADCFEl); 89 | L.set_int64 l 10 (0x1032547698BADCFEL); 90 | assert_equal l src 91 | 92 | let cmp_buf buf c text = 93 | for i = 0 to Bigarray.Array1.dim buf - 1 do 94 | if Bigarray.Array1.get buf i <> (int_of_char c) 95 | then assert_failure text; 96 | done 97 | 98 | let test_pread_bigarray () = 99 | require "unsafe_pread"; 100 | let name = Filename.temp_file "extunix" "pread" in 101 | let fd = 102 | Unix.openfile name [Unix.O_RDWR] 0 103 | in 104 | try 105 | let size = 65536 in 106 | let s = String.make size 'x' in 107 | assert_equal (Unix.write_substring fd s 0 size) size; 108 | let t = Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.c_layout size in 109 | assert_equal (pread fd 0 t) size; 110 | cmp_buf t 'x' "pread read bad data"; 111 | assert_equal (single_pread fd 0 t) size; 112 | cmp_buf t 'x' "pread read bad data"; 113 | let t = Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.c_layout size in 114 | assert_equal (LargeFile.pread fd Int64.zero t) size; 115 | cmp_buf t 'x' "Largefile.pread read bad data"; 116 | assert_equal (LargeFile.single_pread fd Int64.zero t) size; 117 | cmp_buf t 'x' "Largefile.single_pread read bad data"; 118 | Unix.close fd; 119 | Unix.unlink name 120 | with exn -> Unix.close fd; Unix.unlink name; raise exn 121 | 122 | let cmp_bytes str c text = 123 | for i = 0 to Bytes.length str - 1 do 124 | if Bytes.get str i <> c 125 | then assert_failure text; 126 | done 127 | 128 | let test_pwrite_bigarray () = 129 | require "unsafe_pwrite"; 130 | let name = Filename.temp_file "extunix" "pwrite" in 131 | let fd = 132 | Unix.openfile name [Unix.O_RDWR] 0 133 | in 134 | let read dst = 135 | assert_equal (Unix.lseek fd 0 Unix.SEEK_SET) 0; 136 | let rec loop off = function 137 | | 0 -> () 138 | | size -> 139 | let len = Unix.read fd dst off size 140 | in 141 | loop (off + len) (size - len) 142 | in 143 | loop 0 (Bytes.length dst) 144 | in 145 | try 146 | let size = 65536 in (* Must be larger than UNIX_BUFFER_SIZE (16384) *) 147 | let s = Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.c_layout size in 148 | for i = 0 to size - 1 do 149 | Bigarray.Array1.set s i (int_of_char 'x'); 150 | done; 151 | assert_equal (pwrite fd 0 s) size; 152 | let t = Bytes.make size ' ' in 153 | read t; 154 | cmp_bytes t 'x' "pwrite wrote bad data"; 155 | assert_equal (single_pwrite fd 0 s) size; 156 | read t; 157 | cmp_bytes t 'x' "single_pwrite wrote bad data"; 158 | for i = 0 to size - 1 do 159 | Bigarray.Array1.set s i (int_of_char 'y'); 160 | done; 161 | assert_equal (LargeFile.pwrite fd Int64.zero s) size; 162 | read t; 163 | cmp_bytes t 'y' "Largefile.pwrite wrote bad data"; 164 | assert_equal (LargeFile.single_pwrite fd Int64.zero s) size; 165 | read t; 166 | cmp_bytes t 'y' "Largefile.single_pwrite wrote bad data"; 167 | Unix.close fd; 168 | Unix.unlink name 169 | with exn -> Unix.close fd; Unix.unlink name; raise exn 170 | 171 | let test_substr () = 172 | let arr = Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.c_layout 12 in 173 | set_substr arr 0 "Hell"; 174 | set_substr arr 4 "o World!"; 175 | assert_equal (get_substr arr 0 6) "Hello "; 176 | assert_equal (get_substr arr 6 6) "World!" 177 | 178 | let test_read_bigarray () = 179 | require "read"; 180 | let name = Filename.temp_file "extunix" "read" in 181 | let fd = 182 | Unix.openfile name [Unix.O_RDWR] 0 183 | in 184 | try 185 | let size = 65536 in 186 | let s = String.make size 'x' in 187 | assert_equal (Unix.write_substring fd s 0 size) size; 188 | let t = Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.c_layout size in 189 | assert_equal (Unix.lseek fd 0 Unix.SEEK_SET) 0; 190 | assert_equal (read fd t) size; 191 | cmp_buf t 'x' "read read bad data"; 192 | assert_equal (Unix.lseek fd 0 Unix.SEEK_SET) 0; 193 | assert_equal (single_read fd t) size; 194 | cmp_buf t 'x' "single_read read bad data"; 195 | Unix.close fd; 196 | Unix.unlink name 197 | with exn -> Unix.close fd; Unix.unlink name; raise exn 198 | 199 | let test_write_bigarray () = 200 | require "write"; 201 | let name = Filename.temp_file "extunix" "write" in 202 | let fd = 203 | Unix.openfile name [Unix.O_RDWR] 0 204 | in 205 | let read dst = 206 | assert_equal (Unix.lseek fd 0 Unix.SEEK_SET) 0; 207 | let rec loop off = function 208 | | 0 -> () 209 | | size -> 210 | let len = Unix.read fd dst off size 211 | in 212 | loop (off + len) (size - len) 213 | in 214 | loop 0 (Bytes.length dst) 215 | in 216 | try 217 | let size = 65536 in (* Must be larger than UNIX_BUFFER_SIZE (16384) *) 218 | let s = Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.c_layout size in 219 | for i = 0 to size - 1 do 220 | Bigarray.Array1.set s i (int_of_char 'x'); 221 | done; 222 | assert_equal (write fd s) size; 223 | let t = Bytes.make size ' ' in 224 | read t; 225 | cmp_bytes t 'x' "write wrote bad data"; 226 | assert_equal (single_write fd s) size; 227 | read t; 228 | cmp_bytes t 'x' "write wrote bad data"; 229 | Unix.close fd; 230 | Unix.unlink name 231 | with exn -> Unix.close fd; Unix.unlink name; raise exn 232 | 233 | let () = 234 | let wrap test = 235 | with_unix_error (fun () -> test (); Gc.compact ()) 236 | in 237 | let tests = ("tests" >::: [ 238 | "endian_bigrray" >:: test_endian_bigarray; 239 | "pread_bigarray" >:: test_pread_bigarray; 240 | "pwrite_bigarray" >:: test_pwrite_bigarray; 241 | "substr" >:: test_substr; 242 | "read_bigarray" >:: test_read_bigarray; 243 | "write_bigarray" >:: test_write_bigarray; 244 | ]) in 245 | ignore (run_test_tt_main (test_decorate wrap tests)) 246 | --------------------------------------------------------------------------------