diff --git a/_oasis b/_oasis index 63c4961..298c5dc 100644 --- a/_oasis +++ b/_oasis @@ -13,7 +13,8 @@ Library mirage_block_unix Findlibname: mirage-block-unix Modules: Block BuildDepends: cstruct (>= 1.3.0), cstruct.lwt, lwt, lwt.unix, mirage-types, logs - CSources: odirect_stubs.c, blkgetsize_stubs.c, lseekhole_stubs.c + CSources: odirect_stubs.c, blkgetsize_stubs.c, lseekhole_stubs.c, flush_stubs.c + CCOpt: -I $(pkg_lwt) Executable test Build$: flag(tests) diff --git a/_tags b/_tags index 6b88e9f..714207d 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 20b3e491575421526a838c26f9aa4bd8) +# DO NOT EDIT (digest: 2523786f1804452927ad7ed0a182fe0f) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -16,6 +16,11 @@ true: annot, bin_annot "_darcs": not_hygienic # Library mirage_block_unix "lib/mirage_block_unix.cmxs": use_mirage_block_unix +: oasis_library_mirage_block_unix_ccopt +"lib/odirect_stubs.c": oasis_library_mirage_block_unix_ccopt +"lib/blkgetsize_stubs.c": oasis_library_mirage_block_unix_ccopt +"lib/lseekhole_stubs.c": oasis_library_mirage_block_unix_ccopt +"lib/flush_stubs.c": oasis_library_mirage_block_unix_ccopt : use_libmirage_block_unix_stubs : pkg_cstruct : pkg_cstruct.lwt @@ -41,6 +46,12 @@ true: annot, bin_annot "lib/lseekhole_stubs.c": pkg_lwt "lib/lseekhole_stubs.c": pkg_lwt.unix "lib/lseekhole_stubs.c": pkg_mirage-types +"lib/flush_stubs.c": pkg_cstruct +"lib/flush_stubs.c": pkg_cstruct.lwt +"lib/flush_stubs.c": pkg_logs +"lib/flush_stubs.c": pkg_lwt +"lib/flush_stubs.c": pkg_lwt.unix +"lib/flush_stubs.c": pkg_mirage-types # Executable test : pkg_cstruct : pkg_cstruct.lwt diff --git a/lib/block.ml b/lib/block.ml index d80c640..f9b64b9 100644 --- a/lib/block.ml +++ b/lib/block.ml @@ -264,13 +264,15 @@ let resize t new_size_sectors = ) ) +external flush_job: Unix.file_descr -> unit Lwt_unix.job = "mirage_block_unix_flush_job" + let flush t = match t.fd with | None -> return (`Error `Disconnected) | Some fd -> lwt_wrap_exn t "fsync" 0L (fun () -> - Lwt_unix.fsync fd + Lwt_unix.run_job (flush_job (Lwt_unix.unix_file_descr fd)) >>= fun () -> return (`Ok ()) ) diff --git a/lib/flush_stubs.c b/lib/flush_stubs.c new file mode 100644 index 0000000..0ac9b48 --- /dev/null +++ b/lib/flush_stubs.c @@ -0,0 +1,97 @@ +/* + * Copyright (c) 2016 Docker Inc + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + */ + +#include +#include +#include +#include +#include + +#ifdef WIN32 +#include +#include +#include +#include +#else +#define HANDLE int +#define DWORD int +#define Handle_val(x) Int_val(x) +#endif + +#include +#include +#include +#include +#include +#include +#include + +#include "lwt_unix.h" + +struct job_flush { + struct lwt_unix_job job; + HANDLE fd; + DWORD errno_copy; +}; + +static void worker_flush(struct job_flush *job) +{ + int result = 0; +#ifdef WIN32 + if (!FlushFileBuffers(job->fd)) { + job->errno_copy = GetLastError(); + } +#else + #if defined(__APPLE__) + result = fcntl(job->fd, F_FULLFSYNC); + #else + result = fsync(job->fd); + #endif + if (result == -1) { + job->errno_copy = errno; + } +#endif +} + +static value result_flush(struct job_flush *job) +{ + CAMLparam0 (); + int errno_copy = job->errno_copy; + lwt_unix_free_job(&job->job); + if (errno_copy != 0) { +#ifdef WIN32 + win32_maperr(errno_copy); + unix_error(errno_copy, "FlushFileBuffers", Nothing); +#else + #if defined(__APPLE__) + unix_error(errno_copy, "fcntl", Nothing); + #else + unix_error(errno_copy, "fsync", Nothing); + #endif +#endif + } + CAMLreturn(Val_unit); +} + +CAMLprim +value mirage_block_unix_flush_job(value handle) +{ + CAMLparam1(handle); + LWT_UNIX_INIT_JOB(job, flush, 0); + job->fd = (HANDLE)Handle_val(handle); + job->errno_copy = 0; + CAMLreturn(lwt_unix_alloc_job(&(job->job))); +} diff --git a/lib/libmirage_block_unix_stubs.clib b/lib/libmirage_block_unix_stubs.clib index 9575e9f..23df841 100644 --- a/lib/libmirage_block_unix_stubs.clib +++ b/lib/libmirage_block_unix_stubs.clib @@ -1,6 +1,7 @@ # OASIS_START -# DO NOT EDIT (digest: b668f9216e9c571614f025452abff2ec) +# DO NOT EDIT (digest: 51b18f9c3d31dfc97ba94ea12beaa69f) odirect_stubs.o blkgetsize_stubs.o lseekhole_stubs.o +flush_stubs.o # OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 80777b3..4670ff9 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 8eec8f510923827706e998bb7731650d) *) +(* DO NOT EDIT (digest: d9316f985ac4adc5c0a3c6191f188efc) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -29,6 +29,166 @@ module OASISGettext = struct end +module OASISString = struct +(* # 22 "src/oasis/OASISString.ml" *) + + + (** Various string utilities. + + Mostly inspired by extlib and batteries ExtString and BatString libraries. + + @author Sylvain Le Gall + *) + + + let nsplitf str f = + if str = "" then + [] + else + let buf = Buffer.create 13 in + let lst = ref [] in + let push () = + lst := Buffer.contents buf :: !lst; + Buffer.clear buf + in + let str_len = String.length str in + for i = 0 to str_len - 1 do + if f str.[i] then + push () + else + Buffer.add_char buf str.[i] + done; + push (); + List.rev !lst + + + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the + separator. + *) + let nsplit str c = + nsplitf str ((=) c) + + + let find ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + what_idx := 0; + incr str_idx + done; + if !what_idx <> String.length what then + raise Not_found + else + !str_idx - !what_idx + + + let sub_start str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str len (str_len - len) + + + let sub_end ?(offset=0) str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str 0 (str_len - len) + + + let starts_with ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + let ok = ref true in + while !ok && + !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + ok := false; + incr str_idx + done; + if !what_idx = String.length what then + true + else + false + + + let strip_starts_with ~what str = + if starts_with ~what str then + sub_start str (String.length what) + else + raise Not_found + + + let ends_with ~what ?(offset=0) str = + let what_idx = ref ((String.length what) - 1) in + let str_idx = ref ((String.length str) - 1) in + let ok = ref true in + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx + else + ok := false; + decr str_idx + done; + if !what_idx = -1 then + true + else + false + + + let strip_ends_with ~what str = + if ends_with ~what str then + sub_end str (String.length what) + else + raise Not_found + + + let replace_chars f s = + let buf = Buffer.create (String.length s) in + String.iter (fun c -> Buffer.add_char buf (f c)) s; + Buffer.contents buf + + let lowercase_ascii = + replace_chars + (fun c -> + if (c >= 'A' && c <= 'Z') then + Char.chr (Char.code c + 32) + else + c) + + let uncapitalize_ascii s = + if s <> "" then + (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s + + let uppercase_ascii = + replace_chars + (fun c -> + if (c >= 'a' && c <= 'z') then + Char.chr (Char.code c - 32) + else + c) + + let capitalize_ascii s = + if s <> "" then + (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s + +end + module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) @@ -129,7 +289,7 @@ module OASISExpr = struct end -# 132 "myocamlbuild.ml" +# 292 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -234,7 +394,7 @@ module BaseEnvLight = struct end -# 237 "myocamlbuild.ml" +# 397 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) @@ -516,7 +676,7 @@ module MyOCamlbuildBase = struct | nm, [], intf_modules -> ocaml_lib nm; let cmis = - List.map (fun m -> (String.uncapitalize m) ^ ".cmi") + List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis | nm, dir :: tl, intf_modules -> @@ -529,7 +689,7 @@ module MyOCamlbuildBase = struct ["compile"; "infer_interface"; "doc"]) tl; let cmis = - List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") + List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] cmis) @@ -603,13 +763,20 @@ module MyOCamlbuildBase = struct end -# 606 "myocamlbuild.ml" +# 766 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [("mirage_block_unix", ["lib"], [])]; lib_c = [("mirage_block_unix", "lib", [])]; - flags = []; + flags = + [ + (["oasis_library_mirage_block_unix_ccopt"; "compile"], + [ + (OASISExpr.EBool true, + S [A "-ccopt"; A "-I"; A "-ccopt"; A "${pkg_lwt}"]) + ]) + ]; includes = [("lib_test", ["lib"])] } ;; @@ -618,6 +785,6 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 622 "myocamlbuild.ml" +# 789 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index 7905e4e..53c1e22 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: b6d56741b04723eb3ff785b7285e36b8) *) +(* DO NOT EDIT (digest: 44e90654fb7ba124267eff52babcb5f2) *) (* - Regenerated by OASIS v0.4.5 + Regenerated by OASIS v0.4.6 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -246,6 +246,33 @@ module OASISString = struct String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf + let lowercase_ascii = + replace_chars + (fun c -> + if (c >= 'A' && c <= 'Z') then + Char.chr (Char.code c + 32) + else + c) + + let uncapitalize_ascii s = + if s <> "" then + (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s + + let uppercase_ascii = + replace_chars + (fun c -> + if (c >= 'a' && c <= 'z') then + Char.chr (Char.code c - 32) + else + c) + + let capitalize_ascii s = + if s <> "" then + (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s end @@ -315,19 +342,15 @@ module OASISUtils = struct let compare_csl s1 s2 = - String.compare (String.lowercase s1) (String.lowercase s2) + String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) module HashStringCsl = Hashtbl.Make (struct type t = string - - let equal s1 s2 = - (String.lowercase s1) = (String.lowercase s2) - - let hash s = - Hashtbl.hash (String.lowercase s) + let equal s1 s2 = (compare_csl s1 s2) = 0 + let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) end) module SetStringCsl = @@ -365,7 +388,7 @@ module OASISUtils = struct else buf in - String.lowercase buf + OASISString.lowercase_ascii buf end @@ -471,7 +494,7 @@ module PropList = struct order = Queue.create (); name_norm = (if case_insensitive then - String.lowercase + OASISString.lowercase_ascii else fun s -> s); } @@ -1822,13 +1845,13 @@ module OASISUnixPath = struct let capitalize_file f = let dir = dirname f in let base = basename f in - concat dir (String.capitalize base) + concat dir (OASISString.capitalize_ascii base) let uncapitalize_file f = let dir = dirname f in let base = basename f in - concat dir (String.uncapitalize base) + concat dir (OASISString.uncapitalize_ascii base) end @@ -2890,7 +2913,7 @@ module OASISFileUtil = struct end -# 2893 "setup.ml" +# 2916 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -2995,7 +3018,7 @@ module BaseEnvLight = struct end -# 2998 "setup.ml" +# 3021 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -5406,7 +5429,7 @@ module BaseSetup = struct end -# 5409 "setup.ml" +# 5432 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -5845,8 +5868,8 @@ module InternalInstallPlugin = struct let make_fnames modul sufx = List.fold_right begin fun sufx accu -> - (String.capitalize modul ^ sufx) :: - (String.uncapitalize modul ^ sufx) :: + (OASISString.capitalize_ascii modul ^ sufx) :: + (OASISString.uncapitalize_ascii modul ^ sufx) :: accu end sufx @@ -6270,7 +6293,7 @@ module InternalInstallPlugin = struct end -# 6273 "setup.ml" +# 6296 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -6648,7 +6671,7 @@ module OCamlbuildDocPlugin = struct end -# 6651 "setup.ml" +# 6674 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) @@ -6796,7 +6819,7 @@ module CustomPlugin = struct end -# 6799 "setup.ml" +# 6822 "setup.ml" open OASISTypes;; let setup_t = @@ -6940,10 +6963,12 @@ let setup_t = [ "odirect_stubs.c"; "blkgetsize_stubs.c"; - "lseekhole_stubs.c" + "lseekhole_stubs.c"; + "flush_stubs.c" ]; bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_ccopt = + [(OASISExpr.EBool true, ["-I"; "${pkg_lwt}"])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; @@ -7031,8 +7056,8 @@ let setup_t = plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.5"; - oasis_digest = Some "¯Çç\157\022ª\144k\007Â\156\003\020Ùé«"; + oasis_version = "0.4.6"; + oasis_digest = Some "Å&\002E±ýÍ\138ö\029ö\011\021\154â£"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7040,6 +7065,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7044 "setup.ml" +# 7069 "setup.ml" (* OASIS_STOP *) let () = setup ();;