From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620756438; cv=none; d=zohomail.com; s=zohoarc; b=mMHwK1V7jv37eCikzdAs+WrwGiSusEL8F9LOQM39c1BGREkaRgns4i1x1uk1Qmh6hiTt/C2EV9D/+YpmMSi15fhQrebDulLwisKCFQuULvUJ9NEue9BdC0xW/dCjvjF6pQgutOZMaLF10A7mkAWizarrNKIzNv+89/tDJItX2JI= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620756438; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=VwwWxbofqeW+bln5bpHY7QdSR/ALUoNdzA8l9ReoqoE=; b=TFDePCUswvZvYQqthuaNCZ+wTUE6nh6piFREt8mArDTgm6eRmFEf/YTS+gFh4O8SVvtdwFff4tOWn0LcKQYkVPphcUP5uHPh+ZZQcbHKxwTCqEDIZDbEL3CRZtfi0YKtrmkY7a2uQBNstr/MypL1tKBt4cg6dwvkW3LwgoLFrwY= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620756438326577.713290259964; Tue, 11 May 2021 11:07:18 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125900.237001 (Exim 4.92) (envelope-from ) id 1lgWmf-0001Ps-H5; Tue, 11 May 2021 18:07:05 +0000 Received: by outflank-mailman (output) from mailman id 125900.237001; Tue, 11 May 2021 18:07:05 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmf-0001Pl-Dm; Tue, 11 May 2021 18:07:05 +0000 Received: by outflank-mailman (input) for mailman id 125900; Tue, 11 May 2021 18:07:03 +0000 Received: from us1-rack-iad1.inumbo.com ([172.99.69.81]) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmd-0000hb-Pq for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:07:03 +0000 Received: from esa3.hc3370-68.iphmx.com (unknown [216.71.145.155]) by us1-rack-iad1.inumbo.com (Halon) with ESMTPS id 14ac971e-46fa-49c1-92ac-8e32a0151c57; Tue, 11 May 2021 18:06:54 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 14ac971e-46fa-49c1-92ac-8e32a0151c57 DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620756414; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=s2aBGweGMww0BGayyrFXSOFGfJlyB1IK+/pB0SJODd8=; b=KPwqoeBw7FcAG6ALJDV6OGEnwixHJZgTswzPxdpIdycbXu02xiMee1Ad WtuAQgqLu0AXTqdCreRLrV4n4JvaVPGzpSxuaRkhv62VcK3vW82G+ONCU py55mgrGoFVmH1szTMeWs+t1H8fdy6/b8SpkgGcApTSnNHgcuJHgSGtDt Q=; Authentication-Results: esa3.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: CC1zsBr/y4R9C1vbycjoeM34x5WOX++nyZQxUXs1mWepQr6wdkd9KquzfTu26GaKMb9rIV28Bf VkqG/NiLqAJN4s5eRzIwoLoat2Sg28bNpgLsomHzX5L1LW3VnVxzeo+x52Z60B8CoOKfP8aJj9 9hbUSg/SUl7SFIi8EErjV5KuS3+leimLLtWmCd2dZkffUyHFDvjlohuiFu6b7tgDFpvZuyqKgL 2Ko6WRTnV6OFSiT5M0C8ZoELGnm7T/eL9SSGF1gNtLxrOwrvvEgdSWd/mM804sYTPXD3jBbmm/ Osw= X-SBRS: 5.1 X-MesageID: 43579255 X-Ironport-Server: esa3.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:AyA/h6DE+dEyxXvlHelW55DYdb4zR+YMi2TDt3oddfWaSKylfq GV7ZAmPHrP4gr5N0tOpTntAse9qBDnhPtICOsqTNSftWDd0QPFEGgL1+DfKlbbak/DH4BmtJ uJc8JFeaDN5VoRt7eH3OFveexQv+Vu88qT9JnjJ28Gd3AMV0n5hT0JcTpyFCdNNW97LKt8Lr WwzOxdqQGtfHwGB/7LfEXsD4D41qT2fIuNW29/OyIa X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43579255" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Andrew Cooper" , George Dunlap , Ian Jackson , Jan Beulich , "Julien Grall" , Stefano Stabellini , Wei Liu Subject: [PATCH v2 01/17] docs/designs/xenstore-migration.md: clarify that deletes are recursive Date: Tue, 11 May 2021 19:05:14 +0100 Message-ID: <3d46415392bd8f90266b624a2ea9c220b3164d18.1620755942.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) Signed-off-by: Edwin T=C3=B6r=C3=B6k --- docs/designs/xenstore-migration.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/docs/designs/xenstore-migration.md b/docs/designs/xenstore-mig= ration.md index 5f1155273e..87ef540918 100644 --- a/docs/designs/xenstore-migration.md +++ b/docs/designs/xenstore-migration.md @@ -364,7 +364,8 @@ record previously present). | | 0x0001: read | | | 0x0002: written | | | | -| | The value will be zero for a deleted node | +| | The value will be zero for a recursively | +| | deleted node | | | | | `perm-count` | The number (N) of node permission specifiers | | | (which will be 0 for a node deleted in a | --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620756450; cv=none; d=zohomail.com; s=zohoarc; b=i8ReBZ3ZlIoZYe1njgwKbjGWukfkAwveGiGqBO/q4Vlomo9X09Ynx/DpEDW61A+dWznstRYZOPoSENrNksxPRX7ZDG7fTual0IuEHPezsWBudjmRZHOPrf2KWeVrOTIT/lrMmUZED+3qoIh2mcTRGQPx2/Otq+LKUff3g6+VzxI= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620756450; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=Iokita1PxYazlMZKGJwOLOH/WKGt3kPIOzit4+3LKxY=; b=MDrWM9iooHL+VOZvvWbqcLh0bj/012E8M0AUAfu0HPsJr7Fg+QwsDAVreVmT/DJ3M6wHsl+BF8OAjDNusFW//HHS+gpsq2owxWkOBwXiyj+J64oZj6NJZc3tceJ7hijFS500HQE6RqyAvyLFqbJj5AZQpZN4ude79PZZA9z0Rcs= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 162075645057620.3676799842641; Tue, 11 May 2021 11:07:30 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125901.237013 (Exim 4.92) (envelope-from ) id 1lgWmk-0001nz-Qg; Tue, 11 May 2021 18:07:10 +0000 Received: by outflank-mailman (output) from mailman id 125901.237013; Tue, 11 May 2021 18:07:10 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmk-0001no-Li; Tue, 11 May 2021 18:07:10 +0000 Received: by outflank-mailman (input) for mailman id 125901; Tue, 11 May 2021 18:07:08 +0000 Received: from us1-rack-iad1.inumbo.com ([172.99.69.81]) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmi-0000hb-Pw for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:07:08 +0000 Received: from esa1.hc3370-68.iphmx.com (unknown [216.71.145.142]) by us1-rack-iad1.inumbo.com (Halon) with ESMTPS id 09254c1f-cd3b-4beb-961a-f31b7ee5b6c1; Tue, 11 May 2021 18:06:58 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 09254c1f-cd3b-4beb-961a-f31b7ee5b6c1 DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620756418; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=aZQnD/ue/pcqfGJ1B3U3Ds8P1LU7rkGdfiBQesXOyvs=; b=Bsh+joSp9ubehxyeFsp0OBKM3X1ildEv2941iLvMNt+MTErlGwDwYW/p g/XiY0bojUGXd0Al2vPQ4s9/ZzJ7VbFWfTgOZ/7p0VbrZ1utHoplHJMlc BQruwQC6LAGVwoRa1eWheZELF3ZQv+VS6dToa09FyvoksrpFV9Ho5kdJN w=; Authentication-Results: esa1.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: zddHIAFWfMIgeURa1CfnJgKd/RtNaAjlYYDng/ZSmL96M1P9iL7XVVnUwfVNXKI67vgaI+LOVI +kEyw35KXTccct8VYNlMCmVHBiAeY27lj7enqNJnrnpljdPiDwu6Nj6m46bSJw8bdfLnpgAPAo 7Ddgcf+wRafZruBAr3ZLFVtFQrYXhskO2O/eYJfDoUEMBuun9opdi5wEBn5YveW6LwDeELYP3e RpNQKMu7T/0ynbzt2qTbhDt6VBqWyTCXJcg/ShFStmQxeZyXgM6CmXg0QYXqHS+EL0tQeKFpov OFY= X-SBRS: 5.1 X-MesageID: 43954237 X-Ironport-Server: esa1.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:7s5/Ra98dAr91pxwh6puk+Hxdb1zdoMgy1knxilNoENuH/Bwxv rFoB1E73TJYW4qKQodcdDpAtjifZquz+8O3WBxB8bpYOCCggeVxe5ZnOzfKlHbehEWs9QtrZ uIEJIOReEYb2IK6/oSiTPQe7lP/DDEytHQuQ609QYOcegeUdAF0+4PMHf/LqQZfml7LKt8MK DZyttMpjKmd3hSRN+8HGM5U+/KoMCOvI76YDYdbiRXpzWmvHeN0vrXAhKY1hARX3dk2rE561 XIlAT/++GKr+y78BnBzGXehq4m1ucJi+EzRfBkuPJlaQkEuTzYJriJnIfy+QzdldvfqGrCVu O85yvIcf4DrE85NVvF3CcFkzOQrArGrUWShWNwyEGT3vDRVXY0DdFMipledQac4008vMtk2K YOxG6BsYFLZCmw1RgVyuK4IC2CrHDE10bKUNRj/UC3WrFuIIO5bbZviH+9Na1wVx4SxLpXYN WGPfuskcq+K2nqHkwxllMfs+BEcE5DYCu7fg== X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43954237" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 02/17] tools/ocaml: add unit test skeleton with Dune build system Date: Tue, 11 May 2021 19:05:15 +0100 Message-ID: X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) Based on initial work by Christian Lindig Doing oxenstored development, especially fuzzing/unit tests requires an incremental and fast build system. Dune is the preferred upstream build system for OCaml, and has been in use by the XAPI project for years. Is is incremental and also generates editor integration files (.merlin). Usage: ./xs-reconfigure.sh cd tools/ocaml make clean make check There are some other convenience targets as well: make dune-clean make dune-syntax-check make dune-build-oxenstored There are some files that are generated by Make, these are created by a 'dune-pre' target, they are too closely tied to make and cannot yet be generated by Dune itself. The various Makefile targets are used as entrypoints into Dune that set the needed env vars (for C include files and libraries) and ensure that the generated files are available. The unit tests do not require Xen to be available, so add mock eventchn and xenctrl libraries for the unit test to use, and copy the non-system specific modules from xenstored/ to xenstored/test/. Xenstored had to be split into Xenstored and Xenstored_main, so that we can use the functions defined in Xenstored without actually starting up the daemon in a unit test. Similarly argument parsing had to be delayed until after daemon startup. Also had to disable setrlimit when running as non-root in poll.ml. Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/.gitignore | 2 + tools/ocaml/Makefile | 33 +++++++++++++ tools/ocaml/dune-project | 5 ++ tools/ocaml/libs/eventchn/dune | 8 ++++ tools/ocaml/libs/mmap/dune | 8 ++++ tools/ocaml/libs/xb/dune | 7 +++ tools/ocaml/libs/xc/dune | 9 ++++ tools/ocaml/libs/xs/dune | 4 ++ tools/ocaml/xen.opam | 1 + tools/ocaml/xenstore.opam | 1 + tools/ocaml/xenstored.opam | 21 ++++++++ tools/ocaml/xenstored/Makefile | 3 +- tools/ocaml/xenstored/dune | 19 ++++++++ tools/ocaml/xenstored/parse_arg.ml | 2 +- tools/ocaml/xenstored/poll.ml | 3 +- tools/ocaml/xenstored/test/dune | 11 +++++ tools/ocaml/xenstored/test/xenctrl.ml | 48 +++++++++++++++++++ tools/ocaml/xenstored/test/xeneventchn.ml | 50 ++++++++++++++++++++ tools/ocaml/xenstored/test/xenstored_test.ml | 2 + tools/ocaml/xenstored/xenstored.ml | 4 +- tools/ocaml/xenstored/xenstored_main.ml | 1 + 21 files changed, 237 insertions(+), 5 deletions(-) create mode 100644 tools/ocaml/.gitignore create mode 100644 tools/ocaml/dune-project create mode 100644 tools/ocaml/libs/eventchn/dune create mode 100644 tools/ocaml/libs/mmap/dune create mode 100644 tools/ocaml/libs/xb/dune create mode 100644 tools/ocaml/libs/xc/dune create mode 100644 tools/ocaml/libs/xs/dune create mode 100644 tools/ocaml/xen.opam create mode 100644 tools/ocaml/xenstore.opam create mode 100644 tools/ocaml/xenstored.opam create mode 100644 tools/ocaml/xenstored/dune create mode 100644 tools/ocaml/xenstored/test/dune create mode 100644 tools/ocaml/xenstored/test/xenctrl.ml create mode 100644 tools/ocaml/xenstored/test/xeneventchn.ml create mode 100644 tools/ocaml/xenstored/test/xenstored_test.ml create mode 100644 tools/ocaml/xenstored/xenstored_main.ml diff --git a/tools/ocaml/.gitignore b/tools/ocaml/.gitignore new file mode 100644 index 0000000000..655e32b07c --- /dev/null +++ b/tools/ocaml/.gitignore @@ -0,0 +1,2 @@ +_build +.merlin diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile index a7c04b6546..53dd0a0f0d 100644 --- a/tools/ocaml/Makefile +++ b/tools/ocaml/Makefile @@ -34,3 +34,36 @@ build-tools-oxenstored: $(MAKE) -s -C libs/xb $(MAKE) -s -C libs/xc $(MAKE) -C xenstored + +LIBRARY_PATH=3D$(XEN_libxenctrl):$(XEN_libxenguest):$(XEN_libxentoollog):$= (XEN_libxencall):$(XEN_libxenevtchn):$(XEN_libxenforeignmemory):$(XEN_libxe= ngnttab):$(XEN_libxendevicemodel):$(XEN_libxentoolcore) +C_INCLUDE_PATH=3D$(XEN_libxenctrl)/include:$(XEN_libxengnttab)/include:$(X= EN_libxenevtchn)/include:$(XEN_libxentoollog)/include:$(XEN_INCLUDE) + +# Files generated by the Makefile +# These cannot be generated from dune, because dune cannot refer to files +# in the parent directory (so it couldn't copy/use Config.mk) +.PHONY: dune-pre +dune-pre: + $(MAKE) -s -C ../../ build-tools-public-headers + $(MAKE) -s -C libs/xs paths.ml + $(MAKE) -s -C libs/xc xenctrl_abi_check.h + $(MAKE) -s -C xenstored paths.ml _paths.h + +.PHONY: check +check: dune-pre + # --force isn't necessary here if the test is deterministic + OCAMLRUNPARAM=3Db C_INCLUDE_PATH=3D$(C_INCLUDE_PATH) dune runtest --profi= le=3Drelease --no-buffer --force + +# Convenience targets for development + +.PHONY: dune-clean +dune-clean: + $(MAKE) clean + dune clean + +.PHONY: dune-syntax-check +dune-syntax-check: dune-pre + LIBRARY_PATH=3D$(LIBRARY_PATH) C_INCLUDE_PATH=3D$(C_INCLUDE_PATH) dune bu= ild --profile=3Drelease @check + +.PHONY: build-oxenstored-dune +dune-build-oxenstored: dune-pre + LD_LIBRARY_PATH=3D$(LIBRARY_PATH) LIBRARY_PATH=3D$(LIBRARY_PATH) C_INCLUD= E_PATH=3D$(C_INCLUDE_PATH) dune build --profile=3Drelease @all diff --git a/tools/ocaml/dune-project b/tools/ocaml/dune-project new file mode 100644 index 0000000000..b41cfae68b --- /dev/null +++ b/tools/ocaml/dune-project @@ -0,0 +1,5 @@ +(lang dune 2.0) + +(name xen) + +(formatting disabled) diff --git a/tools/ocaml/libs/eventchn/dune b/tools/ocaml/libs/eventchn/dune new file mode 100644 index 0000000000..e08bc76fdf --- /dev/null +++ b/tools/ocaml/libs/eventchn/dune @@ -0,0 +1,8 @@ +(library + (foreign_stubs + (language c) + (names xeneventchn_stubs)) + (name xeneventchn) + (public_name xen.eventchn) + (libraries unix) + (c_library_flags -lxenevtchn)) diff --git a/tools/ocaml/libs/mmap/dune b/tools/ocaml/libs/mmap/dune new file mode 100644 index 0000000000..a47de44e47 --- /dev/null +++ b/tools/ocaml/libs/mmap/dune @@ -0,0 +1,8 @@ +(library + (foreign_stubs + (language c) + (names xenmmap_stubs)) + (name xenmmap) + (public_name xen.mmap) + (libraries unix) + (install_c_headers mmap_stubs)) diff --git a/tools/ocaml/libs/xb/dune b/tools/ocaml/libs/xb/dune new file mode 100644 index 0000000000..feb30adc01 --- /dev/null +++ b/tools/ocaml/libs/xb/dune @@ -0,0 +1,7 @@ +(library + (foreign_stubs + (language c) + (names xenbus_stubs xs_ring_stubs)) + (name xenbus) + (public_name xen.bus) + (libraries unix xenmmap)) diff --git a/tools/ocaml/libs/xc/dune b/tools/ocaml/libs/xc/dune new file mode 100644 index 0000000000..fb75ee8ff7 --- /dev/null +++ b/tools/ocaml/libs/xc/dune @@ -0,0 +1,9 @@ +(library + (foreign_stubs + (language c) + (names xenctrl_stubs)) + (name xenctrl) + (public_name xen.ctrl) + (libraries unix xenmmap) + (c_library_flags -lxenctrl -lxenguest -lxencall -lxenforeignmemory + -lxengnttab)) diff --git a/tools/ocaml/libs/xs/dune b/tools/ocaml/libs/xs/dune new file mode 100644 index 0000000000..c79ea75775 --- /dev/null +++ b/tools/ocaml/libs/xs/dune @@ -0,0 +1,4 @@ +(library + (name xenstore) + (public_name xen.store) + (libraries unix xenbus)) diff --git a/tools/ocaml/xen.opam b/tools/ocaml/xen.opam new file mode 100644 index 0000000000..013b84db61 --- /dev/null +++ b/tools/ocaml/xen.opam @@ -0,0 +1 @@ +opam-version: "2.0" diff --git a/tools/ocaml/xenstore.opam b/tools/ocaml/xenstore.opam new file mode 100644 index 0000000000..013b84db61 --- /dev/null +++ b/tools/ocaml/xenstore.opam @@ -0,0 +1 @@ +opam-version: "2.0" diff --git a/tools/ocaml/xenstored.opam b/tools/ocaml/xenstored.opam new file mode 100644 index 0000000000..a226328e43 --- /dev/null +++ b/tools/ocaml/xenstored.opam @@ -0,0 +1,21 @@ +opam-version: "2.0" +synopsis: "In-memory key-value store for the Xen hypervisor" +maintainer: "lindig@gmail.com" +authors: "lindig@gmail.com" +license: "LGPL" +homepage: "https://github.com/lindig/xen-ocaml-tools" +bug-reports: "https://github.com/lindig/xen-ocaml-tools/issues" +depends: [ + "ocaml" + "dune" {build} + "base-unix" + + "crowbar" {with-test} + "fmt" {with-test} + + "crowbar" + "fmt" +] +build: ["dune" "build" "-p" name "-j" jobs] +depexts: ["m4" "libxen-dev" "libsystemd-dev"] {os-distribution =3D "debian= "} +dev-repo: "git+https://github.com/lindig/xen-ocaml-tools.git" diff --git a/tools/ocaml/xenstored/Makefile b/tools/ocaml/xenstored/Makefile index 89ec3ec76a..9d2da206d8 100644 --- a/tools/ocaml/xenstored/Makefile +++ b/tools/ocaml/xenstored/Makefile @@ -56,7 +56,8 @@ OBJS =3D paths \ history \ parse_arg \ process \ - xenstored + xenstored \ + xenstored_main =20 INTF =3D symbol.cmi trie.cmi syslog.cmi systemd.cmi poll.cmi =20 diff --git a/tools/ocaml/xenstored/dune b/tools/ocaml/xenstored/dune new file mode 100644 index 0000000000..714a2ae07e --- /dev/null +++ b/tools/ocaml/xenstored/dune @@ -0,0 +1,19 @@ +(executable + (modes byte exe) + (name xenstored_main) + (modules (:standard \ syslog systemd)) + (public_name oxenstored) + (package xenstored) + (flags (:standard -w -52)) + (libraries unix xen.bus xen.mmap xen.ctrl xen.eventchn xenstubs)) + +(library + (foreign_stubs + (language c) + (names syslog_stubs systemd_stubs select_stubs) + (flags (-DHAVE_SYSTEMD))) + (modules syslog systemd) + (name xenstubs) + (wrapped false) + (libraries unix) + (c_library_flags -lsystemd)) diff --git a/tools/ocaml/xenstored/parse_arg.ml b/tools/ocaml/xenstored/par= se_arg.ml index 7c0478e76a..965cb9ebeb 100644 --- a/tools/ocaml/xenstored/parse_arg.ml +++ b/tools/ocaml/xenstored/parse_arg.ml @@ -28,7 +28,7 @@ type config =3D disable_socket: bool; } =20 -let do_argv =3D +let do_argv () =3D let pidfile =3D ref "" and tracefile =3D ref "" (* old xenstored compatib= ility *) and domain_init =3D ref true and activate_access_log =3D ref true diff --git a/tools/ocaml/xenstored/poll.ml b/tools/ocaml/xenstored/poll.ml index 26f8620dfc..92e0717ed2 100644 --- a/tools/ocaml/xenstored/poll.ml +++ b/tools/ocaml/xenstored/poll.ml @@ -64,4 +64,5 @@ let poll_select in_fds out_fds exc_fds timeout =3D a r =20 let () =3D - set_fd_limit (get_sys_fs_nr_open ()) + if Unix.geteuid () =3D 0 then + set_fd_limit (get_sys_fs_nr_open ()) diff --git a/tools/ocaml/xenstored/test/dune b/tools/ocaml/xenstored/test/d= une new file mode 100644 index 0000000000..2a3eb2b7df --- /dev/null +++ b/tools/ocaml/xenstored/test/dune @@ -0,0 +1,11 @@ +(copy_files# ../*.ml{,i}) + +(test + (modes native) + (ocamlopt_flags -afl-instrument) + (name xenstored_test) + (modules (:standard \ syslog systemd)) + (package xenstored) + (flags (:standard -w -52)) + ;;(action (run %{test} -v --seed 364172147)) + (libraries unix xen.bus xen.mmap xenstubs crowbar xen.store fmt fmt.tty)) diff --git a/tools/ocaml/xenstored/test/xenctrl.ml b/tools/ocaml/xenstored/= test/xenctrl.ml new file mode 100644 index 0000000000..37d6da0a47 --- /dev/null +++ b/tools/ocaml/xenstored/test/xenctrl.ml @@ -0,0 +1,48 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** *) +type domid =3D int + +(* ** xenctrl.h ** *) + + +type domaininfo =3D +{ + domid : domid; + dying : bool; + shutdown : bool; + shutdown_code : int; +} + +exception Error of string + +type handle =3D unit + +let interface_open () =3D () +let interface_close () =3D () + +let domain_getinfo () domid =3D { + domid =3D domid; + dying =3D false; + shutdown =3D false; + shutdown_code =3D 0; +} + +let devzero =3D Unix.openfile "/dev/zero" [] 0 +let nullmap () =3D Xenmmap.mmap devzero Xenmmap.RDWR Xenmmap.PRIVATE 4096= 0 + +let map_foreign_range _ _ _ _ =3D nullmap () diff --git a/tools/ocaml/xenstored/test/xeneventchn.ml b/tools/ocaml/xensto= red/test/xeneventchn.ml new file mode 100644 index 0000000000..6612722dc2 --- /dev/null +++ b/tools/ocaml/xenstored/test/xeneventchn.ml @@ -0,0 +1,50 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type handle =3D Unix.file_descr * int ref + +let devnull =3D Unix.openfile "/dev/null" [] 0 +let init () =3D devnull, ref 0 +let fd (h, _) =3D h + +type t =3D int + +type virq_t =3D + | Timer (* #define VIRQ_TIMER 0 *) + | Debug (* #define VIRQ_DEBUG 1 *) + | Console (* #define VIRQ_CONSOLE 2 *) + | Dom_exc (* #define VIRQ_DOM_EXC 3 *) + | Tbuf (* #define VIRQ_TBUF 4 *) + | Reserved_5 (* Do not use this value as it's not defined *) + | Debugger (* #define VIRQ_DEBUGGER 6 *) + | Xenoprof (* #define VIRQ_XENOPROF 7 *) + | Con_ring (* #define VIRQ_CON_RING 8 *) + | Pcpu_state (* #define VIRQ_PCPU_STATE 9 *) + | Mem_event (* #define VIRQ_MEM_EVENT 10 *) + | Xc_reserved (* #define VIRQ_XC_RESERVED 11 *) + | Enomem (* #define VIRQ_ENOMEM 12 *) + | Xenpmu (* #define VIRQ_XENPMU 13 *) + +let notify _h _ =3D () +let bind_interdomain (_h, port) domid remote_port =3D incr port; !port +let bind_virq (_h, port) _ =3D incr port; !port +let bind_dom_exc_virq handle =3D bind_virq handle Dom_exc +let unbind _ _ =3D () +let pending (_h, port) =3D !port +let unmask _ _ =3D () + +let to_int x =3D x +let of_int x =3D x diff --git a/tools/ocaml/xenstored/test/xenstored_test.ml b/tools/ocaml/xen= stored/test/xenstored_test.ml new file mode 100644 index 0000000000..e86b68e867 --- /dev/null +++ b/tools/ocaml/xenstored/test/xenstored_test.ml @@ -0,0 +1,2 @@ +open Xenstored +let () =3D () diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xen= stored.ml index d44ae673c4..ae2eab498a 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -265,8 +265,8 @@ let to_file store cons fds file =3D (fun () -> close_out channel) end =20 -let _ =3D - let cf =3D do_argv in +let main () =3D + let cf =3D do_argv () in let pidfile =3D if Sys.file_exists (config_filename cf) then parse_config (config_filename cf) diff --git a/tools/ocaml/xenstored/xenstored_main.ml b/tools/ocaml/xenstore= d/xenstored_main.ml new file mode 100644 index 0000000000..929dd62fb4 --- /dev/null +++ b/tools/ocaml/xenstored/xenstored_main.ml @@ -0,0 +1 @@ +let () =3D Xenstored.main () --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620757914; cv=none; d=zohomail.com; s=zohoarc; b=ljZhbwsbHyUIUscSS975b8HwpzpwWTTCNrTip6N2YYt76Nh/dQK4Zjp0voHiBvOguteOcTGvSKYbsEH1YMBaU8LM3+IMn68h60an7gfjm27YOw7qeSBEhk7vSfMkLh8DjY9ky04Bqr8R/7eFteouPWWDgQoeTSDu6srpRfsF/f0= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620757914; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=NsCx0uUbCfsR7amboa8be0SYB1E1r2J1pzqiP7qjOzI=; b=ab4Wc0z46zoNO4C4TdU4Vxso9VI7OJ/2HMNZ90W1mSHtc6Ta6aLkRbfauJCOUetug+7NMOU09AT5+EHq2y/5gVzGfTh94HakB6eknMkmUyo0qwfdniRJ/WyfCJhdIS0XevGKa3UScM/KoXoj1j1uPwILPnX2V5zqrIiJiDDhLrI= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620757914180779.501496317185; Tue, 11 May 2021 11:31:54 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125904.237181 (Exim 4.92) (envelope-from ) id 1lgXA4-0005yX-4v; Tue, 11 May 2021 18:31:16 +0000 Received: by outflank-mailman (output) from mailman id 125904.237181; Tue, 11 May 2021 18:31:16 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgXA3-0005yQ-Vf; Tue, 11 May 2021 18:31:16 +0000 Received: by outflank-mailman (input) for mailman id 125904; Tue, 11 May 2021 18:07:15 +0000 Received: from all-amaz-eas1.inumbo.com ([34.197.232.57] helo=us1-amaz-eas2.inumbo.com) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmp-0001nY-D7 for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:07:15 +0000 Received: from esa6.hc3370-68.iphmx.com (unknown [216.71.155.175]) by us1-amaz-eas2.inumbo.com (Halon) with ESMTPS id c0f3be8a-b68c-4083-bba1-8f900dcae6d6; Tue, 11 May 2021 18:07:04 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: c0f3be8a-b68c-4083-bba1-8f900dcae6d6 DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620756424; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=mqm2Gc2+qWUMHLmZhD/y0DMFCobF8xyc73SR1mUL2Zk=; b=YPHNBCdk6xvq6UP4s3Py/VzpSWT23KQmDPeAl0niTBcS6LDCIVCbJpJq yRvfyTwZGTK6c5+I9mBjUFjA8WEq6e6m0cWkaXl7745V1Q5sabmMhhl5n YLJJp5z2lUcKWeSMjGrbSuO1cBLcVyMmzAxf3SYZTZCqIPpvQ6O/TDIbo g=; Authentication-Results: esa6.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: 1JaAF9mkjSkZ3gvBYIVoB/P1FtA7/TLd4oBXFG/ieOf2o0oudjxMxYNDpJojsNo1ccs/iwtWsn TSKi6K0fEdQ5Xu/CYfBiEvGk6o6VSV+dnarfi4CSsnBR+Xt9n7Do+IeiMIU88E/Hj9RAj1MEw3 gDVpHGQuX8n7BrGyGZmJyfvtsOxpNLzWp99LMc8sfgkhBJw/4cJsIohzwRLW4GaMOS3zTs4rJw sPY65tApe+LT0J3ukaNwXbvXVwAdWm+4OwBht36iaImCck6IsShXW64To4wq/hC2tQfGq0NAmP iYo= X-SBRS: 5.1 X-MesageID: 43675373 X-Ironport-Server: esa6.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:R4IWCqOp+jXA4MBcTjujsMiBIKoaSvp037BK7S1MoNJuEvBw9v re+MjzsCWftN9/Yh4dcLy7VpVoIkmskKKdg7NhXotKNTOO0AeVxelZhrcKqAeQeREWmNQ96U 9hGZIOdeEZDzJB/LrHCN/TKade/DGFmprY+9s31x1WPGZXgzkL1XYDNu6ceHcGIjVuNN4CO7 e3wNFInDakcWR/VLXAOpFUN9Kz3uEijfjdEGY7OyI= X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43675373" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 03/17] tools/ocaml: vendor external dependencies for convenience Date: Tue, 11 May 2021 19:05:16 +0100 Message-ID: <878863919ef8eea9fc715d5b86f6f0a9eb75b0be.1620755942.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) To run the unit tests these dependencies need to be available. The developer can either install them themselves using opam, or we can add them as subdirs here. Dune will automatically pick the libraries from the system or build it from the subdir as needed, no changes to the dune files are needed. The duniverse/ subdir was generated by using the 'opam monorepo' command: https://github.com/ocamllabs/opam-monorepo This wrote a lockfile (xen.opam.locked) containing tarball sources and hashes, and then opam monorepo pull downloaded the sources. Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/duniverse/cmdliner/.gitignore | 10 + tools/ocaml/duniverse/cmdliner/.ocp-indent | 1 + tools/ocaml/duniverse/cmdliner/B0.ml | 9 + tools/ocaml/duniverse/cmdliner/CHANGES.md | 255 +++ tools/ocaml/duniverse/cmdliner/LICENSE.md | 13 + tools/ocaml/duniverse/cmdliner/Makefile | 77 + tools/ocaml/duniverse/cmdliner/README.md | 51 + tools/ocaml/duniverse/cmdliner/_tags | 3 + tools/ocaml/duniverse/cmdliner/build.ml | 155 ++ tools/ocaml/duniverse/cmdliner/cmdliner.opam | 32 + tools/ocaml/duniverse/cmdliner/doc/api.odocl | 1 + tools/ocaml/duniverse/cmdliner/dune-project | 2 + tools/ocaml/duniverse/cmdliner/pkg/META | 7 + tools/ocaml/duniverse/cmdliner/pkg/pkg.ml | 33 + .../ocaml/duniverse/cmdliner/src/cmdliner.ml | 309 ++++ .../ocaml/duniverse/cmdliner/src/cmdliner.mli | 1624 +++++++++++++++++ .../duniverse/cmdliner/src/cmdliner.mllib | 11 + .../duniverse/cmdliner/src/cmdliner_arg.ml | 356 ++++ .../duniverse/cmdliner/src/cmdliner_arg.mli | 111 ++ .../duniverse/cmdliner/src/cmdliner_base.ml | 302 +++ .../duniverse/cmdliner/src/cmdliner_base.mli | 68 + .../duniverse/cmdliner/src/cmdliner_cline.ml | 199 ++ .../duniverse/cmdliner/src/cmdliner_cline.mli | 34 + .../duniverse/cmdliner/src/cmdliner_docgen.ml | 352 ++++ .../cmdliner/src/cmdliner_docgen.mli | 30 + .../duniverse/cmdliner/src/cmdliner_info.ml | 233 +++ .../duniverse/cmdliner/src/cmdliner_info.mli | 140 ++ .../cmdliner/src/cmdliner_manpage.ml | 502 +++++ .../cmdliner/src/cmdliner_manpage.mli | 100 + .../duniverse/cmdliner/src/cmdliner_msg.ml | 116 ++ .../duniverse/cmdliner/src/cmdliner_msg.mli | 56 + .../cmdliner/src/cmdliner_suggest.ml | 54 + .../cmdliner/src/cmdliner_suggest.mli | 25 + .../duniverse/cmdliner/src/cmdliner_term.ml | 41 + .../duniverse/cmdliner/src/cmdliner_term.mli | 40 + .../duniverse/cmdliner/src/cmdliner_trie.ml | 97 + .../duniverse/cmdliner/src/cmdliner_trie.mli | 35 + tools/ocaml/duniverse/cmdliner/src/dune | 4 + tools/ocaml/duniverse/cmdliner/test/chorus.ml | 31 + tools/ocaml/duniverse/cmdliner/test/cp_ex.ml | 54 + .../ocaml/duniverse/cmdliner/test/darcs_ex.ml | 149 ++ tools/ocaml/duniverse/cmdliner/test/dune | 12 + tools/ocaml/duniverse/cmdliner/test/revolt.ml | 9 + tools/ocaml/duniverse/cmdliner/test/rm_ex.ml | 53 + .../ocaml/duniverse/cmdliner/test/tail_ex.ml | 73 + .../ocaml/duniverse/cmdliner/test/test_man.ml | 100 + .../duniverse/cmdliner/test/test_man_utf8.ml | 11 + .../duniverse/cmdliner/test/test_opt_req.ml | 13 + .../ocaml/duniverse/cmdliner/test/test_pos.ml | 13 + .../duniverse/cmdliner/test/test_pos_all.ml | 11 + .../duniverse/cmdliner/test/test_pos_left.ml | 11 + .../duniverse/cmdliner/test/test_pos_req.ml | 15 + .../duniverse/cmdliner/test/test_pos_rev.ml | 14 + .../duniverse/cmdliner/test/test_term_dups.ml | 19 + .../cmdliner/test/test_with_used_args.ml | 18 + tools/ocaml/duniverse/cppo/.gitignore | 5 + tools/ocaml/duniverse/cppo/.ocp-indent | 22 + tools/ocaml/duniverse/cppo/.travis.yml | 16 + tools/ocaml/duniverse/cppo/CODEOWNERS | 8 + tools/ocaml/duniverse/cppo/Changes | 85 + tools/ocaml/duniverse/cppo/INSTALL.md | 17 + tools/ocaml/duniverse/cppo/LICENSE.md | 24 + tools/ocaml/duniverse/cppo/Makefile | 18 + tools/ocaml/duniverse/cppo/README.md | 521 ++++++ tools/ocaml/duniverse/cppo/VERSION | 1 + tools/ocaml/duniverse/cppo/appveyor.yml | 14 + tools/ocaml/duniverse/cppo/cppo.opam | 31 + .../ocaml/duniverse/cppo/cppo_ocamlbuild.opam | 27 + tools/ocaml/duniverse/cppo/dune-project | 3 + tools/ocaml/duniverse/cppo/examples/Makefile | 8 + tools/ocaml/duniverse/cppo/examples/debug.ml | 7 + tools/ocaml/duniverse/cppo/examples/dune | 32 + tools/ocaml/duniverse/cppo/examples/french.ml | 34 + tools/ocaml/duniverse/cppo/examples/lexer.mll | 9 + .../duniverse/cppo/ocamlbuild_plugin/_tags | 1 + .../duniverse/cppo/ocamlbuild_plugin/dune | 6 + .../cppo/ocamlbuild_plugin/ocamlbuild_cppo.ml | 35 + .../ocamlbuild_plugin/ocamlbuild_cppo.mli | 9 + tools/ocaml/duniverse/cppo/src/compat.ml | 7 + .../ocaml/duniverse/cppo/src/cppo_command.ml | 63 + .../ocaml/duniverse/cppo/src/cppo_command.mli | 11 + tools/ocaml/duniverse/cppo/src/cppo_eval.ml | 697 +++++++ tools/ocaml/duniverse/cppo/src/cppo_eval.mli | 29 + tools/ocaml/duniverse/cppo/src/cppo_lexer.mll | 721 ++++++++ tools/ocaml/duniverse/cppo/src/cppo_main.ml | 230 +++ .../ocaml/duniverse/cppo/src/cppo_parser.mly | 266 +++ tools/ocaml/duniverse/cppo/src/cppo_types.ml | 98 + tools/ocaml/duniverse/cppo/src/cppo_types.mli | 70 + .../ocaml/duniverse/cppo/src/cppo_version.mli | 1 + tools/ocaml/duniverse/cppo/src/dune | 21 + tools/ocaml/duniverse/cppo/test/capital.cppo | 6 + tools/ocaml/duniverse/cppo/test/capital.ref | 6 + tools/ocaml/duniverse/cppo/test/comments.cppo | 7 + tools/ocaml/duniverse/cppo/test/comments.ref | 8 + tools/ocaml/duniverse/cppo/test/cond.cppo | 47 + tools/ocaml/duniverse/cppo/test/cond.ref | 17 + tools/ocaml/duniverse/cppo/test/dune | 130 ++ tools/ocaml/duniverse/cppo/test/ext.cppo | 10 + tools/ocaml/duniverse/cppo/test/ext.ref | 28 + tools/ocaml/duniverse/cppo/test/incl.cppo | 3 + tools/ocaml/duniverse/cppo/test/incl2.cppo | 1 + tools/ocaml/duniverse/cppo/test/loc.cppo | 8 + tools/ocaml/duniverse/cppo/test/loc.ref | 21 + .../ocaml/duniverse/cppo/test/paren_arg.cppo | 3 + tools/ocaml/duniverse/cppo/test/paren_arg.ref | 4 + tools/ocaml/duniverse/cppo/test/source.sh | 13 + tools/ocaml/duniverse/cppo/test/test.cppo | 144 ++ tools/ocaml/duniverse/cppo/test/tuple.cppo | 38 + tools/ocaml/duniverse/cppo/test/tuple.ref | 20 + .../ocaml/duniverse/cppo/test/unmatched.cppo | 14 + tools/ocaml/duniverse/cppo/test/unmatched.ref | 15 + tools/ocaml/duniverse/cppo/test/version.cppo | 30 + tools/ocaml/duniverse/crowbar/.gitignore | 5 + tools/ocaml/duniverse/crowbar/CHANGES.md | 9 + tools/ocaml/duniverse/crowbar/LICENSE.md | 8 + tools/ocaml/duniverse/crowbar/README.md | 82 + tools/ocaml/duniverse/crowbar/crowbar.opam | 33 + tools/ocaml/duniverse/crowbar/dune | 1 + tools/ocaml/duniverse/crowbar/dune-project | 2 + .../duniverse/crowbar/examples/.gitignore | 1 + .../duniverse/crowbar/examples/calendar/dune | 3 + .../examples/calendar/test_calendar.ml | 29 + .../duniverse/crowbar/examples/fpath/dune | 4 + .../crowbar/examples/fpath/test_fpath.ml | 18 + .../duniverse/crowbar/examples/input/testcase | 1 + .../ocaml/duniverse/crowbar/examples/map/dune | 3 + .../crowbar/examples/map/test_map.ml | 47 + .../duniverse/crowbar/examples/pprint/dune | 3 + .../crowbar/examples/pprint/test_pprint.ml | 39 + .../crowbar/examples/serializer/dune | 3 + .../crowbar/examples/serializer/serializer.ml | 34 + .../examples/serializer/test_serializer.ml | 47 + .../duniverse/crowbar/examples/uunf/dune | 3 + .../crowbar/examples/uunf/test_uunf.ml | 75 + .../duniverse/crowbar/examples/xmldiff/dune | 3 + .../crowbar/examples/xmldiff/test_xmldiff.ml | 42 + tools/ocaml/duniverse/crowbar/src/crowbar.ml | 582 ++++++ tools/ocaml/duniverse/crowbar/src/crowbar.mli | 251 +++ tools/ocaml/duniverse/crowbar/src/dune | 3 + tools/ocaml/duniverse/crowbar/src/todo | 16 + tools/ocaml/duniverse/csexp/CHANGES.md | 45 + tools/ocaml/duniverse/csexp/LICENSE.md | 21 + tools/ocaml/duniverse/csexp/Makefile | 23 + tools/ocaml/duniverse/csexp/README.md | 33 + .../duniverse/csexp/bench/csexp_bench.ml | 22 + tools/ocaml/duniverse/csexp/bench/dune | 11 + tools/ocaml/duniverse/csexp/bench/main.ml | 1 + tools/ocaml/duniverse/csexp/bench/runner.sh | 4 + tools/ocaml/duniverse/csexp/csexp.opam | 51 + .../ocaml/duniverse/csexp/csexp.opam.template | 14 + tools/ocaml/duniverse/csexp/dune-project | 42 + .../ocaml/duniverse/csexp/dune-workspace.dev | 6 + tools/ocaml/duniverse/csexp/src/csexp.ml | 333 ++++ tools/ocaml/duniverse/csexp/src/csexp.mli | 369 ++++ tools/ocaml/duniverse/csexp/src/dune | 3 + tools/ocaml/duniverse/csexp/test/dune | 6 + tools/ocaml/duniverse/csexp/test/test.ml | 142 ++ tools/ocaml/duniverse/dune | 4 + tools/ocaml/duniverse/fmt/.gitignore | 8 + tools/ocaml/duniverse/fmt/.ocp-indent | 1 + tools/ocaml/duniverse/fmt/CHANGES.md | 98 + tools/ocaml/duniverse/fmt/LICENSE.md | 13 + tools/ocaml/duniverse/fmt/README.md | 35 + tools/ocaml/duniverse/fmt/_tags | 7 + tools/ocaml/duniverse/fmt/doc/api.odocl | 3 + tools/ocaml/duniverse/fmt/doc/index.mld | 11 + tools/ocaml/duniverse/fmt/dune-project | 2 + tools/ocaml/duniverse/fmt/fmt.opam | 35 + tools/ocaml/duniverse/fmt/pkg/META | 40 + tools/ocaml/duniverse/fmt/pkg/pkg.ml | 18 + tools/ocaml/duniverse/fmt/src/dune | 30 + tools/ocaml/duniverse/fmt/src/fmt.ml | 787 ++++++++ tools/ocaml/duniverse/fmt/src/fmt.mli | 689 +++++++ tools/ocaml/duniverse/fmt/src/fmt.mllib | 1 + tools/ocaml/duniverse/fmt/src/fmt_cli.ml | 32 + tools/ocaml/duniverse/fmt/src/fmt_cli.mli | 45 + tools/ocaml/duniverse/fmt/src/fmt_cli.mllib | 1 + tools/ocaml/duniverse/fmt/src/fmt_top.ml | 23 + tools/ocaml/duniverse/fmt/src/fmt_top.mllib | 1 + tools/ocaml/duniverse/fmt/src/fmt_tty.ml | 78 + tools/ocaml/duniverse/fmt/src/fmt_tty.mli | 50 + tools/ocaml/duniverse/fmt/src/fmt_tty.mllib | 1 + .../duniverse/fmt/src/fmt_tty_top_init.ml | 23 + tools/ocaml/duniverse/fmt/test/test.ml | 322 ++++ .../duniverse/ocaml-afl-persistent/.gitignore | 2 + .../duniverse/ocaml-afl-persistent/CHANGES.md | 22 + .../duniverse/ocaml-afl-persistent/LICENSE.md | 8 + .../duniverse/ocaml-afl-persistent/README.md | 17 + .../ocaml-afl-persistent/afl-persistent.opam | 49 + .../afl-persistent.opam.template | 16 + .../aflPersistent.available.ml | 21 + .../ocaml-afl-persistent/aflPersistent.mli | 1 + .../aflPersistent.stub.ml | 1 + .../duniverse/ocaml-afl-persistent/detect.sh | 43 + .../ocaml/duniverse/ocaml-afl-persistent/dune | 20 + .../ocaml-afl-persistent/dune-project | 23 + .../duniverse/ocaml-afl-persistent/test.ml | 3 + .../ocaml-afl-persistent/test/harness.ml | 22 + .../ocaml-afl-persistent/test/test.ml | 73 + .../ocaml-afl-persistent/test/test.sh | 33 + .../ocaml/duniverse/ocplib-endian/.gitignore | 3 + .../ocaml/duniverse/ocplib-endian/.travis.yml | 19 + .../ocaml/duniverse/ocplib-endian/CHANGES.md | 55 + .../ocaml/duniverse/ocplib-endian/COPYING.txt | 521 ++++++ tools/ocaml/duniverse/ocplib-endian/Makefile | 13 + tools/ocaml/duniverse/ocplib-endian/README.md | 16 + .../duniverse/ocplib-endian/dune-project | 2 + .../ocplib-endian/ocplib-endian.opam | 30 + .../ocplib-endian/src/be_ocaml_401.ml | 32 + .../duniverse/ocplib-endian/src/common.ml | 24 + .../ocplib-endian/src/common_401.cppo.ml | 100 + .../ocplib-endian/src/common_float.ml | 5 + tools/ocaml/duniverse/ocplib-endian/src/dune | 75 + .../ocplib-endian/src/endianBigstring.cppo.ml | 112 ++ .../src/endianBigstring.cppo.mli | 128 ++ .../ocplib-endian/src/endianBytes.cppo.ml | 130 ++ .../ocplib-endian/src/endianBytes.cppo.mli | 124 ++ .../ocplib-endian/src/endianString.cppo.ml | 118 ++ .../ocplib-endian/src/endianString.cppo.mli | 121 ++ .../ocplib-endian/src/le_ocaml_401.ml | 32 + .../ocplib-endian/src/ne_ocaml_401.ml | 20 + .../duniverse/ocplib-endian/tests/bench.ml | 436 +++++ .../ocaml/duniverse/ocplib-endian/tests/dune | 35 + .../duniverse/ocplib-endian/tests/test.ml | 39 + .../tests/test_bigstring.cppo.ml | 191 ++ .../ocplib-endian/tests/test_bytes.cppo.ml | 185 ++ .../ocplib-endian/tests/test_string.cppo.ml | 185 ++ tools/ocaml/duniverse/result/CHANGES.md | 15 + tools/ocaml/duniverse/result/LICENSE.md | 24 + tools/ocaml/duniverse/result/Makefile | 17 + tools/ocaml/duniverse/result/README.md | 5 + tools/ocaml/duniverse/result/dune | 12 + tools/ocaml/duniverse/result/dune-project | 3 + .../duniverse/result/result-as-alias-4.08.ml | 2 + .../ocaml/duniverse/result/result-as-alias.ml | 2 + .../duniverse/result/result-as-newtype.ml | 2 + tools/ocaml/duniverse/result/result.opam | 18 + tools/ocaml/duniverse/result/which_result.ml | 14 + tools/ocaml/duniverse/stdlib-shims/CHANGES.md | 5 + tools/ocaml/duniverse/stdlib-shims/LICENSE | 203 +++ tools/ocaml/duniverse/stdlib-shims/README.md | 2 + .../ocaml/duniverse/stdlib-shims/dune-project | 1 + .../duniverse/stdlib-shims/dune-workspace.dev | 14 + tools/ocaml/duniverse/stdlib-shims/src/dune | 97 + .../duniverse/stdlib-shims/stdlib-shims.opam | 24 + tools/ocaml/duniverse/stdlib-shims/test/dune | 3 + .../ocaml/duniverse/stdlib-shims/test/test.ml | 2 + tools/ocaml/xen.opam.locked | 119 ++ 248 files changed, 18334 insertions(+) create mode 100644 tools/ocaml/duniverse/cmdliner/.gitignore create mode 100644 tools/ocaml/duniverse/cmdliner/.ocp-indent create mode 100644 tools/ocaml/duniverse/cmdliner/B0.ml create mode 100644 tools/ocaml/duniverse/cmdliner/CHANGES.md create mode 100644 tools/ocaml/duniverse/cmdliner/LICENSE.md create mode 100644 tools/ocaml/duniverse/cmdliner/Makefile create mode 100644 tools/ocaml/duniverse/cmdliner/README.md create mode 100644 tools/ocaml/duniverse/cmdliner/_tags create mode 100755 tools/ocaml/duniverse/cmdliner/build.ml create mode 100644 tools/ocaml/duniverse/cmdliner/cmdliner.opam create mode 100644 tools/ocaml/duniverse/cmdliner/doc/api.odocl create mode 100644 tools/ocaml/duniverse/cmdliner/dune-project create mode 100644 tools/ocaml/duniverse/cmdliner/pkg/META create mode 100755 tools/ocaml/duniverse/cmdliner/pkg/pkg.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner.mllib create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_arg.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_arg.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_base.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_base.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_cline.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_cline.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_docgen.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_docgen.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_info.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_info.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_manpage.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_manpage.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_msg.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_msg.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_suggest.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_suggest.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_term.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_term.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_trie.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_trie.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/dune create mode 100644 tools/ocaml/duniverse/cmdliner/test/chorus.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/cp_ex.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/darcs_ex.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/dune create mode 100644 tools/ocaml/duniverse/cmdliner/test/revolt.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/rm_ex.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/tail_ex.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_man.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_man_utf8.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_opt_req.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_pos.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_pos_all.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_pos_left.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_pos_req.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_pos_rev.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_term_dups.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_with_used_args= .ml create mode 100644 tools/ocaml/duniverse/cppo/.gitignore create mode 100644 tools/ocaml/duniverse/cppo/.ocp-indent create mode 100644 tools/ocaml/duniverse/cppo/.travis.yml create mode 100644 tools/ocaml/duniverse/cppo/CODEOWNERS create mode 100644 tools/ocaml/duniverse/cppo/Changes create mode 100644 tools/ocaml/duniverse/cppo/INSTALL.md create mode 100644 tools/ocaml/duniverse/cppo/LICENSE.md create mode 100644 tools/ocaml/duniverse/cppo/Makefile create mode 100644 tools/ocaml/duniverse/cppo/README.md create mode 100644 tools/ocaml/duniverse/cppo/VERSION create mode 100644 tools/ocaml/duniverse/cppo/appveyor.yml create mode 100644 tools/ocaml/duniverse/cppo/cppo.opam create mode 100644 tools/ocaml/duniverse/cppo/cppo_ocamlbuild.opam create mode 100644 tools/ocaml/duniverse/cppo/dune-project create mode 100644 tools/ocaml/duniverse/cppo/examples/Makefile create mode 100644 tools/ocaml/duniverse/cppo/examples/debug.ml create mode 100644 tools/ocaml/duniverse/cppo/examples/dune create mode 100644 tools/ocaml/duniverse/cppo/examples/french.ml create mode 100644 tools/ocaml/duniverse/cppo/examples/lexer.mll create mode 100644 tools/ocaml/duniverse/cppo/ocamlbuild_plugin/_tags create mode 100644 tools/ocaml/duniverse/cppo/ocamlbuild_plugin/dune create mode 100644 tools/ocaml/duniverse/cppo/ocamlbuild_plugin/ocamlbuild= _cppo.ml create mode 100644 tools/ocaml/duniverse/cppo/ocamlbuild_plugin/ocamlbuild= _cppo.mli create mode 100644 tools/ocaml/duniverse/cppo/src/compat.ml create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_command.ml create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_command.mli create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_eval.ml create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_eval.mli create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_lexer.mll create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_main.ml create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_parser.mly create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_types.ml create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_types.mli create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_version.mli create mode 100644 tools/ocaml/duniverse/cppo/src/dune create mode 100644 tools/ocaml/duniverse/cppo/test/capital.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/capital.ref create mode 100644 tools/ocaml/duniverse/cppo/test/comments.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/comments.ref create mode 100644 tools/ocaml/duniverse/cppo/test/cond.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/cond.ref create mode 100644 tools/ocaml/duniverse/cppo/test/dune create mode 100644 tools/ocaml/duniverse/cppo/test/ext.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/ext.ref create mode 100644 tools/ocaml/duniverse/cppo/test/incl.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/incl2.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/loc.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/loc.ref create mode 100644 tools/ocaml/duniverse/cppo/test/paren_arg.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/paren_arg.ref create mode 100755 tools/ocaml/duniverse/cppo/test/source.sh create mode 100644 tools/ocaml/duniverse/cppo/test/test.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/tuple.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/tuple.ref create mode 100644 tools/ocaml/duniverse/cppo/test/unmatched.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/unmatched.ref create mode 100644 tools/ocaml/duniverse/cppo/test/version.cppo create mode 100644 tools/ocaml/duniverse/crowbar/.gitignore create mode 100644 tools/ocaml/duniverse/crowbar/CHANGES.md create mode 100644 tools/ocaml/duniverse/crowbar/LICENSE.md create mode 100644 tools/ocaml/duniverse/crowbar/README.md create mode 100644 tools/ocaml/duniverse/crowbar/crowbar.opam create mode 100644 tools/ocaml/duniverse/crowbar/dune create mode 100644 tools/ocaml/duniverse/crowbar/dune-project create mode 100644 tools/ocaml/duniverse/crowbar/examples/.gitignore create mode 100644 tools/ocaml/duniverse/crowbar/examples/calendar/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/calendar/test_ca= lendar.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/fpath/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/fpath/test_fpath= .ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/input/testcase create mode 100644 tools/ocaml/duniverse/crowbar/examples/map/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/map/test_map.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/pprint/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/pprint/test_ppri= nt.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/serializer/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/serializer/seria= lizer.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/serializer/test_= serializer.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/uunf/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/uunf/test_uunf.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/xmldiff/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/xmldiff/test_xml= diff.ml create mode 100644 tools/ocaml/duniverse/crowbar/src/crowbar.ml create mode 100644 tools/ocaml/duniverse/crowbar/src/crowbar.mli create mode 100644 tools/ocaml/duniverse/crowbar/src/dune create mode 100644 tools/ocaml/duniverse/crowbar/src/todo create mode 100644 tools/ocaml/duniverse/csexp/CHANGES.md create mode 100644 tools/ocaml/duniverse/csexp/LICENSE.md create mode 100644 tools/ocaml/duniverse/csexp/Makefile create mode 100644 tools/ocaml/duniverse/csexp/README.md create mode 100644 tools/ocaml/duniverse/csexp/bench/csexp_bench.ml create mode 100644 tools/ocaml/duniverse/csexp/bench/dune create mode 100644 tools/ocaml/duniverse/csexp/bench/main.ml create mode 100755 tools/ocaml/duniverse/csexp/bench/runner.sh create mode 100644 tools/ocaml/duniverse/csexp/csexp.opam create mode 100644 tools/ocaml/duniverse/csexp/csexp.opam.template create mode 100644 tools/ocaml/duniverse/csexp/dune-project create mode 100644 tools/ocaml/duniverse/csexp/dune-workspace.dev create mode 100644 tools/ocaml/duniverse/csexp/src/csexp.ml create mode 100644 tools/ocaml/duniverse/csexp/src/csexp.mli create mode 100644 tools/ocaml/duniverse/csexp/src/dune create mode 100644 tools/ocaml/duniverse/csexp/test/dune create mode 100644 tools/ocaml/duniverse/csexp/test/test.ml create mode 100644 tools/ocaml/duniverse/dune create mode 100644 tools/ocaml/duniverse/fmt/.gitignore create mode 100644 tools/ocaml/duniverse/fmt/.ocp-indent create mode 100644 tools/ocaml/duniverse/fmt/CHANGES.md create mode 100644 tools/ocaml/duniverse/fmt/LICENSE.md create mode 100644 tools/ocaml/duniverse/fmt/README.md create mode 100644 tools/ocaml/duniverse/fmt/_tags create mode 100644 tools/ocaml/duniverse/fmt/doc/api.odocl create mode 100644 tools/ocaml/duniverse/fmt/doc/index.mld create mode 100644 tools/ocaml/duniverse/fmt/dune-project create mode 100644 tools/ocaml/duniverse/fmt/fmt.opam create mode 100644 tools/ocaml/duniverse/fmt/pkg/META create mode 100755 tools/ocaml/duniverse/fmt/pkg/pkg.ml create mode 100644 tools/ocaml/duniverse/fmt/src/dune create mode 100644 tools/ocaml/duniverse/fmt/src/fmt.ml create mode 100644 tools/ocaml/duniverse/fmt/src/fmt.mli create mode 100644 tools/ocaml/duniverse/fmt/src/fmt.mllib create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_cli.ml create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_cli.mli create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_cli.mllib create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_top.ml create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_top.mllib create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_tty.ml create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_tty.mli create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_tty.mllib create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_tty_top_init.ml create mode 100644 tools/ocaml/duniverse/fmt/test/test.ml create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/.gitignore create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/CHANGES.md create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/LICENSE.md create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/README.md create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/afl-persiste= nt.opam create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/afl-persiste= nt.opam.template create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/aflPersisten= t.available.ml create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/aflPersisten= t.mli create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/aflPersisten= t.stub.ml create mode 100755 tools/ocaml/duniverse/ocaml-afl-persistent/detect.sh create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/dune create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/dune-project create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/test.ml create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/test/harness= .ml create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/test/test.ml create mode 100755 tools/ocaml/duniverse/ocaml-afl-persistent/test/test.sh create mode 100644 tools/ocaml/duniverse/ocplib-endian/.gitignore create mode 100644 tools/ocaml/duniverse/ocplib-endian/.travis.yml create mode 100644 tools/ocaml/duniverse/ocplib-endian/CHANGES.md create mode 100644 tools/ocaml/duniverse/ocplib-endian/COPYING.txt create mode 100644 tools/ocaml/duniverse/ocplib-endian/Makefile create mode 100644 tools/ocaml/duniverse/ocplib-endian/README.md create mode 100644 tools/ocaml/duniverse/ocplib-endian/dune-project create mode 100644 tools/ocaml/duniverse/ocplib-endian/ocplib-endian.opam create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/be_ocaml_401.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/common.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/common_401.cppo= .ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/common_float.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/dune create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianBigstring= .cppo.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianBigstring= .cppo.mli create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianBytes.cpp= o.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianBytes.cpp= o.mli create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianString.cp= po.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianString.cp= po.mli create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/le_ocaml_401.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/ne_ocaml_401.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/bench.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/dune create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/test.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/test_bigstrin= g.cppo.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/test_bytes.cp= po.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/test_string.c= ppo.ml create mode 100755 tools/ocaml/duniverse/result/CHANGES.md create mode 100755 tools/ocaml/duniverse/result/LICENSE.md create mode 100755 tools/ocaml/duniverse/result/Makefile create mode 100755 tools/ocaml/duniverse/result/README.md create mode 100755 tools/ocaml/duniverse/result/dune create mode 100755 tools/ocaml/duniverse/result/dune-project create mode 100755 tools/ocaml/duniverse/result/result-as-alias-4.08.ml create mode 100755 tools/ocaml/duniverse/result/result-as-alias.ml create mode 100755 tools/ocaml/duniverse/result/result-as-newtype.ml create mode 100755 tools/ocaml/duniverse/result/result.opam create mode 100755 tools/ocaml/duniverse/result/which_result.ml create mode 100644 tools/ocaml/duniverse/stdlib-shims/CHANGES.md create mode 100644 tools/ocaml/duniverse/stdlib-shims/LICENSE create mode 100644 tools/ocaml/duniverse/stdlib-shims/README.md create mode 100644 tools/ocaml/duniverse/stdlib-shims/dune-project create mode 100644 tools/ocaml/duniverse/stdlib-shims/dune-workspace.dev create mode 100644 tools/ocaml/duniverse/stdlib-shims/src/dune create mode 100644 tools/ocaml/duniverse/stdlib-shims/stdlib-shims.opam create mode 100644 tools/ocaml/duniverse/stdlib-shims/test/dune create mode 100644 tools/ocaml/duniverse/stdlib-shims/test/test.ml create mode 100644 tools/ocaml/xen.opam.locked diff --git a/tools/ocaml/duniverse/cmdliner/.gitignore b/tools/ocaml/dunive= rse/cmdliner/.gitignore new file mode 100644 index 0000000000..2b7712335b --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/.gitignore @@ -0,0 +1,10 @@ +_build +_b0 +tmp +*~ +\.\#* +\#*# +*.byte +*.native +cmdliner.install +src/.merlin diff --git a/tools/ocaml/duniverse/cmdliner/.ocp-indent b/tools/ocaml/duniv= erse/cmdliner/.ocp-indent new file mode 100644 index 0000000000..ad2fbcbfa5 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/.ocp-indent @@ -0,0 +1 @@ +strict_with=3Dalways,match_clause=3D4,strict_else=3Dnever \ No newline at end of file diff --git a/tools/ocaml/duniverse/cmdliner/B0.ml b/tools/ocaml/duniverse/c= mdliner/B0.ml new file mode 100644 index 0000000000..ddeb802719 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/B0.ml @@ -0,0 +1,9 @@ +open B0 + +let cmdliner =3D "cmdliner" +let doc =3D "Declarative definition of command line interfaces for OCaml" + +let pkg =3D Pkg.create cmdliner ~doc +let lib =3D + let srcs =3D (`Src_dirs [Fpath.v "src"]) in + B0_ocaml.Unit.lib ~pkg cmdliner srcs ~doc diff --git a/tools/ocaml/duniverse/cmdliner/CHANGES.md b/tools/ocaml/dunive= rse/cmdliner/CHANGES.md new file mode 100644 index 0000000000..ec68c51a08 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/CHANGES.md @@ -0,0 +1,255 @@ +v1.0.4 2019-06-14 Zagreb +------------------------ + +- Change the way `Error (_, e)` term evaluation results=20 + are formatted. Instead of treating `e` as text, treat + it as formatted lines. +- Fix 4.08 `Pervasives` deprecation. +- Fix 4.03 String deprecations. +- Fix bootstrap build in absence of dynlink. +- Make the `Makefile` bootstrap build reproducible. + Thanks to Thomas Leonard for the patch. + +v1.0.3 2018-11-26 Zagreb +------------------------ + +- Add `Term.with_used_args`. Thanks to Jeremie Dimino for + the patch. +- Use `Makefile` bootstrap build in opam file. +- Drop ocamlbuild requirement for `Makefile` bootstrap build. +- Drop support for ocaml < 4.03.0 +- Dune build support. + +v1.0.2 2017-08-07 Zagreb +------------------------ + +- Don't remove the `Makefile` from the distribution. + +v1.0.1 2017-08-03 Zagreb +------------------------ + +- Add a `Makefile` to build and install cmdliner without `topkg` and + opam `.install` files. Helps bootstraping opam in OS package + managers. Thanks to Hendrik Tews for the patches. + +v1.0.0 2017-03-02 La Forclaz (VS) +--------------------------------- + +**IMPORTANT** The `Arg.converter` type is deprecated in favor of the +`Arg.conv` type. For this release both types are equal but the next +major release will drop the former and make the latter abstract. All +users are kindly requested to migrate to use the new type and **only** +via the new `Arg.[p]conv` and `Arg.conv_{parser,printer}` functions. + +- Allow terms to be used more than once in terms without tripping out + documentation generation (#77). Thanks to Fran=C3=A7ois Bobot and Gabriel + Radanne. +- Disallow defining the same option (resp. command) name twice via two + different arguments (resp. terms). Raises Invalid_argument, used + to be undefined behaviour (in practice, an arbitrary one would be + ignored). +- Improve converter API (see important message above). +- Add `Term.exit[_status]` and `Term.exit_status_of[_status]_result`. + improves composition with `Pervasives.exit`. +- Add `Term.term_result` and `Term.cli_parse_result` improves composition + with terms evaluating to `result` types. +- Add `Arg.parser_of_kind_of_string`. +- Change semantics of `Arg.pos_left` (see #76 for details). +- Deprecate `Term.man_format` in favor of `Arg.man_format`. +- Reserve the `--cmdliner` option for library use. This is unused for now + but will be in the future. +- Relicense from BSD3 to ISC. +- Safe-string support. +- Build depend on topkg. + +### End-user visible changes + +The following changes affect the end-user behaviour of all binaries using +cmdliner. + +- Required positional arguments. All missing required position + arguments are now reported to the end-user, in the correct + order (#39). Thanks to Dmitrii Kashin for the report. +- Optional arguments. All unknown and ambiguous optional argument + arguments are now reported to the end-user (instead of only + the first one). +- Change default behaviour of `--help[=3DFMT]` option. `FMT` no longer + defaults to `pager` if unspecified. It defaults to the new value + `auto` which prints the help as `pager` or `plain` whenever the + `TERM` environment variable is `dumb` or undefined (#43). At the API + level this changes the signature of the type `Term.ret` and values + `Term.ret`, `Term.man_format` (deprecated) and `Manpage.print` to add the + new `` `Auto`` case to manual formats. These are now represented by the + `Manpage.format` type rather than inlined polyvars. + +### Doc specification improvements and fixes + +- Add `?envs` optional argument to `Term.info`. Documents environment + variables that influence a term's evaluation and automatically + integrate them in the manual. +- Add `?exits` optional argument to `Term.info`. Documents exit statuses of + the program. Use `Term.default_exits` if you are using the new `Term.exi= t` + functions. +- Add `?man_xrefs` optional argument to `Term.info`. Documents + references to other manpages. Automatically formats a `SEE ALSO` section + in the manual. +- Add `Manpage.escape` to escape a string from the documentation markup + language. +- Add `Manpage.s_*` constants for standard man page section names. +- Add a `` `Blocks`` case to `Manpage.blocks` to allow block splicing + (#69). This avoids having to concatenate block lists at the + toplevel of your program. +- `Arg.env_var`, change default environment variable section to the + standard `ENVIRONMENT` manual section rather than `ENVIRONMENT + VARIABLES`. If you previously manually positioned that section in + your man page you will have to change the name. See also next point. +- Fix automatic placement of default environment variable section (#44) + whenever unspecified in the man page. +- Better automatic insertions of man page sections (#73). See the API + docs about manual specification. As a side effect the `NAME` section + can now also be overriden manually. +- Fix repeated environment variable printing for flags (#64). Thanks to + Thomas Gazagnaire for the report. +- Fix rendering of env vars in man pages, bold is standard (#71). +- Fix plain help formatting for commands with empty + description. Thanks to Maciek Starzyk for the patch. +- Fix (implement really) groff man page escaping (#48). +- Request `an` macros directly in the man page via `.mso` this + makes man pages self-describing and avoids having to call `groff` with + the `-man` option. +- Document required optional arguments as such (#82). Thanks to Isaac Hodes + for the report. + +### Doc language sanitization + +This release tries to bring sanity to the doc language. This may break +the rendering of some of your man pages. Thanks to Gabriel Scherer, +Ivan Gotovchits and Nicol=C3=A1s Ojeda B=C3=A4r for the feedback. + +- It is only allowed to use the variables `$(var)` that are mentioned in + the docs (`$(docv)`, `$(opt)`, etc.) and the markup directives + `$({i,b},text)`. Any other unknown `$(var)` will generate errors + on standard error during documentation generation. +- Markup directives `$({i,b},text)` treat `text` as is, modulo escapes; + see next point. +- Characters `$`, `(`, `)` and `\` can respectively be escaped by `\$`, + `\(`, `\)` and `\\`. Escaping `$` and `\` is mandatory everywhere. + Escaping `)` is mandatory only in markup directives. Escaping `(` + is only here for your symmetric pleasure. Any other sequence of + character starting with a `\` is an illegal sequence. +- Variables `$(mname)` and `$(tname)` are now marked up with bold when + substituted. If you used to write `$(b,$(tname))` this will generate + an error on standard output, since `$` is not escaped in the markup + directive. Simply replace these by `$(tname)`. + +v0.9.8 2015-10-11 Cambridge (UK) +-------------------------------- + +- Bring back support for OCaml 3.12.0 +- Support for pre-formatted paragraphs in man pages. This adds a + ```Pre`` case to the `Manpage.block` type which can break existing + programs. Thanks to Guillaume Bury for suggesting and help. +- Support for environment variables. If an argument is absent from the + command line, its value can be read and parsed from an environment + variable. This adds an `env` optional argument to the `Arg.info` + function which can break existing programs. +- Support for new variables in option documentation strings. `$(opt)` + can be used to refer to the name of the option being documented and + `$(env)` for the name of the option's the environment variable. +- Deprecate `Term.pure` in favor of `Term.const`. +- Man page generation. Keep undefined variables untouched. Previously + a `$(undef)` would be turned into `undef`. +- Turn a few misterious and spurious `Not_found` exceptions into + `Invalid_arg`. These can be triggered by client programming errors + (e.g. an unclosed variable in a documentation string). +- Positional arguments. Invoke the printer on the default (absent) + value only if needed. See Optional arguments in the release notes of + v0.9.6. + +v0.9.7 2015-02-06 La Forclaz (VS) +--------------------------------- + +- Build system, don't depend on `ocamlfind`. The package no longer + depends on ocamlfind. Thanks to Louis Gesbert for the patch.=20 + +v0.9.6 2014-11-18 La Forclaz (VS) +--------------------------------- + +- Optional arguments. Invoke the printer on the default (absent) value + only if needed, i.e. if help is shown. Strictly speaking an + interface breaking change =E2=80=93 for example if the absent value was = lazy + it would be forced on each run. This is no longer the case. +- Parsed command line syntax: allow short flags to be specified + together under a single dash, possibly ending with a short option. + This allows to specify e.g. `tar -xvzf archive.tgz` or `tar + -xvzfarchive.tgz`. Previously this resulted in an error, all the + short flags had to be specified separately. Backward compatible in + the sense that only more command lines are parsed. Thanks to Hugo + Heuzard for the patch. +- End user error message improvements using heuristics and edit + distance search in the optional argument and sub command name + spaces. Thanks to Hugo Heuzard for the patch. +- Adds `Arg.doc_{quote,alts,alts_enum}`, documentation string + helpers. +- Adds the `Term.eval_peek_opts` function for advanced usage scenarios. +- The function `Arg.enum` now raises `Invalid_argument` if the + enumeration is empty. +- Improves help paging behaviour on Windows. Thanks to Romain Bardou + for the help. + + +v0.9.5 2014-07-04 Cambridge (UK) +-------------------------------- + +- Add variance annotation to Term.t. Thanks to Peter Zotov for suggesting. +- Fix section name formatting in plain text output. Thanks to Mikhail + Sobolev for reporting. + + +v0.9.4 2014-02-09 La Forclaz (VS) +--------------------------------- + +- Remove temporary files created for paged help. Thanks to Kaustuv Chaudhu= ri + for the suggestion. +- Avoid linking against `Oo` (was used to get program uuid). +- Check the environment for `$MANPAGER` aswell. Thanks to Rapha=C3=ABl Pro= ust + for the patch. +- OPAM friendly workflow and drop OASIS support. + + +v0.9.3 2013-01-04 La Forclaz (VS) +--------------------------------- + +- Allow user specified `SYNOPSIS` sections. + + +v0.9.2 2012-08-05 Lausanne +-------------------------- + +- OASIS 0.3.0 support. + + +v0.9.1 2012-03-17 La Forclaz (VS) +--------------------------------- + +- OASIS support. +- Fixed broken `Arg.pos_right`. +- Variables `$(tname)` and `$(mname)` can be used in a term's man + page to respectively refer to the term's name and the main term + name. +- Support for custom variable substitution in `Manpage.print`. +- Adds `Term.man_format`, to facilitate the definition of help commands. +- Rewrote the examples with a better and consistent style. + +Incompatible API changes: + +- The signature of `Term.eval` and `Term.eval_choice` changed to make + it more regular: the given term and its info must be tupled together + even for the main term and the tuple order was swapped to make it + consistent with the one used for arguments. + + +v0.9.0 2011-05-27 Lausanne +-------------------------- + +- First release. diff --git a/tools/ocaml/duniverse/cmdliner/LICENSE.md b/tools/ocaml/dunive= rse/cmdliner/LICENSE.md new file mode 100644 index 0000000000..90fca24d71 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/LICENSE.md @@ -0,0 +1,13 @@ +Copyright (c) 2011 Daniel C. B=C3=BCnzli + +Permission to use, copy, modify, and/or 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. diff --git a/tools/ocaml/duniverse/cmdliner/Makefile b/tools/ocaml/dunivers= e/cmdliner/Makefile new file mode 100644 index 0000000000..1d2ffd40b7 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/Makefile @@ -0,0 +1,77 @@ +# To be used by system package managers to bootstrap opam. topkg +# cannot be used as it needs opam-installer which is provided by opam +# itself. + +# Typical usage: +# +# make all +# make install PREFIX=3D/usr/local +# make install-doc PREFIX=3D/usr/local + +# Adjust the following on the cli invocation for configuring + +-include $(shell ocamlc -where)/Makefile.config + +PREFIX=3D/usr +LIBDIR=3D$(DESTDIR)$(PREFIX)/lib/ocaml/cmdliner +DOCDIR=3D$(DESTDIR)$(PREFIX)/share/doc/cmdliner +NATIVE=3D$(shell ocamlopt -version > /dev/null 2>&1 && echo true) +# EXT_LIB by default value of OCaml's Makefile.config +# NATDYNLINK by default value of OCaml's Makefile.config + +INSTALL=3Dinstall +B=3D_build +BASE=3D$(B)/cmdliner + +ifeq ($(NATIVE),true) + BUILD-TARGETS=3Dbuild-byte build-native + INSTALL-TARGETS=3Dinstall-common install-byte install-native + ifeq ($(NATDYNLINK),true) + BUILD-TARGETS +=3D build-native-dynlink + INSTALL-TARGETS +=3D install-native-dynlink + endif +else + BUILD-TARGETS=3Dbuild-byte + INSTALL-TARGETS=3Dinstall-common install-byte +endif + +all: $(BUILD-TARGETS) + +install: $(INSTALL-TARGETS) + +install-doc: + $(INSTALL) -d $(DOCDIR) + $(INSTALL) CHANGES.md LICENSE.md README.md $(DOCDIR) + +clean: + ocaml build.ml clean + +build-byte: + ocaml build.ml cma + +build-native: + ocaml build.ml cmxa + +build-native-dynlink: + ocaml build.ml cmxs + +create-libdir: + $(INSTALL) -d $(LIBDIR) + +install-common: create-libdir + $(INSTALL) pkg/META $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) + $(INSTALL) cmdliner.opam $(LIBDIR)/opam + +install-byte: create-libdir + $(INSTALL) $(BASE).cma $(LIBDIR) + +install-native: create-libdir + $(INSTALL) $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(B)/cmdliner*.cmx) \ + $(LIBDIR) + +install-native-dynlink: create-libdir + $(INSTALL) $(BASE).cmxs $(LIBDIR) + +.PHONY: all install install-doc clean build-byte build-native \ + build-native-dynlink create-libdir install-common install-byte \ + install-native install-dynlink diff --git a/tools/ocaml/duniverse/cmdliner/README.md b/tools/ocaml/duniver= se/cmdliner/README.md new file mode 100644 index 0000000000..408e80f76c --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/README.md @@ -0,0 +1,51 @@ +Cmdliner =E2=80=94 Declarative definition of command line interfaces for O= Caml +--------------------------------------------------------------------------= ----- +%%VERSION%% + +Cmdliner allows the declarative definition of command line interfaces +for OCaml. + +It provides a simple and compositional mechanism to convert command +line arguments to OCaml values and pass them to your functions. The +module automatically handles syntax errors, help messages and UNIX man +page generation. It supports programs with single or multiple commands +and respects most of the [POSIX][1] and [GNU][2] conventions. + +Cmdliner has no dependencies and is distributed under the ISC license. + +[1]: http://pubs.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.ht= ml +[2]: http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html + +Home page: http://erratique.ch/software/cmdliner =20 +Contact: Daniel B=C3=BCnzli `` + + +## Installation + +Cmdliner can be installed with `opam`: + + opam install cmdliner + +If you don't use `opam` consult the [`opam`](opam) file for build +instructions. + + +## Documentation + +The documentation and API reference is automatically generated by from +the source interfaces. It can be consulted [online][doc] or via +`odig doc cmdliner`. + +[doc]: http://erratique.ch/software/cmdliner/doc/Cmdliner + + +## Sample programs + +If you installed Cmdliner with `opam` sample programs are located in +the directory `opam config var cmdliner:doc`. These programs define +the command line of some classic programs. + +In the distribution sample programs are located in the `test` +directory of the distribution. They can be built and run with: + + topkg build --tests true && topkg test diff --git a/tools/ocaml/duniverse/cmdliner/_tags b/tools/ocaml/duniverse/c= mdliner/_tags new file mode 100644 index 0000000000..71bfd61d91 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/_tags @@ -0,0 +1,3 @@ +true : bin_annot, safe_string + : include + : include \ No newline at end of file diff --git a/tools/ocaml/duniverse/cmdliner/build.ml b/tools/ocaml/dunivers= e/cmdliner/build.ml new file mode 100755 index 0000000000..3228af3205 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/build.ml @@ -0,0 +1,155 @@ +#!/usr/bin/env ocaml + +(* Usage: ocaml build.ml [cma|cmxa|cmxs|clean] *) + +let root_dir =3D Sys.getcwd () +let build_dir =3D "_build" +let src_dir =3D "src" + +let base_ocaml_opts =3D + [ "-g"; "-bin-annot"; + "-safe-string"; (* Remove once we require >=3D 4.06 *) ] + +(* Logging *) + +let strf =3D Printf.sprintf +let err fmt =3D Printf.kfprintf (fun oc -> flush oc; exit 1) stderr fmt +let log fmt =3D Printf.kfprintf (fun oc -> flush oc) stdout fmt + +(* The running joke *) + +let rev_cut ~sep s =3D match String.rindex s sep with +| exception Not_found -> None +| i -> String.(Some (sub s 0 i, sub s (i + 1) (length s - (i + 1)))) + +let cuts ~sep s =3D + let rec loop acc =3D function + | "" -> acc + | s -> + match rev_cut ~sep s with + | None -> s :: acc + | Some (l, r) -> loop (r :: acc) l + in + loop [] s + +(* Read, write and collect files *) + +let fpath ~dir f =3D String.concat "" [dir; "/"; f] + +let string_of_file f =3D + let ic =3D open_in_bin f in + let len =3D in_channel_length ic in + let buf =3D Bytes.create len in + really_input ic buf 0 len; + close_in ic; + Bytes.unsafe_to_string buf + +let string_to_file f s =3D + let oc =3D open_out_bin f in + output_string oc s; + close_out oc + +let cp src dst =3D string_to_file dst (string_of_file src) + +let ml_srcs dir =3D + let add_file dir acc f =3D match rev_cut ~sep:'.' f with + | Some (m, e) when e =3D "ml" || e =3D "mli" -> f :: acc + | Some _ | None -> acc + in + Array.fold_left (add_file dir) [] (Sys.readdir dir) + +(* Finding and running commands *) + +let find_cmd cmds =3D + let test, null =3D match Sys.win32 with + | true -> "where", " NUL" + | false -> "type", "/dev/null" + in + let cmd c =3D Sys.command (strf "%s %s 1>%s 2>%s" test c null null) =3D = 0 in + try Some (List.find cmd cmds) with Not_found -> None + +let err_cmd exit cmd =3D err "exited with %d: %s\n" exit cmd +let quote_cmd =3D match Sys.win32 with +| false -> fun cmd -> cmd +| true -> fun cmd -> strf "\"%s\"" cmd + +let run_cmd args =3D + let cmd =3D String.concat " " (List.map Filename.quote args) in +(* log "[EXEC] %s\n" cmd; *) + let exit =3D Sys.command (quote_cmd cmd) in + if exit =3D 0 then () else err_cmd exit cmd + +let read_cmd args =3D + let stdout =3D Filename.temp_file (Filename.basename Sys.argv.(0)) "b00t= " in + at_exit (fun () -> try ignore (Sys.remove stdout) with _ -> ()); + let cmd =3D String.concat " " (List.map Filename.quote args) in + let cmd =3D quote_cmd @@ strf "%s 1>%s" cmd (Filename.quote stdout) in + let exit =3D Sys.command cmd in + if exit =3D 0 then string_of_file stdout else err_cmd exit cmd + +(* Create and delete directories *) + +let mkdir dir =3D + try match Sys.file_exists dir with + | true -> () + | false -> run_cmd ["mkdir"; dir] + with + | Sys_error e -> err "%s: %s" dir e + +let rmdir dir =3D + try match Sys.file_exists dir with + | false -> () + | true -> + let rm f =3D Sys.remove (fpath ~dir f) in + Array.iter rm (Sys.readdir dir); + run_cmd ["rmdir"; dir] + with + | Sys_error e -> err "%s: %s" dir e + +(* Lookup OCaml compilers and ocamldep *) + +let really_find_cmd alts =3D match find_cmd alts with +| Some cmd -> cmd +| None -> err "No %s found in PATH\n" (List.hd @@ List.rev alts) + +let ocamlc () =3D really_find_cmd ["ocamlc.opt"; "ocamlc"] +let ocamlopt () =3D really_find_cmd ["ocamlopt.opt"; "ocamlopt"] +let ocamldep () =3D really_find_cmd ["ocamldep.opt"; "ocamldep"] + +(* Build *) + +let sort_srcs srcs =3D + let srcs =3D List.sort String.compare srcs in + read_cmd (ocamldep () :: "-slash" :: "-sort" :: srcs) + |> String.trim |> cuts ~sep:' ' + +let common srcs =3D base_ocaml_opts @ sort_srcs srcs + +let build_cma srcs =3D + run_cmd ([ocamlc ()] @ common srcs @ ["-a"; "-o"; "cmdliner.cma"]) + +let build_cmxa srcs =3D + run_cmd ([ocamlopt ()] @ common srcs @ ["-a"; "-o"; "cmdliner.cmxa"]) + +let build_cmxs srcs =3D + run_cmd ([ocamlopt ()] @ common srcs @ ["-shared"; "-o"; "cmdliner.cmxs"= ]) + +let clean () =3D rmdir build_dir + +let in_build_dir f =3D + let srcs =3D ml_srcs src_dir in + let cp src =3D cp (fpath ~dir:src_dir src) (fpath ~dir:build_dir src) in + mkdir build_dir; + List.iter cp srcs; + Sys.chdir build_dir; f srcs; Sys.chdir root_dir + +let main () =3D match Array.to_list Sys.argv with +| _ :: [ "cma" ] -> in_build_dir build_cma +| _ :: [ "cmxa" ] -> in_build_dir build_cmxa +| _ :: [ "cmxs" ] -> in_build_dir build_cmxs +| _ :: [ "clean" ] -> clean () +| [] | [_] -> err "Missing argument: cma, cmxa, cmxs or clean\n"; +| cmd :: args -> + err "%s: Unknown argument(s): %s\n" cmd @@ String.concat " " args + +let () =3D main () diff --git a/tools/ocaml/duniverse/cmdliner/cmdliner.opam b/tools/ocaml/dun= iverse/cmdliner/cmdliner.opam new file mode 100644 index 0000000000..cb958e70d2 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/cmdliner.opam @@ -0,0 +1,32 @@ +opam-version: "2.0" +maintainer: "Daniel B=C3=BCnzli " +authors: ["Daniel B=C3=BCnzli "] +homepage: "http://erratique.ch/software/cmdliner" +doc: "http://erratique.ch/software/cmdliner/doc/Cmdliner" +dev-repo: "git+https://github.com/dune-universe/cmdliner.git" +bug-reports: "https://github.com/dbuenzli/cmdliner/issues" +tags: [ "cli" "system" "declarative" "org:erratique" ] +license: "ISC" +depends: [ + "dune" "ocaml" {>=3D "4.03.0"} ] +synopsis: """Declarative definition of command line interfaces for OCaml""" +description: """\ + +Cmdliner allows the declarative definition of command line interfaces +for OCaml. + +It provides a simple and compositional mechanism to convert command +line arguments to OCaml values and pass them to your functions. The +module automatically handles syntax errors, help messages and UNIX man +page generation. It supports programs with single or multiple commands +and respects most of the [POSIX][1] and [GNU][2] conventions. + +Cmdliner has no dependencies and is distributed under the ISC license. + +[1]: http://pubs.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.ht= ml +[2]: http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html +""" +build: [[ "dune" "build" "-p" name ]] +url { + src: "git://github.com/dune-universe/cmdliner.git#duniverse-v1.0.4" +} diff --git a/tools/ocaml/duniverse/cmdliner/doc/api.odocl b/tools/ocaml/dun= iverse/cmdliner/doc/api.odocl new file mode 100644 index 0000000000..58711c53d9 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/doc/api.odocl @@ -0,0 +1 @@ +Cmdliner diff --git a/tools/ocaml/duniverse/cmdliner/dune-project b/tools/ocaml/duni= verse/cmdliner/dune-project new file mode 100644 index 0000000000..f4beddd4f7 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.4) +(name cmdliner) \ No newline at end of file diff --git a/tools/ocaml/duniverse/cmdliner/pkg/META b/tools/ocaml/dunivers= e/cmdliner/pkg/META new file mode 100644 index 0000000000..81671c5328 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/pkg/META @@ -0,0 +1,7 @@ +version =3D "%%VERSION%%" +description =3D "Declarative definition of command line interfaces" +requires =3D "" +archive(byte) =3D "cmdliner.cma" +archive(native) =3D "cmdliner.cmxa" +plugin(byte) =3D "cmdliner.cma" +plugin(native) =3D "cmdliner.cmxs" \ No newline at end of file diff --git a/tools/ocaml/duniverse/cmdliner/pkg/pkg.ml b/tools/ocaml/dunive= rse/cmdliner/pkg/pkg.ml new file mode 100755 index 0000000000..7d3982ac9e --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/pkg/pkg.ml @@ -0,0 +1,33 @@ +#!/usr/bin/env ocaml +#use "topfind" +#require "topkg" +open Topkg + +let test t =3D Pkg.flatten [ Pkg.test ~run:false t; Pkg.doc (t ^ ".ml")] + +let distrib =3D + let exclude_paths () =3D Ok [".git";".gitignore";".gitattributes";"_buil= d"] in + Pkg.distrib ~exclude_paths () + +let opams =3D + [Pkg.opam_file "cmdliner.opam"] + +let () =3D + Pkg.describe ~distrib "cmdliner" ~opams @@ fun c -> + Ok [ Pkg.mllib ~api:["Cmdliner"] "src/cmdliner.mllib"; + test "test/chorus"; + test "test/cp_ex"; + test "test/darcs_ex"; + test "test/revolt"; + test "test/rm_ex"; + test "test/tail_ex"; + Pkg.test ~run:false "test/test_man"; + Pkg.test ~run:false "test/test_man_utf8"; + Pkg.test ~run:false "test/test_pos"; + Pkg.test ~run:false "test/test_pos_rev"; + Pkg.test ~run:false "test/test_pos_all"; + Pkg.test ~run:false "test/test_pos_left"; + Pkg.test ~run:false "test/test_pos_req"; + Pkg.test ~run:false "test/test_opt_req"; + Pkg.test ~run:false "test/test_term_dups"; + Pkg.test ~run:false "test/test_with_used_args"; ] diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner.ml b/tools/ocaml/d= universe/cmdliner/src/cmdliner.ml new file mode 100644 index 0000000000..40afd525cd --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner.ml @@ -0,0 +1,309 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +module Manpage =3D Cmdliner_manpage +module Arg =3D Cmdliner_arg +module Term =3D struct + type ('a, 'b) stdlib_result =3D ('a, 'b) result + + include Cmdliner_term + + (* Deprecated *) + + let man_format =3D Cmdliner_arg.man_format + let pure =3D const + + (* Terms *) + + let ( $ ) =3D app + + type 'a ret =3D [ `Ok of 'a | term_escape ] + + let ret (al, v) =3D + al, fun ei cl -> match v ei cl with + | Ok (`Ok v) -> Ok v + | Ok (`Error _ as err) -> Error err + | Ok (`Help _ as help) -> Error help + | Error _ as e -> e + + let term_result ?(usage =3D false) (al, v) =3D + al, fun ei cl -> match v ei cl with + | Ok (Ok _ as ok) -> ok + | Ok (Error (`Msg e)) -> Error (`Error (usage, e)) + | Error _ as e -> e + + let cli_parse_result (al, v) =3D + al, fun ei cl -> match v ei cl with + | Ok (Ok _ as ok) -> ok + | Ok (Error (`Msg e)) -> Error (`Parse e) + | Error _ as e -> e + + let main_name =3D + Cmdliner_info.Args.empty, + (fun ei _ -> Ok (Cmdliner_info.(term_name @@ eval_main ei))) + + let choice_names =3D + let choice_name t =3D Cmdliner_info.term_name t in + Cmdliner_info.Args.empty, + (fun ei _ -> Ok (List.rev_map choice_name (Cmdliner_info.eval_choices = ei))) + + let with_used_args (al, v) : (_ * string list) t =3D + al, fun ei cl -> + match v ei cl with + | Ok x -> + let actual_args arg_info acc =3D + let args =3D Cmdliner_cline.actual_args cl arg_info in + List.rev_append args acc + in + let used =3D List.rev (Cmdliner_info.Args.fold actual_args al []= ) in + Ok (x, used) + | Error _ as e -> e + + (* Term information *) + + type exit_info =3D Cmdliner_info.exit + let exit_info =3D Cmdliner_info.exit + + let exit_status_success =3D 0 + let exit_status_cli_error =3D 124 + let exit_status_internal_error =3D 125 + let default_error_exits =3D + [ exit_info exit_status_cli_error ~doc:"on command line parsing errors= ."; + exit_info exit_status_internal_error + ~doc:"on unexpected internal errors (bugs)."; ] + + let default_exits =3D + (exit_info exit_status_success ~doc:"on success.") :: default_error_ex= its + + type env_info =3D Cmdliner_info.env + let env_info =3D Cmdliner_info.env + + type info =3D Cmdliner_info.term + let info =3D Cmdliner_info.term ~args:Cmdliner_info.Args.empty + let name ti =3D Cmdliner_info.term_name ti + + (* Evaluation *) + + let err_help s =3D "Term error, help requested for unknown command " ^ s + let err_argv =3D "argv array must have at least one element" + let err_multi_cmd_def name (a, _) (a', _) =3D + Cmdliner_base.err_multi_def ~kind:"command" name Cmdliner_info.term_do= c a a' + + type 'a result =3D + [ `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ] + + let add_stdopts ei =3D + let docs =3D Cmdliner_info.(term_stdopts_docs @@ eval_term ei) in + let vargs, vers =3D match Cmdliner_info.(term_version @@ eval_main ei)= with + | None -> Cmdliner_info.Args.empty, None + | Some _ -> + let args, _ as vers =3D Cmdliner_arg.stdopt_version ~docs in + args, Some vers + in + let help =3D Cmdliner_arg.stdopt_help ~docs in + let args =3D Cmdliner_info.Args.union vargs (fst help) in + let term =3D Cmdliner_info.(term_add_args (eval_term ei) args) in + help, vers, Cmdliner_info.eval_with_term ei term + + type 'a eval_result =3D + ('a, [ term_escape + | `Exn of exn * Printexc.raw_backtrace + | `Parse of string + | `Std_help of Manpage.format | `Std_version ]) stdlib_result + + let run ~catch ei cl f =3D try (f ei cl :> 'a eval_result) with + | exn when catch -> + let bt =3D Printexc.get_raw_backtrace () in + Error (`Exn (exn, bt)) + + let try_eval_stdopts ~catch ei cl help version =3D + match run ~catch ei cl (snd help) with + | Ok (Some fmt) -> Some (Error (`Std_help fmt)) + | Error _ as err -> Some err + | Ok None -> + match version with + | None -> None + | Some version -> + match run ~catch ei cl (snd version) with + | Ok false -> None + | Ok true -> Some (Error (`Std_version)) + | Error _ as err -> Some err + + let term_eval ~catch ei f args =3D + let help, version, ei =3D add_stdopts ei in + let term_args =3D Cmdliner_info.(term_args @@ eval_term ei) in + let res =3D match Cmdliner_cline.create term_args args with + | Error (e, cl) -> + begin match try_eval_stdopts ~catch ei cl help version with + | Some e -> e + | None -> Error (`Error (true, e)) + end + | Ok cl -> + match try_eval_stdopts ~catch ei cl help version with + | Some e -> e + | None -> run ~catch ei cl f + in + ei, res + + let term_eval_peek_opts ei f args =3D + let help, version, ei =3D add_stdopts ei in + let term_args =3D Cmdliner_info.(term_args @@ eval_term ei) in + let v, ret =3D match Cmdliner_cline.create ~peek_opts:true term_args a= rgs with + | Error (e, cl) -> + begin match try_eval_stdopts ~catch:true ei cl help version with + | Some e -> None, e + | None -> None, Error (`Error (true, e)) + end + | Ok cl -> + let ret =3D run ~catch:true ei cl f in + let v =3D match ret with Ok v -> Some v | Error _ -> None in + match try_eval_stdopts ~catch:true ei cl help version with + | Some e -> v, e + | None -> v, ret + in + let ret =3D match ret with + | Ok v -> `Ok v + | Error `Std_help _ -> `Help + | Error `Std_version -> `Version + | Error `Parse _ -> `Error `Parse + | Error `Help _ -> `Help + | Error `Exn _ -> `Error `Exn + | Error `Error _ -> `Error `Term + in + v, ret + + let do_help help_ppf err_ppf ei fmt cmd =3D + let ei =3D match cmd with + | None -> Cmdliner_info.(eval_with_term ei @@ eval_main ei) + | Some cmd -> + try + let is_cmd t =3D Cmdliner_info.term_name t =3D cmd in + let cmd =3D List.find is_cmd (Cmdliner_info.eval_choices ei) in + Cmdliner_info.eval_with_term ei cmd + with Not_found -> invalid_arg (err_help cmd) + in + let _, _, ei =3D add_stdopts ei (* may not be the originally eval'd te= rm *) in + Cmdliner_docgen.pp_man ~errs:err_ppf fmt help_ppf ei + + let do_result help_ppf err_ppf ei =3D function + | Ok v -> `Ok v + | Error res -> + match res with + | `Std_help fmt -> Cmdliner_docgen.pp_man err_ppf fmt help_ppf ei; `= Help + | `Std_version -> Cmdliner_msg.pp_version help_ppf ei; `Version + | `Parse err -> + Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; + `Error `Parse + | `Help (fmt, cmd) -> do_help help_ppf err_ppf ei fmt cmd; `Help + | `Exn (e, bt) -> Cmdliner_msg.pp_backtrace err_ppf ei e bt; `Error = `Exn + | `Error (usage, err) -> + (if usage + then Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:true ~err + else Cmdliner_msg.pp_err err_ppf ei ~err); + `Error `Term + + (* API *) + + let env_default v =3D try Some (Sys.getenv v) with Not_found -> None + let remove_exec argv =3D + try List.tl (Array.to_list argv) with Failure _ -> invalid_arg err_argv + + let eval + ?help:(help_ppf =3D Format.std_formatter) + ?err:(err_ppf =3D Format.err_formatter) + ?(catch =3D true) ?(env =3D env_default) ?(argv =3D Sys.argv) ((al, = f), ti) =3D + let term =3D Cmdliner_info.term_add_args ti al in + let ei =3D Cmdliner_info.eval ~term ~main:term ~choices:[] ~env in + let args =3D remove_exec argv in + let ei, res =3D term_eval ~catch ei f args in + do_result help_ppf err_ppf ei res + + let choose_term main choices =3D function + | [] -> Ok (main, []) + | maybe :: args' as args -> + if String.length maybe > 1 && maybe.[0] =3D '-' then Ok (main, args)= else + let index =3D + let add acc (choice, _ as c) =3D + let name =3D Cmdliner_info.term_name choice in + match Cmdliner_trie.add acc name c with + | `New t -> t + | `Replaced (c', _) -> invalid_arg (err_multi_cmd_def name c c') + in + List.fold_left add Cmdliner_trie.empty choices + in + match Cmdliner_trie.find index maybe with + | `Ok choice -> Ok (choice, args') + | `Not_found -> + let all =3D Cmdliner_trie.ambiguities index "" in + let hints =3D Cmdliner_suggest.value maybe all in + Error (Cmdliner_base.err_unknown ~kind:"command" maybe ~hints) + | `Ambiguous -> + let ambs =3D Cmdliner_trie.ambiguities index maybe in + let ambs =3D List.sort compare ambs in + Error (Cmdliner_base.err_ambiguous ~kind:"command" maybe ~ambs) + + let eval_choice + ?help:(help_ppf =3D Format.std_formatter) + ?err:(err_ppf =3D Format.err_formatter) + ?(catch =3D true) ?(env =3D env_default) ?(argv =3D Sys.argv) + main choices =3D + let to_term_f ((al, f), ti) =3D Cmdliner_info.term_add_args ti al, f in + let choices_f =3D List.rev_map to_term_f choices in + let main_f =3D to_term_f main in + let choices =3D List.rev_map fst choices_f in + let main =3D fst main_f in + match choose_term main_f choices_f (remove_exec argv) with + | Error err -> + let ei =3D Cmdliner_info.eval ~term:main ~main ~choices ~env in + Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; + `Error `Parse + | Ok ((chosen, f), args) -> + let ei =3D Cmdliner_info.eval ~term:chosen ~main ~choices ~env in + let ei, res =3D term_eval ~catch ei f args in + do_result help_ppf err_ppf ei res + + let eval_peek_opts + ?(version_opt =3D false) ?(env =3D env_default) ?(argv =3D Sys.argv) + ((args, f) : 'a t) =3D + let version =3D if version_opt then Some "dummy" else None in + let term =3D Cmdliner_info.term ~args ?version "dummy" in + let ei =3D Cmdliner_info.eval ~term ~main:term ~choices:[] ~env in + (term_eval_peek_opts ei f (remove_exec argv) :> 'a option * 'a result) + + (* Exits *) + + let exit_status_of_result ?(term_err =3D 1) =3D function + | `Ok _ | `Help | `Version -> exit_status_success + | `Error `Term -> term_err + | `Error `Exn -> exit_status_internal_error + | `Error `Parse -> exit_status_cli_error + + let exit_status_of_status_result ?term_err =3D function + | `Ok n -> n + | r -> exit_status_of_result ?term_err r + + let stdlib_exit =3D exit + let exit ?term_err r =3D stdlib_exit (exit_status_of_result ?term_err r) + let exit_status ?term_err r =3D + stdlib_exit (exit_status_of_status_result ?term_err r) + +end + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner.mli b/tools/ocaml/= duniverse/cmdliner/src/cmdliner.mli new file mode 100644 index 0000000000..a993e83c4e --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner.mli @@ -0,0 +1,1624 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** Declarative definition of command line interfaces. + + [Cmdliner] provides a simple and compositional mechanism + to convert command line arguments to OCaml values and pass them to + your functions. The module automatically handles syntax errors, + help messages and UNIX man page generation. It supports programs + with single or multiple commands + (like [darcs] or [git]) and respect most of the + {{:http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.h= tml} + POSIX} and + {{:http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.h= tml} + GNU} conventions. + + Consult the {{!basics}basics}, details about the supported + {{!cmdline}command line syntax} and {{!examples} examples} of + use. Open the module to use it, it defines only three modules in + your scope. + + {e %%VERSION%% =E2=80=94 {{:%%PKG_HOMEPAGE%% }homepage}} *) + +(** {1:top Interface} *) + +(** Man page specification. + + Man page generation is automatically handled by [Cmdliner], + consult the {{!manual}details}. + + The {!block} type is used to define a man page's content. It's a + good idea to follow the {{!standard_sections}standard} manual page + structure. + + {b References.} + {ul + {- [man-pages(7)], {{:http://man7.org/linux/man-pages/man7/man-pages.7.= html} + {e Conventions for writing Linux man pages}}.}} *) +module Manpage : sig + + (** {1:man Man pages} *) + + type block =3D + [ `S of string | `P of string | `Pre of string | `I of string * string + | `Noblank | `Blocks of block list ] + (** The type for a block of man page text. + + {ul + {- [`S s] introduces a new section [s], see the + {{!standard_sections}standard section names}.} + {- [`P t] is a new paragraph with text [t].} + {- [`Pre t] is a new preformatted paragraph with text [t].} + {- [`I (l,t)] is an indented paragraph with label + [l] and text [t].} + {- [`Noblank] suppresses the blank line introduced between two block= s.} + {- [`Blocks bs] splices the blocks [bs].}} + + Except in [`Pre], whitespace and newlines are not significant + and are all collapsed to a single space. All block strings + support the {{!doclang}documentation markup language}.*) + + val escape : string -> string + (** [escape s] escapes [s] so that it doesn't get interpreted by the + {{!doclang}documentation markup language}. *) + + type title =3D string * int * string * string * string + (** The type for man page titles. Describes the man page + [title], [section], [center_footer], [left_footer], [center_header].= *) + + type t =3D title * block list + (** The type for a man page. A title and the page text as a list of bloc= ks. *) + + type xref =3D + [ `Main | `Cmd of string | `Tool of string | `Page of string * int ] + (** The type for man page cross-references. + {ul + {- [`Main] refers to the man page of the program itself.} + {- [`Cmd cmd] refers to the man page of the program's [cmd] + command (which must exist).} + {- [`Tool bin] refers to the command line tool named [bin].} + {- [`Page (name, sec)] refers to the man page [name(sec)].}} *) + + (** {1:standard_sections Standard section names and content} + + The following are standard man page section names, roughly ordered + in the order they conventionally appear. See also + {{:http://man7.org/linux/man-pages/man7/man-pages.7.html}[man man-pa= ges]} + for more elaborations about what sections should contain. *) + + val s_name : string + (** The [NAME] section. This section is automatically created by + [Cmdliner] for your. *) + + val s_synopsis : string + (** The [SYNOPSIS] section. By default this section is automatically + created by [Cmdliner] for you, unless it is the first section of + your term's man page, in which case it will replace it with yours. *) + + val s_description : string + (** The [DESCRIPTION] section. This should be a description of what + the tool does and provide a little bit of usage and + documentation guidance. *) + + val s_commands : string + (** The [COMMANDS] section. By default subcommands get listed here. *) + + val s_arguments : string + (** The [ARGUMENTS] section. By default positional arguments get + listed here. *) + + val s_options : string + (** The [OPTIONS] section. By default options and flag arguments get + listed here. *) + + val s_common_options : string + (** The [COMMON OPTIONS] section. For programs with multiple commands + a section that can be used to gather options common to all commands.= *) + + val s_exit_status : string + (** The [EXIT STATUS] section. By default term status exit codes + get listed here. *) + + val s_environment : string + (** The [ENVIRONMENT] section. By default environment variables get + listed here. *) + + val s_environment_intro : block + (** [s_environment_intro] is the introduction content used by cmdliner + when it creates the {!s_environment} section. *) + + val s_files : string + (** The [FILES] section. *) + + val s_bugs : string + (** The [BUGS] section. *) + + val s_examples : string + (** The [EXAMPLES] section. *) + + val s_authors : string + (** The [AUTHORS] section. *) + + val s_see_also : string + (** The [SEE ALSO] section. *) + + (** {1:output Output} + + The {!print} function can be useful if the client wants to define + other man pages (e.g. to implement a help command). *) + + type format =3D [ `Auto | `Pager | `Plain | `Groff ] + (** The type for man page output specification. + {ul + {- [`Auto], formats like [`Pager] or [`Plain] whenever the [TERM] + environment variable is [dumb] or unset.} + {- [`Pager], tries to write to a discovered pager, if that fails + uses the [`Plain] format.} + {- [`Plain], formats to plain text.} + {- [`Groff], formats to groff commands.}} *) + + val print : + ?errs:Format.formatter -> + ?subst:(string -> string option) -> format -> Format.formatter -> t ->= unit + (** [print ~errs ~subst fmt ppf page] prints [page] on [ppf] in the + format [fmt]. [subst] can be used to perform variable + substitution,(defaults to the identity). [errs] is used to print + formatting errors, it defaults to {!Format.err_formatter}. *) +end + +(** Terms. + + A term is evaluated by a program to produce a {{!result}result}, + which can be turned into an {{!exits}exit status}. A term made of terms + referring to {{!Arg}command line arguments} implicitly defines a + command line syntax. *) +module Term : sig + + (** {1:terms Terms} *) + + type +'a t + (** The type for terms evaluating to values of type 'a. *) + + val const : 'a -> 'a t + (** [const v] is a term that evaluates to [v]. *) + + (**/**) + val pure : 'a -> 'a t + (** @deprecated use {!const} instead. *) + + val man_format : Manpage.format t + (** @deprecated Use {!Arg.man_format} instead. *) + (**/**) + + val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t + (** [f $ v] is a term that evaluates to the result of applying + the evaluation of [v] to the one of [f]. *) + + val app : ('a -> 'b) t -> 'a t -> 'b t + (** [app] is {!($)}. *) + + (** {1 Interacting with Cmdliner's evaluation} *) + + type 'a ret =3D + [ `Help of Manpage.format * string option + | `Error of (bool * string) + | `Ok of 'a ] + (** The type for command return values. See {!ret}. *) + + val ret : 'a ret t -> 'a t + (** [ret v] is a term whose evaluation depends on the case + to which [v] evaluates. With : + {ul + {- [`Ok v], it evaluates to [v].} + {- [`Error (usage, e)], the evaluation fails and [Cmdliner] prints + the error [e] and the term's usage if [usage] is [true].} + {- [`Help (format, name)], the evaluation fails and [Cmdliner] print= s the + term's man page in the given [format] (or the man page for a + specific [name] term in case of multiple term evaluation).}} *) + + val term_result : ?usage:bool -> ('a, [`Msg of string]) result t -> 'a t + (** [term_result ~usage t] evaluates to + {ul + {- [`Ok v] if [t] evaluates to [Ok v]} + {- [`Error `Term] with the error message [e] and usage shown accordi= ng + to [usage] (defaults to [false]), if [t] evaluates to + [Error (`Msg e)].}} *) + + val cli_parse_result : ('a, [`Msg of string]) result t -> 'a t + (** [cli_parse_result t] is a term that evaluates to: + {ul + {- [`Ok v] if [t] evaluates to [Ok v].} + {- [`Error `Parse] with the error message [e] + if [t] evaluates to [Error (`Msg e)].}} *) + + val main_name : string t + (** [main_name] is a term that evaluates to the "main" term's name. *) + + val choice_names : string list t + (** [choice_names] is a term that evaluates to the names of the terms + to choose from. *) + + val with_used_args : 'a t -> ('a * string list) t + (** [with_used_args t] is a term that evaluates to [t] tupled + with the arguments from the command line that where used to + evaluate [t]. *) + + (** {1:tinfo Term information} + + Term information defines the name and man page of a term. + For simple evaluation this is the name of the program and its + man page. For multiple term evaluation, this is + the name of a command and its man page. *) + + type exit_info + (** The type for exit status information. *) + + val exit_info : ?docs:string -> ?doc:string -> ?max:int -> int -> exit_i= nfo + (** [exit_info ~docs ~doc min ~max] describe the range of exit + statuses from [min] to [max] (defaults to [min]). [doc] is the + man page information for the statuses, defaults to ["undocumented"]. + [docs] is the title of the man page section in which the statuses + will be listed, it defaults to {!Manpage.s_exit_status}. + + In [doc] the {{!doclang}documentation markup language} can be + used with following variables: + {ul + {- [$(status)], the value of [min].} + {- [$(status_max)], the value of [max].} + {- The variables mentioned in {!info}}} *) + + val default_exits : exit_info list + (** [default_exits] is information for exit status {!exit_status_success} + added to {!default_error_exits}. *) + + val default_error_exits : exit_info list + (** [default_error_exits] is information for exit statuses + {!exit_status_cli_error} and {!exit_status_internal_error}. *) + + type env_info + (** The type for environment variable information. *) + + val env_info : ?docs:string -> ?doc:string -> string -> env_info + (** [env_info ~docs ~doc var] describes an environment variable + [var]. [doc] is the man page information of the environment + variable, defaults to ["undocumented"]. [docs] is the title of + the man page section in which the environment variable will be + listed, it defaults to {!Manpage.s_environment}. + + In [doc] the {{!doclang}documentation markup language} can be + used with following variables: + {ul + {- [$(env)], the value of [var].} + {- The variables mentioned in {!info}}} *) + + type info + (** The type for term information. *) + + val info : + ?man_xrefs:Manpage.xref list -> ?man:Manpage.block list -> + ?envs:env_info list -> ?exits:exit_info list -> ?sdocs:string -> + ?docs:string -> ?doc:string -> ?version:string -> string -> info + (** [info sdocs man docs doc version name] is a term information + such that: + {ul + {- [name] is the name of the program or the command.} + {- [version] is the version string of the program, ignored + for commands.} + {- [doc] is a one line description of the program or command used + for the [NAME] section of the term's man page. For commands this + description is also used in the list of commands of the main + term's man page.} + {- [docs], only for commands, the title of the section of the main + term's man page where it should be listed (defaults to + {!Manpage.s_commands}).} + {- [sdocs] defines the title of the section in which the + standard [--help] and [--version] arguments are listed + (defaults to {!Manpage.s_options}).} + {- [exits] is a list of exit statuses that the term evaluation + may produce.} + {- [envs] is a list of environment variables that influence + the term's evaluation.} + {- [man] is the text of the man page for the term.} + {- [man_xrefs] are cross-references to other manual pages. These + are used to generate a {!Manpage.s_see_also} section.}} + [doc], [man], [envs] support the {{!doclang}documentation markup + language} in which the following variables are recognized: + {ul + {- [$(tname)] the term's name.} + {- [$(mname)] the main term's name.}} *) + + val name : info -> string + (** [name ti] is the name of the term information. *) + + (** {1:evaluation Evaluation} *) + + type 'a result =3D + [ `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ] + (** The type for evaluation results. + {ul + {- [`Ok v], the term evaluated successfully and [v] is the result.} + {- [`Version], the version string of the main term was printed + on the help formatter.} + {- [`Help], man page about the term was printed on the help formatte= r.} + {- [`Error `Parse], a command line parse error occurred and was + reported on the error formatter.} + {- [`Error `Term], a term evaluation error occurred and was reported + on the error formatter (see {!Term.ret}).} + {- [`Error `Exn], an exception [e] was caught and reported + on the error formatter (see the [~catch] parameter of {!eval}).}}= *) + + val eval : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> ('a t * info) = -> + 'a result + (** [eval help err catch argv (t,i)] is the evaluation result + of [t] with command line arguments [argv] (defaults to {!Sys.argv}). + + If [catch] is [true] (default) uncaught exceptions + are intercepted and their stack trace is written to the [err] + formatter. + + [help] is the formatter used to print help or version messages + (defaults to {!Format.std_formatter}). [err] is the formatter + used to print error messages (defaults to {!Format.err_formatter}). + + [env] is used for environment variable lookup, the default + uses {!Sys.getenv}. *) + + val eval_choice : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + 'a t * info -> ('a t * info) list -> 'a result + (** [eval_choice help err catch argv (t,i) choices] is like {!eval} + except that if the first argument on the command line is not an opti= on + name it will look in [choices] for a term whose information has this + name and evaluate it. + + If the command name is unknown an error is reported. If the name + is unspecified the "main" term [t] is evaluated. [i] defines the + name and man page of the program. *) + + val eval_peek_opts : + ?version_opt:bool -> ?env:(string -> string option) -> + ?argv:string array -> 'a t -> 'a option * 'a result + (** [eval_peek_opts version_opt argv t] evaluates [t], a term made + of optional arguments only, with the command line [argv] + (defaults to {!Sys.argv}). In this evaluation, unknown optional + arguments and positional arguments are ignored. + + The evaluation returns a pair. The first component is + the result of parsing the command line [argv] stripped from + any help and version option if [version_opt] is [true] (defaults + to [false]). It results in: + {ul + {- [Some _] if the command line would be parsed correctly given the + {e partial} knowledge in [t].} + {- [None] if a parse error would occur on the options of [t]}} + + The second component is the result of parsing the command line + [argv] without stripping the help and version options. It + indicates what the evaluation would result in on [argv] given + the partial knowledge in [t] (for example it would return + [`Help] if there's a help option in [argv]). However in + contrasts to {!eval} and {!eval_choice} no side effects like + error reporting or help output occurs. + + {b Note.} Positional arguments can't be peeked without the full + specification of the command line: we can't tell apart a + positional argument from the value of an unknown optional + argument. *) + + (** {1:exits Turning evaluation results into exit codes} + + {b Note.} If you are using the following functions to handle + the evaluation result of a term you should add {!default_exits} to + the term's information {{!info}[~exits]} argument. + + {b WARNING.} You should avoid status codes strictly greater than 125 + as those may be used by + {{:https://www.gnu.org/software/bash/manual/html_node/Exit-Status.ht= ml} + some} shells. *) + + val exit_status_success : int + (** [exit_status_success] is 0, the exit status for success. *) + + val exit_status_cli_error : int + (** [exit_status_cli_error] is 124, an exit status for command line + parsing errors. *) + + val exit_status_internal_error : int + (** [exit_status_internal_error] is 125, an exit status for unexpected + internal errors. *) + + val exit_status_of_result : ?term_err:int -> 'a result -> int + (** [exit_status_of_result ~term_err r] is an [exit(3)] status + code determined from [r] as follows: + {ul + {- {!exit_status_success} if [r] is one of [`Ok _], [`Version], [`He= lp]} + {- [term_err] if [r] is [`Error `Term], [term_err] defaults to [1].} + {- {!exit_status_cli_error} if [r] is [`Error `Parse]} + {- {!exit_status_internal_error} if [r] is [`Error `Exn]}} *) + + val exit_status_of_status_result : ?term_err:int -> int result -> int + (** [exit_status_of_status_result] is like {!exit_status_of_result} + except for [`Ok n] where [n] is used as the status exit code. *) + + val exit : ?term_err:int -> 'a result -> unit + (** [exit ~term_err r] is + [Stdlib.exit @@ exit_status_of_result ~term_err r] *) + + val exit_status : ?term_err:int -> int result -> unit + (** [exit_status ~term_err r] is + [Stdlib.exit @@ exit_status_of_status_result ~term_err r] *) +end + +(** Terms for command line arguments. + + This module provides functions to define terms that evaluate + to the arguments provided on the command line. + + Basic constraints, like the argument type or repeatability, are + specified by defining a value of type {!t}. Further constraints can + be specified during the {{!argterms}conversion} to a term. *) +module Arg : sig + +(** {1:argconv Argument converters} + + An argument converter transforms a string argument of the command + line to an OCaml value. {{!converters}Predefined converters} + are provided for many types of the standard library. *) + + type 'a parser =3D string -> [ `Ok of 'a | `Error of string ] + (** The type for argument parsers. + + @deprecated Use a parser with [('a, [ `Msg of string]) result] resul= ts + and {!conv}. *) + + type 'a printer =3D Format.formatter -> 'a -> unit + (** The type for converted argument printers. *) + + type 'a conv =3D 'a parser * 'a printer + (** The type for argument converters. + + {b WARNING.} This type will become abstract in the next + major version of cmdliner, use {!val:conv} or {!pconv} + to construct values of this type. *) + + type 'a converter =3D 'a conv + (** @deprecated Use the {!type:conv} type via the {!val:conv} and {!pcon= v} + functions. *) + + val conv : + ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a printer= -> + 'a conv + (** [converter ~docv (parse, print)] is an argument converter + parsing values with [parse] and printing them with + [print]. [docv] is a documentation meta-variable used in the + documentation to stand for the argument value, defaults to + ["VALUE"]. *) + + val pconv : + ?docv:string -> 'a parser * 'a printer -> 'a conv + (** [pconv] is like {!converter}, but uses a deprecated {!parser} + signature. *) + + val conv_parser : 'a conv -> (string -> ('a, [`Msg of string]) result) + (** [conv_parser c] 's [c]'s parser. *) + + val conv_printer : 'a conv -> 'a printer + (** [conv_printer c] is [c]'s printer. *) + + val conv_docv : 'a conv -> string + (** [conv_docv c] is [c]'s documentation meta-variable. + + {b WARNING.} Currently always returns ["VALUE"] in the future + will return the value given to {!conv} or {!pconv}. *) + + val parser_of_kind_of_string : + kind:string -> (string -> 'a option) -> + (string -> ('a, [`Msg of string]) result) + (** [parser_of_kind_of_string ~kind kind_of_string] is an argument + parser using the [kind_of_string] function for parsing and [kind] + to report errors (e.g. could be ["an integer"] for an [int] parser.)= . *) + + val some : ?none:string -> 'a conv -> 'a option conv + (** [some none c] is like the converter [c] except it returns + [Some] value. It is used for command line arguments + that default to [None] when absent. [none] is what to print to + document the absence (defaults to [""]). *) + +(** {1:arginfo Arguments and their information} + + Argument information defines the man page information of an + argument and, for optional arguments, its names. An environment + variable can also be specified to read the argument value from + if the argument is absent from the command line and the variable + is defined. *) + + type env =3D Term.env_info + (** The type for environment variables and their documentation. *) + + val env_var : ?docs:string -> ?doc:string -> string -> env + (** [env_var docs doc var] is an environment variables [var]. [doc] + is the man page information of the environment variable, the + {{!doclang}documentation markup language} with the variables + mentioned in {!info} be used; it defaults to ["See option + $(opt)."]. [docs] is the title of the man page section in which + the environment variable will be listed, it defaults to + {!Manpage.s_environment}. *) + + type 'a t + (** The type for arguments holding data of type ['a]. *) + + type info + (** The type for information about command line arguments. *) + + val info : + ?docs:string -> ?docv:string -> ?doc:string -> ?env:env -> string list= -> + info + (** [info docs docv doc env names] defines information for + an argument. + {ul + {- [names] defines the names under which an optional argument + can be referred to. Strings of length [1] (["c"]) define + short option names (["-c"]), longer strings (["count"]) + define long option names (["--count"]). [names] must be empty + for positional arguments.} + {- [env] defines the name of an environment variable which is + looked up for defining the argument if it is absent from the + command line. See {{!envlookup}environment variables} for + details.} + {- [doc] is the man page information of the argument. + The {{!doclang}documentation language} can be used and + the following variables are recognized: + {ul + {- ["$(docv)"] the value of [docv] (see below).} + {- ["$(opt)"], one of the options of [names], preference + is given to a long one.} + {- ["$(env)"], the environment var specified by [env] (if any).}} + {{!doc_helpers}These functions} can help with formatting argument + values.} + {- [docv] is for positional and non-flag optional arguments. + It is a variable name used in the man page to stand for their val= ue.} + {- [docs] is the title of the man page section in which the argument + will be listed. For optional arguments this defaults + to {!Manpage.s_options}. For positional arguments this defaults + to {!Manpage.s_arguments}. However a positional argument is only + listed if it has both a [doc] and [docv] specified.}} *) + + val ( & ) : ('a -> 'b) -> 'a -> 'b + (** [f & v] is [f v], a right associative composition operator for + specifying argument terms. *) + +(** {1:optargs Optional arguments} + + The information of an optional argument must have at least + one name or [Invalid_argument] is raised. *) + + val flag : info -> bool t + (** [flag i] is a [bool] argument defined by an optional flag + that may appear {e at most} once on the command line under one of + the names specified by [i]. The argument holds [true] if the + flag is present on the command line and [false] otherwise. *) + + val flag_all : info -> bool list t + (** [flag_all] is like {!flag} except the flag may appear more than + once. The argument holds a list that contains one [true] value per + occurrence of the flag. It holds the empty list if the flag + is absent from the command line. *) + + val vflag : 'a -> ('a * info) list -> 'a t + (** [vflag v \[v]{_0}[,i]{_0}[;...\]] is an ['a] argument defined + by an optional flag that may appear {e at most} once on + the command line under one of the names specified in the [i]{_k} + values. The argument holds [v] if the flag is absent from the + command line and the value [v]{_k} if the name under which it appears + is in [i]{_k}. + + {b Note.} Environment variable lookup is unsupported for + for these arguments. *) + + val vflag_all : 'a list -> ('a * info) list -> 'a list t + (** [vflag_all v l] is like {!vflag} except the flag may appear more + than once. The argument holds the list [v] if the flag is absent + from the command line. Otherwise it holds a list that contains one + corresponding value per occurrence of the flag, in the order found on + the command line. + + {b Note.} Environment variable lookup is unsupported for + for these arguments. *) + + val opt : ?vopt:'a -> 'a conv -> 'a -> info -> 'a t + (** [opt vopt c v i] is an ['a] argument defined by the value of + an optional argument that may appear {e at most} once on the command + line under one of the names specified by [i]. The argument holds + [v] if the option is absent from the command line. Otherwise + it has the value of the option as converted by [c]. + + If [vopt] is provided the value of the optional argument is itself + optional, taking the value [vopt] if unspecified on the command line= . *) + + val opt_all : ?vopt:'a -> 'a conv -> 'a list -> info -> 'a list t + (** [opt_all vopt c v i] is like {!opt} except the optional argument may + appear more than once. The argument holds a list that contains one v= alue + per occurrence of the flag in the order found on the command line. + It holds the list [v] if the flag is absent from the command line. *) + + (** {1:posargs Positional arguments} + + The information of a positional argument must have no name + or [Invalid_argument] is raised. Positional arguments indexing + is zero-based. + + {b Warning.} The following combinators allow to specify and + extract a given positional argument with more than one term. + This should not be done as it will likely confuse end users and + documentation generation. These over-specifications may be + prevented by raising [Invalid_argument] in the future. But for now + it is the client's duty to make sure this doesn't happen. *) + + val pos : ?rev:bool -> int -> 'a conv -> 'a -> info -> 'a t + (** [pos rev n c v i] is an ['a] argument defined by the [n]th + positional argument of the command line as converted by [c]. + If the positional argument is absent from the command line + the argument is [v]. + + If [rev] is [true] (defaults to [false]), the computed + position is [max-n] where [max] is the position of + the last positional argument present on the command line. *) + + val pos_all : 'a conv -> 'a list -> info -> 'a list t + (** [pos_all c v i] is an ['a list] argument that holds + all the positional arguments of the command line as converted + by [c] or [v] if there are none. *) + + val pos_left : + ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t + (** [pos_left rev n c v i] is an ['a list] argument that holds + all the positional arguments as converted by [c] found on the left + of the [n]th positional argument or [v] if there are none. + + If [rev] is [true] (defaults to [false]), the computed + position is [max-n] where [max] is the position of + the last positional argument present on the command line. *) + + val pos_right : + ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t + (** [pos_right] is like {!pos_left} except it holds all the positional + arguments found on the right of the specified positional argument. *) + + (** {1:argterms Arguments as terms} *) + + val value : 'a t -> 'a Term.t + (** [value a] is a term that evaluates to [a]'s value. *) + + val required : 'a option t -> 'a Term.t + (** [required a] is a term that fails if [a]'s value is [None] and + evaluates to the value of [Some] otherwise. Use this for required + positional arguments (it can also be used for defining required + optional arguments, but from a user interface perspective this + shouldn't be done, it is a contradiction in terms). *) + + val non_empty : 'a list t -> 'a list Term.t + (** [non_empty a] is term that fails if [a]'s list is empty and + evaluates to [a]'s list otherwise. Use this for non empty lists + of positional arguments. *) + + val last : 'a list t -> 'a Term.t + (** [last a] is a term that fails if [a]'s list is empty and evaluates + to the value of the last element of the list otherwise. Use this + for lists of flags or options where the last occurrence takes preced= ence + over the others. *) + + (** {1:predef Predefined arguments} *) + + val man_format : Manpage.format Term.t + (** [man_format] is a term that defines a [--man-format] option and + evaluates to a value that can be used with {!Manpage.print}. *) + + (** {1:converters Predefined converters} *) + + val bool : bool conv + (** [bool] converts values with {!bool_of_string}. *) + + val char : char conv + (** [char] converts values by ensuring the argument has a single char. *) + + val int : int conv + (** [int] converts values with {!int_of_string}. *) + + val nativeint : nativeint conv + (** [nativeint] converts values with {!Nativeint.of_string}. *) + + val int32 : int32 conv + (** [int32] converts values with {!Int32.of_string}. *) + + val int64 : int64 conv + (** [int64] converts values with {!Int64.of_string}. *) + + val float : float conv + (** [float] converts values with {!float_of_string}. *) + + val string : string conv + (** [string] converts values with the identity function. *) + + val enum : (string * 'a) list -> 'a conv + (** [enum l p] converts values such that unambiguous prefixes of string = names + in [l] map to the corresponding value of type ['a]. + + {b Warning.} The type ['a] must be comparable with {!Pervasives.comp= are}. + + @raise Invalid_argument if [l] is empty. *) + + val file : string conv + (** [file] converts a value with the identity function and + checks with {!Sys.file_exists} that a file with that name exists. *) + + val dir : string conv + (** [dir] converts a value with the identity function and checks + with {!Sys.file_exists} and {!Sys.is_directory} + that a directory with that name exists. *) + + val non_dir_file : string conv + (** [non_dir_file] converts a value with the identity function and checks + with {!Sys.file_exists} and {!Sys.is_directory} + that a non directory file with that name exists. *) + + val list : ?sep:char -> 'a conv -> 'a list conv + (** [list sep c] splits the argument at each [sep] (defaults to [',']) + character and converts each substrings with [c]. *) + + val array : ?sep:char -> 'a conv -> 'a array conv + (** [array sep c] splits the argument at each [sep] (defaults to [',']) + character and converts each substring with [c]. *) + + val pair : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv + (** [pair sep c0 c1] splits the argument at the {e first} [sep] character + (defaults to [',']) and respectively converts the substrings with + [c0] and [c1]. *) + + val t2 : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv + (** {!t2} is {!pair}. *) + + val t3 : ?sep:char -> 'a conv ->'b conv -> 'c conv -> ('a * 'b * 'c) conv + (** [t3 sep c0 c1 c2] splits the argument at the {e first} two [sep] + characters (defaults to [',']) and respectively converts the + substrings with [c0], [c1] and [c2]. *) + + val t4 : + ?sep:char -> 'a conv -> 'b conv -> 'c conv -> 'd conv -> + ('a * 'b * 'c * 'd) conv + (** [t4 sep c0 c1 c2 c3] splits the argument at the {e first} three [sep] + characters (defaults to [',']) respectively converts the substrings + with [c0], [c1], [c2] and [c3]. *) + + (** {1:doc_helpers Documentation formatting helpers} *) + + val doc_quote : string -> string + (** [doc_quote s] quotes the string [s]. *) + + val doc_alts : ?quoted:bool -> string list -> string + (** [doc_alts alts] documents the alternative tokens [alts] according + the number of alternatives. If [quoted] is [true] (default) + the tokens are quoted. The resulting string can be used in + sentences of the form ["$(docv) must be %s"]. + + @raise Invalid_argument if [alts] is the empty string. *) + + val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string + (** [doc_alts_enum quoted alts] is [doc_alts quoted (List.map fst alts)]= . *) +end + +(** {1:basics Basics} + + With [Cmdliner] your program evaluates a term. A {e term} is a value + of type {!Term.t}. The type parameter indicates the type of the + result of the evaluation. + +One way to create terms is by lifting regular OCaml values with +{!Term.const}. Terms can be applied to terms evaluating to functional +values with {!Term.( $ )}. For example for the function: + +{[ +let revolt () =3D print_endline "Revolt!" +]} + +the term : + +{[ +open Cmdliner + +let revolt_t =3D Term.(const revolt $ const ()) +]} + +is a term that evaluates to the result (and effect) of the [revolt] +function. Terms are evaluated with {!Term.eval}: + +{[ +let () =3D Term.exit @@ Term.eval (revolt_t, Term.info "revolt") +]} + +This defines a command line program named ["revolt"], without command +line arguments, that just prints ["Revolt!"] on [stdout]. + +{[ +> ./revolt +Revolt! +]} + +The combinators in the {!Arg} module allow to extract command line +argument data as terms. These terms can then be applied to lifted +OCaml functions to be evaluated by the program. + +Terms corresponding to command line argument data that are part of a +term evaluation implicitly define a command line syntax. We show this +on an concrete example. + +Consider the [chorus] function that prints repeatedly a given message : + +{[ +let chorus count msg =3D + for i =3D 1 to count do print_endline msg done +]} + +we want to make it available from the command line with the synopsis: + +{[ +chorus [-c COUNT | --count=3DCOUNT] [MSG] +]} + +where [COUNT] defaults to [10] and [MSG] defaults to ["Revolt!"]. We +first define a term corresponding to the [--count] option: + +{[ +let count =3D + let doc =3D "Repeat the message $(docv) times." in + Arg.(value & opt int 10 & info ["c"; "count"] ~docv:"COUNT" ~doc) +]} + +This says that [count] is a term that evaluates to the value of an +optional argument of type [int] that defaults to [10] if unspecified +and whose option name is either [-c] or [--count]. The arguments [doc] +and [docv] are used to generate the option's man page information. + +The term for the positional argument [MSG] is: + +{[ +let msg =3D + let doc =3D "Overrides the default message to print." in + let env =3D Arg.env_var "CHORUS_MSG" ~doc in + let doc =3D "The message to print." in + Arg.(value & pos 0 string "Revolt!" & info [] ~env ~docv:"MSG" ~doc) +]} + +which says that [msg] is a term whose value is the positional argument +at index [0] of type [string] and defaults to ["Revolt!"] or the +value of the environment variable [CHORUS_MSG] if the argument is +unspecified on the command line. Here again [doc] and [docv] are used +for the man page information. + +The term for executing [chorus] with these command line arguments is : + +{[ +let chorus_t =3D Term.(const chorus $ count $ msg) +]} + +and we are now ready to define our program: + +{[ +let info =3D + let doc =3D "print a customizable message repeatedly" in + let man =3D [ + `S Manpage.s_bugs; + `P "Email bug reports to ." ] + in + Term.info "chorus" ~version:"%=E2=80=8C%VERSION%%" ~doc ~exits:Term.defa= ult_exits ~man + +let () =3D Term.exit @@ Term.eval (chorus_t, info)) +]} + +The [info] value created with {!Term.info} gives more information +about the term we execute and is used to generate the program's man +page. Since we provided a [~version] string, the program will +automatically respond to the [--version] option by printing this +string. + +A program using {!Term.eval} always responds to the [--help] option by +showing the man page about the program generated using the information +you provided with {!Term.info} and {!Arg.info}. Here is the output +generated by our example : + +{v +> ./chorus --help +NAME + chorus - print a customizable message repeatedly + +SYNOPSIS + chorus [OPTION]... [MSG] + +ARGUMENTS + MSG (absent=3DRevolt! or CHORUS_MSG env) + The message to print. + +OPTIONS + -c COUNT, --count=3DCOUNT (absent=3D10) + Repeat the message COUNT times. + + --help[=3DFMT] (default=3Dauto) + Show this help in format FMT. The value FMT must be one of `aut= o', + `pager', `groff' or `plain'. With `auto', the format is `pager`= or + `plain' whenever the TERM env var is `dumb' or undefined. + + --version + Show version information. + +EXIT STATUS + chorus exits with the following status: + + 0 on success. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + +ENVIRONMENT + These environment variables affect the execution of chorus: + + CHORUS_MSG + Overrides the default message to print. + +BUGS + Email bug reports to . +v} + +If a pager is available, this output is written to a pager. This help +is also available in plain text or in the +{{:http://www.gnu.org/software/groff/groff.html}groff} man page format +by invoking the program with the option [--help=3Dplain] or +[--help=3Dgroff]. + +For examples of more complex command line definitions look and run +the {{!examples}examples}. + +{2:multiterms Multiple terms} + +[Cmdliner] also provides support for programs like [darcs] or [git] +that have multiple commands each with their own syntax: + +{[prog COMMAND [OPTION]... ARG...]} + +A command is defined by coupling a term with {{!Term.tinfo}term +information}. The term information defines the command name and its +man page. Given a list of commands the function {!Term.eval_choice} +will execute the term corresponding to the [COMMAND] argument or a +specific "main" term if there is no [COMMAND] argument. + +{2:doclang Documentation markup language} + +Manpage {{!Manpage.block}blocks} and doc strings support the following +markup language. + +{ul +{- Markup directives [$(i,text)] and [$(b,text)], where [text] is raw + text respectively rendered in italics and bold.} +{- Outside markup directives, context dependent variables of the form + [$(var)] are substituted by marked up data. For example in a term's + man page [$(tname)] is substituted by the term name in bold.} +{- Characters $, (, ) and \ can respectively be escaped by \$, \(, \) + and \\ (in OCaml strings this will be ["\\$"], ["\\("], ["\\)"], + ["\\\\"]). Escaping $ and \ is mandatory everywhere. Escaping ) is + mandatory only in markup directives. Escaping ( is only here for + your symmetric pleasure. Any other sequence of characters starting + with a \ is an illegal character sequence.} +{- Refering to unknown markup directives or variables will generate + errors on standard error during documentation generation.}} + +{2:manual Manual} + +Man page sections for a term are printed in the order specified by the +term manual as given to {!Term.info}. Unless specified explicitely in +the term's manual the following sections are automaticaly created and +populated for you: + +{ul +{- {{!Manpage.s_name}[NAME]} section.} +{- {{!Manpage.s_synopsis}[SYNOPSIS]} section.}} + +The various [doc] documentation strings specified by the term's +subterms and additional metadata get inserted at the end of the +documentation section name [docs] they respectively mention, in the +following order: + +{ol +{- Commands, see {!Term.info}.} +{- Positional arguments, see {!Arg.info}. Those are listed iff + both the [docv] and [doc] string is specified by {!Arg.info}.} +{- Optional arguments, see {!Arg.info}.} +{- Exit statuses, see {!Term.exit_info}.} +{- Environment variables, see {!Arg.env_var} and {!Term.env_info}.}} + +If a [docs] section name is mentioned and does not exist in the term's +manual, an empty section is created for it, after which the [doc] strings +are inserted, possibly prefixed by boilerplate text (e.g. for +{!Manpage.s_environment} and {!Manpage.s_exit_status}). + +If the created section is: +{ul +{- {{!Manpage.standard_sections}standard}, it + is inserted at the right place in the order specified + {{!Manpage.standard_sections}here}, but after a possible non-standard + section explicitely specified by the term since the latter get the + order number of the last previously specified standard section + or the order of {!Manpage.s_synopsis} if there is no such section.} +{- non-standard, it is inserted before the {!Manpage.s_commands} + section or the first subsequent existing standard section if it + doesn't exist. Taking advantage of this behaviour is discouraged, + you should declare manually your non standard section in the term's + manual.}} + +Ideally all manual strings should be UTF-8 encoded. However at the +moment macOS (until at least 10.12) is stuck with [groff 1.19.2] which +doesn't support `preconv(1)`. Regarding UTF-8 output, generating the +man page with [-Tutf8] maps the hyphen-minus [U+002D] to the minus +sign [U+2212] which makes it difficult to search it in the pager, so +[-Tascii] is used for now. Conclusion is that it is better to stick +to the ASCII set for now. Please contact the author if something seems +wrong in this reasoning or if you know a work around this. + +{2:misc Miscellaneous} + +{ul +{- The option name [--cmdliner] is reserved by the library.} +{- The option name [--help], (and [--version] if you specify a version + string) is reserved by the library. Using it as a term or option + name may result in undefined behaviour.} +{- Defining the same option or command name via two different + arguments or terms is illegal and raises [Invalid_argument].}} + +{1:cmdline Command line syntax} + +For programs evaluating a single term the most general form of invocation = is: + +{[ +prog [OPTION]... [ARG]... +]} + +The program automatically reponds to the [--help] option by printing +the help. If a version string is provided in the {{!Term.tinfo}term +information}, it also automatically responds to the [--version] option +by printing this string. + +Command line arguments are either {{!optargs}{e optional}} or +{{!posargs}{e positional}}. Both can be freely interleaved but since +[Cmdliner] accepts many optional forms this may result in +ambiguities. The special {{!posargs} token [--]} can be used to +resolve them. + +Programs evaluating multiple terms also add this form of invocation: + +{[ +prog COMMAND [OPTION]... [ARG]... +]} + +Commands automatically respond to the [--help] option by printing +their help. The [COMMAND] string must be the first string following +the program name and may be specified by a prefix as long as it is not +ambiguous. + +{2:optargs Optional arguments} + +An optional argument is specified on the command line by a {e name} +possibly followed by a {e value}. + +The name of an option can be short or long. + +{ul +{- A {e short} name is a dash followed by a single alphanumeric + character: ["-h"], ["-q"], ["-I"].} +{- A {e long} name is two dashes followed by alphanumeric + characters and dashes: ["--help"], ["--silent"], ["--ignore-case"].}} + +More than one name may refer to the same optional argument. For +example in a given program the names ["-q"], ["--quiet"] and +["--silent"] may all stand for the same boolean argument indicating +the program to be quiet. Long names can be specified by any non +ambiguous prefix. + +The value of an option can be specified in three different ways. + +{ul +{- As the next token on the command line: ["-o a.out"], ["--output a.out"]= .} +{- Glued to a short name: ["-oa.out"].} +{- Glued to a long name after an equal character: ["--output=3Da.out"].}} + +Glued forms are especially useful if the value itself starts with a +dash as is the case for negative numbers, ["--min=3D-10"]. + +An optional argument without a value is either a {e flag} (see +{!Arg.flag}, {!Arg.vflag}) or an optional argument with an optional +value (see the [~vopt] argument of {!Arg.opt}). + +Short flags can be grouped together to share a single dash and the +group can end with a short option. For example assuming ["-v"] and +["-x"] are flags and ["-f"] is a short option: + +{ul +{- ["-vx"] will be parsed as ["-v -x"].} +{- ["-vxfopt"] will be parsed as ["-v -x -fopt"].} +{- ["-vxf opt"] will be parsed as ["-v -x -fopt"].} +{- ["-fvx"] will be parsed as ["-f=3Dvx"].}} + +{2:posargs Positional arguments} + +Positional arguments are tokens on the command line that are not +option names and are not the value of an optional argument. They are +numbered from left to right starting with zero. + +Since positional arguments may be mistaken as the optional value of an +optional argument or they may need to look like option names, anything +that follows the special token ["--"] on the command line is +considered to be a positional argument. + +{2:envlookup Environment variables} + +Non-required command line arguments can be backed up by an environment +variable. If the argument is absent from the command line and that +the environment variable is defined, its value is parsed using the +argument converter and defines the value of the argument. + +For {!Arg.flag} and {!Arg.flag_all} that do not have an argument converter= a +boolean is parsed from the lowercased variable value as follows: + + +{ul +{- [""], ["false"], ["no"], ["n"] or ["0"] is [false].} +{- ["true"], ["yes"], ["y"] or ["1"] is [true].} +{- Any other string is an error.}} + +Note that environment variables are not supported for {!Arg.vflag} and +{!Arg.vflag_all}. + +{1:examples Examples} + +These examples are in the [test] directory of the distribution. + +{2:exrm A [rm] command} + +We define the command line interface of a [rm] command with the synopsis: + +{[ +rm [OPTION]... FILE... +]} + +The [-f], [-i] and [-I] flags define the prompt behaviour of [rm], +represented in our program by the [prompt] type. If more than one of +these flags is present on the command line the last one takes +precedence. + +To implement this behaviour we map the presence of these flags to +values of the [prompt] type by using {!Arg.vflag_all}. This argument +will contain all occurrences of the flag on the command line and we +just take the {!Arg.last} one to define our term value (if there's no +occurrence the last value of the default list [[Always]] is taken, +i.e. the default is [Always]). + +{[ +(* Implementation of the command, we just print the args. *) + +type prompt =3D Always | Once | Never +let prompt_str =3D function +| Always -> "always" | Once -> "once" | Never -> "never" + +let rm prompt recurse files =3D + Printf.printf "prompt =3D %s\nrecurse =3D %B\nfiles =3D %s\n" + (prompt_str prompt) recurse (String.concat ", " files) + +(* Command line interface *) + +open Cmdliner + +let files =3D Arg.(non_empty & pos_all file [] & info [] ~docv:"FILE") +let prompt =3D + let doc =3D "Prompt before every removal." in + let always =3D Always, Arg.info ["i"] ~doc in + let doc =3D "Ignore nonexistent files and never prompt." in + let never =3D Never, Arg.info ["f"; "force"] ~doc in + let doc =3D "Prompt once before removing more than three files, or when + removing recursively. Less intrusive than $(b,-i), while + still giving protection against most mistakes." + in + let once =3D Once, Arg.info ["I"] ~doc in + Arg.(last & vflag_all [Always] [always; never; once]) + +let recursive =3D + let doc =3D "Remove directories and their contents recursively." in + Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc) + +let cmd =3D + let doc =3D "remove files or directories" in + let man =3D [ + `S Manpage.s_description; + `P "$(tname) removes each specified $(i,FILE). By default it does not + remove directories, to also remove them and their contents, use the + option $(b,--recursive) ($(b,-r) or $(b,-R))."; + `P "To remove a file whose name starts with a `-', for example + `-foo', use one of these commands:"; + `P "rm -- -foo"; `Noblank; + `P "rm ./-foo"; + `P "$(tname) removes symbolic links, not the files referenced by the + links."; + `S Manpage.s_bugs; `P "Report bugs to ."; + `S Manpage.s_see_also; `P "$(b,rmdir)(1), $(b,unlink)(2)" ] + in + Term.(const rm $ prompt $ recursive $ files), + Term.info "rm" ~version:"%%VERSION%%" ~doc ~exits:Term.default_exits ~man + +let () =3D Term.(exit @@ eval cmd) +]} + +{2:excp A [cp] command} + +We define the command line interface of a [cp] command with the synopsis: +{[ +cp [OPTION]... SOURCE... DEST +]} + +The [DEST] argument must be a directory if there is more than one +[SOURCE]. This constraint is too complex to be expressed by the +combinators of {!Arg}. Hence we just give it the {!Arg.string} type +and verify the constraint at the beginning of the [cp] +implementation. If unsatisfied we return an [`Error] and by using +{!Term.ret} on the lifted result [cp_t] of [cp], [Cmdliner] handles +the error reporting. + +{[ +(* Implementation, we check the dest argument and print the args *) + +let cp verbose recurse force srcs dest =3D + if List.length srcs > 1 && + (not (Sys.file_exists dest) || not (Sys.is_directory dest)) + then + `Error (false, dest ^ " is not a directory") + else + `Ok (Printf.printf + "verbose =3D %B\nrecurse =3D %B\nforce =3D %B\nsrcs =3D %s\ndest =3D = %s\n" + verbose recurse force (String.concat ", " srcs) dest) + +(* Command line interface *) + +open Cmdliner + +let verbose =3D + let doc =3D "Print file names as they are copied." in + Arg.(value & flag & info ["v"; "verbose"] ~doc) + +let recurse =3D + let doc =3D "Copy directories recursively." in + Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc) + +let force =3D + let doc =3D "If a destination file cannot be opened, remove it and try a= gain."in + Arg.(value & flag & info ["f"; "force"] ~doc) + +let srcs =3D + let doc =3D "Source file(s) to copy." in + Arg.(non_empty & pos_left ~rev:true 0 file [] & info [] ~docv:"SOURCE" ~= doc) + +let dest =3D + let doc =3D "Destination of the copy. Must be a directory if there is mo= re + than one $(i,SOURCE)." in + Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv:"DEST" + ~doc) + +let cmd =3D + let doc =3D "copy files" in + let man_xrefs =3D + [ `Tool "mv"; `Tool "scp"; `Page (2, "umask"); `Page (7, "symlink") ] + in + let exits =3D Term.default_exits in + let man =3D + [ `S Manpage.s_bugs; + `P "Email them to ."; ] + in + Term.(ret (const cp $ verbose $ recurse $ force $ srcs $ dest)), + Term.info "cp" ~version:"%%VERSION%%" ~doc ~exits ~man ~man_xrefs + +let () =3D Term.(exit @@ eval cmd) +]} + +{2:extail A [tail] command} + +We define the command line interface of a [tail] command with the +synopsis: + +{[ +tail [OPTION]... [FILE]... +]} + +The [--lines] option whose value specifies the number of last lines to +print has a special syntax where a [+] prefix indicates to start +printing from that line number. In the program this is represented by +the [loc] type. We define a custom [loc] {{!Arg.argconv}argument +converter} for this option. + +The [--follow] option has an optional enumerated value. The argument +converter [follow], created with {!Arg.enum} parses the option value +into the enumeration. By using {!Arg.some} and the [~vopt] argument of +{!Arg.opt}, the term corresponding to the option [--follow] evaluates +to [None] if [--follow] is absent from the command line, to [Some +Descriptor] if present but without a value and to [Some v] if present +with a value [v] specified. + +{[ +(* Implementation of the command, we just print the args. *) + +type loc =3D bool * int +type verb =3D Verbose | Quiet +type follow =3D Name | Descriptor + +let str =3D Printf.sprintf +let opt_str sv =3D function None -> "None" | Some v -> str "Some(%s)" (sv = v) +let loc_str (rev, k) =3D if rev then str "%d" k else str "+%d" k +let follow_str =3D function Name -> "name" | Descriptor -> "descriptor" +let verb_str =3D function Verbose -> "verbose" | Quiet -> "quiet" + +let tail lines follow verb pid files =3D + Printf.printf "lines =3D %s\nfollow =3D %s\nverb =3D %s\npid =3D %s\nfil= es =3D %s\n" + (loc_str lines) (opt_str follow_str follow) (verb_str verb) + (opt_str string_of_int pid) (String.concat ", " files) + +(* Command line interface *) + +open Cmdliner + +let lines =3D + let loc =3D + let parse s =3D + try + if s <> "" && s.[0] <> '+' then Ok (true, int_of_string s) else + Ok (false, int_of_string (String.sub s 1 (String.length s - 1))) + with Failure _ -> Error (`Msg "unable to parse integer") + in + let print ppf p =3D Format.fprintf ppf "%s" (loc_str p) in + Arg.conv ~docv:"N" (parse, print) + in + Arg.(value & opt loc (true, 10) & info ["n"; "lines"] ~docv:"N" + ~doc:"Output the last $(docv) lines or use $(i,+)$(docv) to start + output after the $(i,N)-1th line.") + +let follow =3D + let doc =3D "Output appended data as the file grows. $(docv) specifies h= ow the + file should be tracked, by its `name' or by its `descriptor'.= " in + let follow =3D Arg.enum ["name", Name; "descriptor", Descriptor] in + Arg.(value & opt (some follow) ~vopt:(Some Descriptor) None & + info ["f"; "follow"] ~docv:"ID" ~doc) + +let verb =3D + let doc =3D "Never output headers giving file names." in + let quiet =3D Quiet, Arg.info ["q"; "quiet"; "silent"] ~doc in + let doc =3D "Always output headers giving file names." in + let verbose =3D Verbose, Arg.info ["v"; "verbose"] ~doc in + Arg.(last & vflag_all [Quiet] [quiet; verbose]) + +let pid =3D + let doc =3D "With -f, terminate after process $(docv) dies." in + Arg.(value & opt (some int) None & info ["pid"] ~docv:"PID" ~doc) + +let files =3D Arg.(value & (pos_all non_dir_file []) & info [] ~docv:"FILE= ") + +let cmd =3D + let doc =3D "display the last part of a file" in + let man =3D [ + `S Manpage.s_description; + `P "$(tname) prints the last lines of each $(i,FILE) to standard outpu= t. If + no file is specified reads standard input. The number of printed + lines can be specified with the $(b,-n) option."; + `S Manpage.s_bugs; + `P "Report them to ."; + `S Manpage.s_see_also; + `P "$(b,cat)(1), $(b,head)(1)" ] + in + Term.(const tail $ lines $ follow $ verb $ pid $ files), + Term.info "tail" ~version:"%=E2=80=8C%VERSION%%" ~doc ~exits:Term.defaul= t_exits ~man + +let () =3D Term.(exit @@ eval cmd) +]} + +{2:exdarcs A [darcs] command} + +We define the command line interface of a [darcs] command with the +synopsis: + +{[ +darcs [COMMAND] ... +]} + +The [--debug], [-q], [-v] and [--prehook] options are available in +each command. To avoid having to pass them individually to each +command we gather them in a record of type [copts]. By lifting the +record constructor [copts] into the term [copts_t] we now have a term +that we can pass to the commands to stand for an argument of type +[copts]. These options are documented in a section called [COMMON +OPTIONS], since we also want to put [--help] and [--version] in this +section, the term information of commands makes a judicious use of the +[sdocs] parameter of {!Term.info}. + +The [help] command shows help about commands or other topics. The help +shown for commands is generated by [Cmdliner] by making an appropriate +use of {!Term.ret} on the lifted [help] function. + +If the program is invoked without a command we just want to show the +help of the program as printed by [Cmdliner] with [--help]. This is +done by the [default_cmd] term. + +{[ +(* Implementations, just print the args. *) + +type verb =3D Normal | Quiet | Verbose +type copts =3D { debug : bool; verb : verb; prehook : string option } + +let str =3D Printf.sprintf +let opt_str sv =3D function None -> "None" | Some v -> str "Some(%s)" (sv = v) +let opt_str_str =3D opt_str (fun s -> s) +let verb_str =3D function + | Normal -> "normal" | Quiet -> "quiet" | Verbose -> "verbose" + +let pr_copts oc copts =3D Printf.fprintf oc + "debug =3D %B\nverbosity =3D %s\nprehook =3D %s\n" + copts.debug (verb_str copts.verb) (opt_str_str copts.prehook) + +let initialize copts repodir =3D Printf.printf + "%arepodir =3D %s\n" pr_copts copts repodir + +let record copts name email all ask_deps files =3D Printf.printf + "%aname =3D %s\nemail =3D %s\nall =3D %B\nask-deps =3D %B\nfiles =3D %= s\n" + pr_copts copts (opt_str_str name) (opt_str_str email) all ask_deps + (String.concat ", " files) + +let help copts man_format cmds topic =3D match topic with +| None -> `Help (`Pager, None) (* help about the program. *) +| Some topic -> + let topics =3D "topics" :: "patterns" :: "environment" :: cmds in + let conv, _ =3D Cmdliner.Arg.enum (List.rev_map (fun s -> (s, s)) topi= cs) in + match conv topic with + | `Error e -> `Error (false, e) + | `Ok t when t =3D "topics" -> List.iter print_endline topics; `Ok () + | `Ok t when List.mem t cmds -> `Help (man_format, Some t) + | `Ok t -> + let page =3D (topic, 7, "", "", ""), [`S topic; `P "Say something"= ;] in + `Ok (Cmdliner.Manpage.print man_format Format.std_formatter page) + +open Cmdliner + +(* Help sections common to all commands *) + +let help_secs =3D [ + `S Manpage.s_common_options; + `P "These options are common to all commands."; + `S "MORE HELP"; + `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command.";`No= blank; + `P "Use `$(mname) help patterns' for help on patch matching."; `Noblank; + `P "Use `$(mname) help environment' for help on environment variables."; + `S Manpage.s_bugs; `P "Check bug reports at http://bugs.example.org.";] + +(* Options common to all commands *) + +let copts debug verb prehook =3D { debug; verb; prehook } +let copts_t =3D + let docs =3D Manpage.s_common_options in + let debug =3D + let doc =3D "Give only debug output." in + Arg.(value & flag & info ["debug"] ~docs ~doc) + in + let verb =3D + let doc =3D "Suppress informational output." in + let quiet =3D Quiet, Arg.info ["q"; "quiet"] ~docs ~doc in + let doc =3D "Give verbose output." in + let verbose =3D Verbose, Arg.info ["v"; "verbose"] ~docs ~doc in + Arg.(last & vflag_all [Normal] [quiet; verbose]) + in + let prehook =3D + let doc =3D "Specify command to run before this $(mname) command." in + Arg.(value & opt (some string) None & info ["prehook"] ~docs ~doc) + in + Term.(const copts $ debug $ verb $ prehook) + +(* Commands *) + +let initialize_cmd =3D + let repodir =3D + let doc =3D "Run the program in repository directory $(docv)." in + Arg.(value & opt file Filename.current_dir_name & info ["repodir"] + ~docv:"DIR" ~doc) + in + let doc =3D "make the current directory a repository" in + let exits =3D Term.default_exits in + let man =3D [ + `S Manpage.s_description; + `P "Turns the current directory into a Darcs repository. Any + existing files and subdirectories become ..."; + `Blocks help_secs; ] + in + Term.(const initialize $ copts_t $ repodir), + Term.info "initialize" ~doc ~sdocs:Manpage.s_common_options ~exits ~man + +let record_cmd =3D + let pname =3D + let doc =3D "Name of the patch." in + Arg.(value & opt (some string) None & info ["m"; "patch-name"] ~docv:"= NAME" + ~doc) + in + let author =3D + let doc =3D "Specifies the author's identity." in + Arg.(value & opt (some string) None & info ["A"; "author"] ~docv:"EMAI= L" + ~doc) + in + let all =3D + let doc =3D "Answer yes to all patches." in + Arg.(value & flag & info ["a"; "all"] ~doc) + in + let ask_deps =3D + let doc =3D "Ask for extra dependencies." in + Arg.(value & flag & info ["ask-deps"] ~doc) + in + let files =3D Arg.(value & (pos_all file) [] & info [] ~docv:"FILE or DI= R") in + let doc =3D "create a patch from unrecorded changes" in + let exits =3D Term.default_exits in + let man =3D + [`S Manpage.s_description; + `P "Creates a patch from changes in the working tree. If you specify + a set of files ..."; + `Blocks help_secs; ] + in + Term.(const record $ copts_t $ pname $ author $ all $ ask_deps $ files), + Term.info "record" ~doc ~sdocs:Manpage.s_common_options ~exits ~man + +let help_cmd =3D + let topic =3D + let doc =3D "The topic to get help on. `topics' lists the topics." in + Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) + in + let doc =3D "display help about darcs and darcs commands" in + let man =3D + [`S Manpage.s_description; + `P "Prints help about darcs commands and other subjects..."; + `Blocks help_secs; ] + in + Term.(ret + (const help $ copts_t $ Arg.man_format $ Term.choice_names $topi= c)), + Term.info "help" ~doc ~exits:Term.default_exits ~man + +let default_cmd =3D + let doc =3D "a revision control system" in + let sdocs =3D Manpage.s_common_options in + let exits =3D Term.default_exits in + let man =3D help_secs in + Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)), + Term.info "darcs" ~version:"%%VERSION%%" ~doc ~sdocs ~exits ~man + +let cmds =3D [initialize_cmd; record_cmd; help_cmd] + +let () =3D Term.(exit @@ eval_choice default_cmd cmds) +]} +*) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner.mllib b/tools/ocam= l/duniverse/cmdliner/src/cmdliner.mllib new file mode 100644 index 0000000000..f1ec5a3ad4 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner.mllib @@ -0,0 +1,11 @@ +Cmdliner_suggest +Cmdliner_trie +Cmdliner_base +Cmdliner_manpage +Cmdliner_info +Cmdliner_docgen +Cmdliner_msg +Cmdliner_cline +Cmdliner_arg +Cmdliner_term +Cmdliner diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_arg.ml b/tools/oca= ml/duniverse/cmdliner/src/cmdliner_arg.ml new file mode 100644 index 0000000000..589f2eb4ad --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_arg.ml @@ -0,0 +1,356 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +let rev_compare n0 n1 =3D compare n1 n0 + +(* Invalid_argument strings **) + +let err_not_opt =3D "Option argument without name" +let err_not_pos =3D "Positional argument with a name" + +(* Documentation formatting helpers *) + +let strf =3D Printf.sprintf +let doc_quote =3D Cmdliner_base.quote +let doc_alts =3D Cmdliner_base.alts_str +let doc_alts_enum ?quoted enum =3D doc_alts ?quoted (List.map fst enum) + +let str_of_pp pp v =3D pp Format.str_formatter v; Format.flush_str_formatt= er () + +(* Argument converters *) + +type 'a parser =3D string -> [ `Ok of 'a | `Error of string ] +type 'a printer =3D Format.formatter -> 'a -> unit + +type 'a conv =3D 'a parser * 'a printer +type 'a converter =3D 'a conv + +let default_docv =3D "VALUE" +let conv ?docv (parse, print) =3D + let parse s =3D match parse s with Ok v -> `Ok v | Error (`Msg e) -> `Er= ror e in + parse, print + +let pconv ?docv conv =3D conv + +let conv_parser (parse, _) =3D + fun s -> match parse s with `Ok v -> Ok v | `Error e -> Error (`Msg e) + +let conv_printer (_, print) =3D print +let conv_docv _ =3D default_docv + +let err_invalid s kind =3D `Msg (strf "invalid value '%s', expected %s" s = kind) +let parser_of_kind_of_string ~kind k_of_string =3D + fun s -> match k_of_string s with + | None -> Error (err_invalid s kind) + | Some v -> Ok v + +let some =3D Cmdliner_base.some + +(* Argument information *) + +type env =3D Cmdliner_info.env +let env_var =3D Cmdliner_info.env + +type 'a t =3D 'a Cmdliner_term.t +type info =3D Cmdliner_info.arg +let info =3D Cmdliner_info.arg + +(* Arguments *) + +let ( & ) f x =3D f x + +let err e =3D Error (`Parse e) + +let parse_to_list parser s =3D match parser s with +| `Ok v -> `Ok [v] +| `Error _ as e -> e + +let try_env ei a parse ~absent =3D match Cmdliner_info.arg_env a with +| None -> Ok absent +| Some env -> + let var =3D Cmdliner_info.env_var env in + match Cmdliner_info.(eval_env_var ei var) with + | None -> Ok absent + | Some v -> + match parse v with + | `Ok v -> Ok v + | `Error e -> err (Cmdliner_msg.err_env_parse env ~err:e) + +let arg_to_args =3D Cmdliner_info.Args.singleton +let list_to_args f l =3D + let add acc v =3D Cmdliner_info.Args.add (f v) acc in + List.fold_left add Cmdliner_info.Args.empty l + +let flag a =3D + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else + let convert ei cl =3D match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a Cmdliner_base.env_bool_parse ~absent:false + | [_, _, None] -> Ok true + | [_, f, Some v] -> err (Cmdliner_msg.err_flag_value f v) + | (_, f, _) :: (_ ,g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated f g) + in + arg_to_args a, convert + +let flag_all a =3D + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else + let a =3D Cmdliner_info.arg_make_all_opts a in + let convert ei cl =3D match Cmdliner_cline.opt_arg cl a with + | [] -> + try_env ei a (parse_to_list Cmdliner_base.env_bool_parse) ~absent:[] + | l -> + try + let truth (_, f, v) =3D match v with + | None -> true + | Some v -> failwith (Cmdliner_msg.err_flag_value f v) + in + Ok (List.rev_map truth l) + with Failure e -> err e + in + arg_to_args a, convert + +let vflag v l =3D + let convert _ cl =3D + let rec aux fv =3D function + | (v, a) :: rest -> + begin match Cmdliner_cline.opt_arg cl a with + | [] -> aux fv rest + | [_, f, None] -> + begin match fv with + | None -> aux (Some (f, v)) rest + | Some (g, _) -> failwith (Cmdliner_msg.err_opt_repeated g f) + end + | [_, f, Some v] -> failwith (Cmdliner_msg.err_flag_value f v) + | (_, f, _) :: (_, g, _) :: _ -> + failwith (Cmdliner_msg.err_opt_repeated g f) + end + | [] -> match fv with None -> v | Some (_, v) -> v + in + try Ok (aux None l) with Failure e -> err e + in + let flag (_, a) =3D + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else a + in + list_to_args flag l, convert + +let vflag_all v l =3D + let convert _ cl =3D + let rec aux acc =3D function + | (fv, a) :: rest -> + begin match Cmdliner_cline.opt_arg cl a with + | [] -> aux acc rest + | l -> + let fval (k, f, v) =3D match v with + | None -> (k, fv) + | Some v -> failwith (Cmdliner_msg.err_flag_value f v) + in + aux (List.rev_append (List.rev_map fval l) acc) rest + end + | [] -> + if acc =3D [] then v else List.rev_map snd (List.sort rev_compare = acc) + in + try Ok (aux [] l) with Failure e -> err e + in + let flag (_, a) =3D + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else + Cmdliner_info.arg_make_all_opts a + in + list_to_args flag l, convert + +let parse_opt_value parse f v =3D match parse v with +| `Ok v -> v +| `Error e -> failwith (Cmdliner_msg.err_opt_parse f e) + +let opt ?vopt (parse, print) v a =3D + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else + let absent =3D Cmdliner_info.Val (lazy (str_of_pp print v)) in + let kind =3D match vopt with + | None -> Cmdliner_info.Opt + | Some dv -> Cmdliner_info.Opt_vopt (str_of_pp print dv) + in + let a =3D Cmdliner_info.arg_make_opt ~absent ~kind a in + let convert ei cl =3D match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a parse ~absent:v + | [_, f, Some v] -> + (try Ok (parse_opt_value parse f v) with Failure e -> err e) + | [_, f, None] -> + begin match vopt with + | None -> err (Cmdliner_msg.err_opt_value_missing f) + | Some optv -> Ok optv + end + | (_, f, _) :: (_, g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated g f) + in + arg_to_args a, convert + +let opt_all ?vopt (parse, print) v a =3D + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else + let absent =3D Cmdliner_info.Val (lazy "") in + let kind =3D match vopt with + | None -> Cmdliner_info.Opt + | Some dv -> Cmdliner_info.Opt_vopt (str_of_pp print dv) + in + let a =3D Cmdliner_info.arg_make_opt_all ~absent ~kind a in + let convert ei cl =3D match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a (parse_to_list parse) ~absent:v + | l -> + let parse (k, f, v) =3D match v with + | Some v -> (k, parse_opt_value parse f v) + | None -> match vopt with + | None -> failwith (Cmdliner_msg.err_opt_value_missing f) + | Some dv -> (k, dv) + in + try Ok (List.rev_map snd + (List.sort rev_compare (List.rev_map parse l))) with + | Failure e -> err e + in + arg_to_args a, convert + +(* Positional arguments *) + +let parse_pos_value parse a v =3D match parse v with +| `Ok v -> v +| `Error e -> failwith (Cmdliner_msg.err_pos_parse a e) + +let pos ?(rev =3D false) k (parse, print) v a =3D + if Cmdliner_info.arg_is_opt a then invalid_arg err_not_pos else + let absent =3D Cmdliner_info.Val (lazy (str_of_pp print v)) in + let pos =3D Cmdliner_info.pos ~rev ~start:k ~len:(Some 1) in + let a =3D Cmdliner_info.arg_make_pos_abs ~absent ~pos a in + let convert ei cl =3D match Cmdliner_cline.pos_arg cl a with + | [] -> try_env ei a parse ~absent:v + | [v] -> + (try Ok (parse_pos_value parse a v) with Failure e -> err e) + | _ -> assert false + in + arg_to_args a, convert + +let pos_list pos (parse, _) v a =3D + if Cmdliner_info.arg_is_opt a then invalid_arg err_not_pos else + let a =3D Cmdliner_info.arg_make_pos pos a in + let convert ei cl =3D match Cmdliner_cline.pos_arg cl a with + | [] -> try_env ei a (parse_to_list parse) ~absent:v + | l -> + try Ok (List.rev (List.rev_map (parse_pos_value parse a) l)) with + | Failure e -> err e + in + arg_to_args a, convert + +let all =3D Cmdliner_info.pos ~rev:false ~start:0 ~len:None +let pos_all c v a =3D pos_list all c v a + +let pos_left ?(rev =3D false) k =3D + let start =3D if rev then k + 1 else 0 in + let len =3D if rev then None else Some k in + pos_list (Cmdliner_info.pos ~rev ~start ~len) + +let pos_right ?(rev =3D false) k =3D + let start =3D if rev then 0 else k + 1 in + let len =3D if rev then Some k else None in + pos_list (Cmdliner_info.pos ~rev ~start ~len) + +(* Arguments as terms *) + +let absent_error args =3D + let make_req a acc =3D + let req_a =3D Cmdliner_info.arg_make_req a in + Cmdliner_info.Args.add req_a acc + in + Cmdliner_info.Args.fold make_req args Cmdliner_info.Args.empty + +let value a =3D a + +let err_arg_missing args =3D + err @@ Cmdliner_msg.err_arg_missing (Cmdliner_info.Args.choose args) + +let required (args, convert) =3D + let args =3D absent_error args in + let convert ei cl =3D match convert ei cl with + | Ok (Some v) -> Ok v + | Ok None -> err_arg_missing args + | Error _ as e -> e + in + args, convert + +let non_empty (al, convert) =3D + let args =3D absent_error al in + let convert ei cl =3D match convert ei cl with + | Ok [] -> err_arg_missing args + | Ok l -> Ok l + | Error _ as e -> e + in + args, convert + +let last (args, convert) =3D + let convert ei cl =3D match convert ei cl with + | Ok [] -> err_arg_missing args + | Ok l -> Ok (List.hd (List.rev l)) + | Error _ as e -> e + in + args, convert + +(* Predefined arguments *) + +let man_fmts =3D + ["auto", `Auto; "pager", `Pager; "groff", `Groff; "plain", `Plain] + +let man_fmt_docv =3D "FMT" +let man_fmts_enum =3D Cmdliner_base.enum man_fmts +let man_fmts_alts =3D doc_alts_enum man_fmts +let man_fmts_doc kind =3D + strf "Show %s in format $(docv). The value $(docv) must be %s. With `aut= o', + the format is `pager` or `plain' whenever the $(b,TERM) env var is + `dumb' or undefined." + kind man_fmts_alts + +let man_format =3D + let doc =3D man_fmts_doc "output" in + let docv =3D man_fmt_docv in + value & opt man_fmts_enum `Pager & info ["man-format"] ~docv ~doc + +let stdopt_version ~docs =3D + value & flag & info ["version"] ~docs ~doc:"Show version information." + +let stdopt_help ~docs =3D + let doc =3D man_fmts_doc "this help" in + let docv =3D man_fmt_docv in + value & opt ~vopt:(Some `Auto) (some man_fmts_enum) None & + info ["help"] ~docv ~docs ~doc + +(* Predefined converters. *) + +let bool =3D Cmdliner_base.bool +let char =3D Cmdliner_base.char +let int =3D Cmdliner_base.int +let nativeint =3D Cmdliner_base.nativeint +let int32 =3D Cmdliner_base.int32 +let int64 =3D Cmdliner_base.int64 +let float =3D Cmdliner_base.float +let string =3D Cmdliner_base.string +let enum =3D Cmdliner_base.enum +let file =3D Cmdliner_base.file +let dir =3D Cmdliner_base.dir +let non_dir_file =3D Cmdliner_base.non_dir_file +let list =3D Cmdliner_base.list +let array =3D Cmdliner_base.array +let pair =3D Cmdliner_base.pair +let t2 =3D Cmdliner_base.t2 +let t3 =3D Cmdliner_base.t3 +let t4 =3D Cmdliner_base.t4 + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_arg.mli b/tools/oc= aml/duniverse/cmdliner/src/cmdliner_arg.mli new file mode 100644 index 0000000000..725f923b8e --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_arg.mli @@ -0,0 +1,111 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** Command line arguments as terms. *) + +type 'a parser =3D string -> [ `Ok of 'a | `Error of string ] +type 'a printer =3D Format.formatter -> 'a -> unit +type 'a conv =3D 'a parser * 'a printer +type 'a converter =3D 'a conv + +val conv : + ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a printer -> + 'a conv + +val pconv : ?docv:string -> 'a parser * 'a printer -> 'a conv +val conv_parser : 'a conv -> (string -> ('a, [`Msg of string]) result) +val conv_printer : 'a conv -> 'a printer +val conv_docv : 'a conv -> string + +val parser_of_kind_of_string : + kind:string -> (string -> 'a option) -> + (string -> ('a, [`Msg of string]) result) + +val some : ?none:string -> 'a converter -> 'a option converter + +type env =3D Cmdliner_info.env +val env_var : ?docs:string -> ?doc:string -> string -> env + +type 'a t =3D 'a Cmdliner_term.t + +type info +val info : + ?docs:string -> ?docv:string -> ?doc:string -> ?env:env -> string list -= > info + +val ( & ) : ('a -> 'b) -> 'a -> 'b + +val flag : info -> bool t +val flag_all : info -> bool list t +val vflag : 'a -> ('a * info) list -> 'a t +val vflag_all : 'a list -> ('a * info) list -> 'a list t +val opt : ?vopt:'a -> 'a converter -> 'a -> info -> 'a t +val opt_all : ?vopt:'a -> 'a converter -> 'a list -> info -> 'a list t + +val pos : ?rev:bool -> int -> 'a converter -> 'a -> info -> 'a t +val pos_all : 'a converter -> 'a list -> info -> 'a list t +val pos_left : ?rev:bool -> int -> 'a converter -> 'a list -> info -> 'a l= ist t +val pos_right : ?rev:bool -> int -> 'a converter -> 'a list -> info -> 'a = list t + +(** {1 As terms} *) + +val value : 'a t -> 'a Cmdliner_term.t +val required : 'a option t -> 'a Cmdliner_term.t +val non_empty : 'a list t -> 'a list Cmdliner_term.t +val last : 'a list t -> 'a Cmdliner_term.t + +(** {1 Predefined arguments} *) + +val man_format : Cmdliner_manpage.format Cmdliner_term.t +val stdopt_version : docs:string -> bool Cmdliner_term.t +val stdopt_help : docs:string -> Cmdliner_manpage.format option Cmdliner_t= erm.t + +(** {1 Converters} *) + +val bool : bool converter +val char : char converter +val int : int converter +val nativeint : nativeint converter +val int32 : int32 converter +val int64 : int64 converter +val float : float converter +val string : string converter +val enum : (string * 'a) list -> 'a converter +val file : string converter +val dir : string converter +val non_dir_file : string converter +val list : ?sep:char -> 'a converter -> 'a list converter +val array : ?sep:char -> 'a converter -> 'a array converter +val pair : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter +val t2 : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter + +val t3 : + ?sep:char -> 'a converter ->'b converter -> 'c converter -> + ('a * 'b * 'c) converter + +val t4 : + ?sep:char -> 'a converter ->'b converter -> 'c converter -> 'd converter= -> + ('a * 'b * 'c * 'd) converter + +val doc_quote : string -> string +val doc_alts : ?quoted:bool -> string list -> string +val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string + + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_base.ml b/tools/oc= aml/duniverse/cmdliner/src/cmdliner_base.ml new file mode 100644 index 0000000000..24ad20c65f --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_base.ml @@ -0,0 +1,302 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(* Invalid argument strings *) + +let err_empty_list =3D "empty list" +let err_incomplete_enum =3D "Incomplete enumeration for the type" + +(* Formatting tools *) + +let strf =3D Printf.sprintf +let pp =3D Format.fprintf +let pp_sp =3D Format.pp_print_space +let pp_str =3D Format.pp_print_string +let pp_char =3D Format.pp_print_char +let pp_text =3D Format.pp_print_text +let pp_lines ppf s =3D + let rec stop_at sat ~start ~max s =3D + if start > max then start else + if sat s.[start] then start else + stop_at sat ~start:(start + 1) ~max s + in + let sub s start stop ~max =3D + if start =3D stop then "" else + if start =3D 0 && stop > max then s else + String.sub s start (stop - start) + in + let is_nl c =3D c =3D '\n' in + let max =3D String.length s - 1 in + let rec loop start s =3D match stop_at is_nl ~start ~max s with + | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~= max) + | stop -> + Format.pp_print_string ppf (sub s start stop ~max); + Format.pp_force_newline ppf (); + loop (stop + 1) s + in + loop 0 s + +let pp_tokens ~spaces ppf s =3D (* collapse white and hint spaces (maybe) = *) + let is_space =3D function ' ' | '\n' | '\r' | '\t' -> true | _ -> false = in + let i_max =3D String.length s - 1 in + let flush start stop =3D pp_str ppf (String.sub s start (stop - start + = 1)) in + let rec skip_white i =3D + if i > i_max then i else + if is_space s.[i] then skip_white (i + 1) else i + in + let rec loop start i =3D + if i > i_max then flush start i_max else + if not (is_space s.[i]) then loop start (i + 1) else + let next_start =3D skip_white i in + (flush start (i - 1); if spaces then pp_sp ppf () else pp_char ppf ' '; + if next_start > i_max then () else loop next_start next_start) + in + loop 0 0 + +(* Converter (end-user) error messages *) + +let quote s =3D strf "`%s'" s +let alts_str ?(quoted =3D true) alts =3D + let quote =3D if quoted then quote else (fun s -> s) in + match alts with + | [] -> invalid_arg err_empty_list + | [a] -> (quote a) + | [a; b] -> strf "either %s or %s" (quote a) (quote b) + | alts -> + let rev_alts =3D List.rev alts in + strf "one of %s or %s" + (String.concat ", " (List.rev_map quote (List.tl rev_alts))) + (quote (List.hd rev_alts)) + +let err_multi_def ~kind name doc v v' =3D + strf "%s %s defined twice (doc strings are '%s' and '%s')" + kind name (doc v) (doc v') + +let err_ambiguous ~kind s ~ambs =3D + strf "%s %s ambiguous and could be %s" kind (quote s) (alts_str ambs) + +let err_unknown ?(hints =3D []) ~kind v =3D + let did_you_mean s =3D strf ", did you mean %s ?" s in + let hints =3D match hints with [] -> "." | hs -> did_you_mean (alts_str = hs) in + strf "unknown %s %s%s" kind (quote v) hints + +let err_no kind s =3D strf "no %s %s" (quote s) kind +let err_not_dir s =3D strf "%s is not a directory" (quote s) +let err_is_dir s =3D strf "%s is a directory" (quote s) +let err_element kind s exp =3D + strf "invalid element in %s (`%s'): %s" kind s exp + +let err_invalid kind s exp =3D strf "invalid %s %s, %s" kind (quote s) exp +let err_invalid_val =3D err_invalid "value" +let err_sep_miss sep s =3D + err_invalid_val s (strf "missing a `%c' separator" sep) + +(* Converters *) + +type 'a parser =3D string -> [ `Ok of 'a | `Error of string ] +type 'a printer =3D Format.formatter -> 'a -> unit +type 'a conv =3D 'a parser * 'a printer + +let some ?(none =3D "") (parse, print) =3D + let parse s =3D match parse s with + | `Ok v -> `Ok (Some v) + | `Error _ as e -> e + in + let print ppf v =3D match v with + | None -> Format.pp_print_string ppf none + | Some v -> print ppf v + in + parse, print + +let bool =3D + let parse s =3D try `Ok (bool_of_string s) with + | Invalid_argument _ -> + `Error (err_invalid_val s (alts_str ["true"; "false"])) + in + parse, Format.pp_print_bool + +let char =3D + let parse s =3D match String.length s =3D 1 with + | true -> `Ok s.[0] + | false -> `Error (err_invalid_val s "expected a character") + in + parse, pp_char + +let parse_with t_of_str exp s =3D + try `Ok (t_of_str s) with Failure _ -> `Error (err_invalid_val s exp) + +let int =3D + parse_with int_of_string "expected an integer", Format.pp_print_int + +let int32 =3D + parse_with Int32.of_string "expected a 32-bit integer", + (fun ppf -> pp ppf "%ld") + +let int64 =3D + parse_with Int64.of_string "expected a 64-bit integer", + (fun ppf -> pp ppf "%Ld") + +let nativeint =3D + parse_with Nativeint.of_string "expected a processor-native integer", + (fun ppf -> pp ppf "%nd") + +let float =3D + parse_with float_of_string "expected a floating point number", + Format.pp_print_float + +let string =3D (fun s -> `Ok s), pp_str +let enum sl =3D + if sl =3D [] then invalid_arg err_empty_list else + let t =3D Cmdliner_trie.of_list sl in + let parse s =3D match Cmdliner_trie.find t s with + | `Ok _ as r -> r + | `Ambiguous -> + let ambs =3D List.sort compare (Cmdliner_trie.ambiguities t s) in + `Error (err_ambiguous "enum value" s ambs) + | `Not_found -> + let alts =3D List.rev (List.rev_map (fun (s, _) -> s) sl) in + `Error (err_invalid_val s ("expected " ^ (alts_str alts))) + in + let print ppf v =3D + let sl_inv =3D List.rev_map (fun (s,v) -> (v,s)) sl in + try pp_str ppf (List.assoc v sl_inv) + with Not_found -> invalid_arg err_incomplete_enum + in + parse, print + +let file =3D + let parse s =3D match Sys.file_exists s with + | true -> `Ok s + | false -> `Error (err_no "file or directory" s) + in + parse, pp_str + +let dir =3D + let parse s =3D match Sys.file_exists s with + | true -> if Sys.is_directory s then `Ok s else `Error (err_not_dir s) + | false -> `Error (err_no "directory" s) + in + parse, pp_str + +let non_dir_file =3D + let parse s =3D match Sys.file_exists s with + | true -> if not (Sys.is_directory s) then `Ok s else `Error (err_is_dir= s) + | false -> `Error (err_no "file" s) + in + parse, pp_str + +let split_and_parse sep parse s =3D (* raises [Failure] *) + let parse sub =3D match parse sub with + | `Error e -> failwith e | `Ok v -> v + in + let rec split accum j =3D + let i =3D try String.rindex_from s j sep with Not_found -> -1 in + if (i =3D -1) then + let p =3D String.sub s 0 (j + 1) in + if p <> "" then parse p :: accum else accum + else + let p =3D String.sub s (i + 1) (j - i) in + let accum' =3D if p <> "" then parse p :: accum else accum in + split accum' (i - 1) + in + split [] (String.length s - 1) + +let list ?(sep =3D ',') (parse, pp_e) =3D + let parse s =3D try `Ok (split_and_parse sep parse s) with + | Failure e -> `Error (err_element "list" s e) + in + let rec print ppf =3D function + | v :: l -> pp_e ppf v; if (l <> []) then (pp_char ppf sep; print ppf l) + | [] -> () + in + parse, print + +let array ?(sep =3D ',') (parse, pp_e) =3D + let parse s =3D try `Ok (Array.of_list (split_and_parse sep parse s)) wi= th + | Failure e -> `Error (err_element "array" s e) + in + let print ppf v =3D + let max =3D Array.length v - 1 in + for i =3D 0 to max do pp_e ppf v.(i); if i <> max then pp_char ppf sep= done + in + parse, print + +let split_left sep s =3D + try + let i =3D String.index s sep in + let len =3D String.length s in + Some ((String.sub s 0 i), (String.sub s (i + 1) (len - i - 1))) + with Not_found -> None + +let pair ?(sep =3D ',') (pa0, pr0) (pa1, pr1) =3D + let parser s =3D match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v0, v1) -> + match pa0 v0, pa1 v1 with + | `Ok v0, `Ok v1 -> `Ok (v0, v1) + | `Error e, _ | _, `Error e -> `Error (err_element "pair" s e) + in + let printer ppf (v0, v1) =3D pp ppf "%a%c%a" pr0 v0 sep pr1 v1 in + parser, printer + +let t2 =3D pair +let t3 ?(sep =3D ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) =3D + let parse s =3D match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v0, s) -> + match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v1, v2) -> + match pa0 v0, pa1 v1, pa2 v2 with + | `Ok v0, `Ok v1, `Ok v2 -> `Ok (v0, v1, v2) + | `Error e, _, _ | _, `Error e, _ | _, _, `Error e -> + `Error (err_element "triple" s e) + in + let print ppf (v0, v1, v2) =3D + pp ppf "%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 + in + parse, print + +let t4 ?(sep =3D ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) (pa3, pr3) =3D + let parse s =3D match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some(v0, s) -> + match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v1, s) -> + match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v2, v3) -> + match pa0 v0, pa1 v1, pa2 v2, pa3 v3 with + | `Ok v1, `Ok v2, `Ok v3, `Ok v4 -> `Ok (v1, v2, v3, v4) + | `Error e, _, _, _ | _, `Error e, _, _ | _, _, `Error e, _ + | _, _, _, `Error e -> `Error (err_element "quadruple" s e) + in + let print ppf (v0, v1, v2, v3) =3D + pp ppf "%a%c%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 sep pr3 v3 + in + parse, print + +let env_bool_parse s =3D match String.lowercase_ascii s with +| "" | "false" | "no" | "n" | "0" -> `Ok false +| "true" | "yes" | "y" | "1" -> `Ok true +| s -> `Error (err_invalid_val s (alts_str ["true"; "yes"; "false"; "no" ]= )) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_base.mli b/tools/o= caml/duniverse/cmdliner/src/cmdliner_base.mli new file mode 100644 index 0000000000..5c54ee01f3 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_base.mli @@ -0,0 +1,68 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** A few helpful base definitions. *) + +(** {1:fmt Formatting helpers} *) + +val pp_text : Format.formatter -> string -> unit +val pp_lines : Format.formatter -> string -> unit +val pp_tokens : spaces:bool -> Format.formatter -> string -> unit + +(** {1:err Error message helpers} *) + +val quote : string -> string +val alts_str : ?quoted:bool -> string list -> string +val err_ambiguous : kind:string -> string -> ambs:string list -> string +val err_unknown : ?hints:string list -> kind:string -> string -> string +val err_multi_def : + kind:string -> string -> ('b -> string) -> 'b -> 'b -> string + +(** {1:conv Textual OCaml value converters} *) + +type 'a parser =3D string -> [ `Ok of 'a | `Error of string ] +type 'a printer =3D Format.formatter -> 'a -> unit +type 'a conv =3D 'a parser * 'a printer + +val some : ?none:string -> 'a conv -> 'a option conv +val bool : bool conv +val char : char conv +val int : int conv +val nativeint : nativeint conv +val int32 : int32 conv +val int64 : int64 conv +val float : float conv +val string : string conv +val enum : (string * 'a) list -> 'a conv +val file : string conv +val dir : string conv +val non_dir_file : string conv +val list : ?sep:char -> 'a conv -> 'a list conv +val array : ?sep:char -> 'a conv -> 'a array conv +val pair : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv +val t2 : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv +val t3 : ?sep:char -> 'a conv ->'b conv -> 'c conv -> ('a * 'b * 'c) conv +val t4 : + ?sep:char -> 'a conv -> 'b conv -> 'c conv -> 'd conv -> + ('a * 'b * 'c * 'd) conv + +val env_bool_parse : bool parser + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_cline.ml b/tools/o= caml/duniverse/cmdliner/src/cmdliner_cline.ml new file mode 100644 index 0000000000..e305d398c2 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_cline.ml @@ -0,0 +1,199 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(* A command line stores pre-parsed information about the command + line's arguments in a more structured way. Given the + Cmdliner_info.arg values mentioned in a term and Sys.argv + (without exec name) we parse the command line into a map of + Cmdliner_info.arg values to [arg] values (see below). This map is used = by + the term's closures to retrieve and convert command line arguments + (see the Cmdliner_arg module). *) + +let err_multi_opt_name_def name a a' =3D + Cmdliner_base.err_multi_def + ~kind:"option name" name Cmdliner_info.arg_doc a a' + +module Amap =3D Map.Make (Cmdliner_info.Arg) + +type arg =3D (* unconverted argument data as found on the command lin= e. *) +| O of (int * string * (string option)) list (* (pos, name, value) of opt.= *) +| P of string list + +type t =3D arg Amap.t (* command line, maps arg_infos to arg value. *) + +let get_arg cl a =3D try Amap.find a cl with Not_found -> assert false +let opt_arg cl a =3D match get_arg cl a with O l -> l | _ -> assert false +let pos_arg cl a =3D match get_arg cl a with P l -> l | _ -> assert false +let actual_args cl a =3D match get_arg cl a with +| P args -> args +| O l -> + let extract_args (_pos, name, value) =3D + name :: (match value with None -> [] | Some v -> [v]) + in + List.concat (List.map extract_args l) + +let arg_info_indexes args =3D + (* from [args] returns a trie mapping the names of optional arguments to + their arg_info, a list with all arg_info for positional arguments and + a cmdline mapping each arg_info to an empty [arg]. *) + let rec loop optidx posidx cl =3D function + | [] -> optidx, posidx, cl + | a :: l -> + match Cmdliner_info.arg_is_pos a with + | true -> loop optidx (a :: posidx) (Amap.add a (P []) cl) l + | false -> + let add t name =3D match Cmdliner_trie.add t name a with + | `New t -> t + | `Replaced (a', _) -> invalid_arg (err_multi_opt_name_def name = a a') + in + let names =3D Cmdliner_info.arg_opt_names a in + let optidx =3D List.fold_left add optidx names in + loop optidx posidx (Amap.add a (O []) cl) l + in + loop Cmdliner_trie.empty [] Amap.empty (Cmdliner_info.Args.elements args) + +(* Optional argument parsing *) + +let is_opt s =3D String.length s > 1 && s.[0] =3D '-' +let is_short_opt s =3D String.length s =3D 2 && s.[0] =3D '-' + +let parse_opt_arg s =3D (* (name, value) of opt arg, assert len > 1. *) + let l =3D String.length s in + if s.[1] <> '-' then (* short opt *) + if l =3D 2 then s, None else + String.sub s 0 2, Some (String.sub s 2 (l - 2)) (* with glued opt arg = *) + else try (* long opt *) + let i =3D String.index s '=3D' in + String.sub s 0 i, Some (String.sub s (i + 1) (l - i - 1)) + with Not_found -> s, None + +let hint_matching_opt optidx s =3D + (* hint options that could match [s] in [optidx]. FIXME explain this is + a bit obscure. *) + if String.length s <=3D 2 then [] else + let short_opt, long_opt =3D + if s.[1] <> '-' + then s, Printf.sprintf "-%s" s + else String.sub s 1 (String.length s - 1), s + in + let short_opt, _ =3D parse_opt_arg short_opt in + let long_opt, _ =3D parse_opt_arg long_opt in + let all =3D Cmdliner_trie.ambiguities optidx "-" in + match List.mem short_opt all, Cmdliner_suggest.value long_opt all with + | false, [] -> [] + | false, l -> l + | true, [] -> [short_opt] + | true, l -> if List.mem short_opt l then l else short_opt :: l + +let parse_opt_args ~peek_opts optidx cl args =3D + (* returns an updated [cl] cmdline according to the options found in [ar= gs] + with the trie index [optidx]. Positional arguments are returned in or= der + in a list. *) + let rec loop errs k cl pargs =3D function + | [] -> List.rev errs, cl, List.rev pargs + | "--" :: args -> List.rev errs, cl, (List.rev_append pargs args) + | s :: args -> + if not (is_opt s) then loop errs (k + 1) cl (s :: pargs) args else + let name, value =3D parse_opt_arg s in + match Cmdliner_trie.find optidx name with + | `Ok a -> + let value, args =3D match value, Cmdliner_info.arg_opt_kind a wi= th + | Some v, Cmdliner_info.Flag when is_short_opt name -> + None, ("-" ^ v) :: args + | Some _, _ -> value, args + | None, Cmdliner_info.Flag -> value, args + | None, _ -> + match args with + | [] -> None, args + | v :: rest -> if is_opt v then None, args else Some v, rest + in + let arg =3D O ((k, name, value) :: opt_arg cl a) in + loop errs (k + 1) (Amap.add a arg cl) pargs args + | `Not_found when peek_opts -> loop errs (k + 1) cl pargs args + | `Not_found -> + let hints =3D hint_matching_opt optidx s in + let err =3D Cmdliner_base.err_unknown ~kind:"option" ~hints name= in + loop (err :: errs) (k + 1) cl pargs args + | `Ambiguous -> + let ambs =3D Cmdliner_trie.ambiguities optidx name in + let ambs =3D List.sort compare ambs in + let err =3D Cmdliner_base.err_ambiguous "option" name ambs in + loop (err :: errs) (k + 1) cl pargs args + in + let errs, cl, pargs =3D loop [] 0 cl [] args in + if errs =3D [] then Ok (cl, pargs) else + let err =3D String.concat "\n" errs in + Error (err, cl, pargs) + +let take_range start stop l =3D + let rec loop i acc =3D function + | [] -> List.rev acc + | v :: vs -> + if i < start then loop (i + 1) acc vs else + if i <=3D stop then loop (i + 1) (v :: acc) vs else + List.rev acc + in + loop 0 [] l + +let process_pos_args posidx cl pargs =3D + (* returns an updated [cl] cmdline in which each positional arg mentioned + in the list index posidx, is given a value according the list + of positional arguments values [pargs]. *) + if pargs =3D [] then + let misses =3D List.filter Cmdliner_info.arg_is_req posidx in + if misses =3D [] then Ok cl else + Error (Cmdliner_msg.err_pos_misses misses, cl) + else + let last =3D List.length pargs - 1 in + let pos rev k =3D if rev then last - k else k in + let rec loop misses cl max_spec =3D function + | [] -> misses, cl, max_spec + | a :: al -> + let apos =3D Cmdliner_info.arg_pos a in + let rev =3D Cmdliner_info.pos_rev apos in + let start =3D pos rev (Cmdliner_info.pos_start apos) in + let stop =3D match Cmdliner_info.pos_len apos with + | None -> pos rev last + | Some n -> pos rev (Cmdliner_info.pos_start apos + n - 1) + in + let start, stop =3D if rev then stop, start else start, stop in + let args =3D take_range start stop pargs in + let max_spec =3D max stop max_spec in + let cl =3D Amap.add a (P args) cl in + let misses =3D match Cmdliner_info.arg_is_req a && args =3D [] with + | true -> a :: misses + | false -> misses + in + loop misses cl max_spec al + in + let misses, cl, max_spec =3D loop [] cl (-1) posidx in + if misses <> [] then Error (Cmdliner_msg.err_pos_misses misses, cl) else + if last <=3D max_spec then Ok cl else + let excess =3D take_range (max_spec + 1) last pargs in + Error (Cmdliner_msg.err_pos_excess excess, cl) + +let create ?(peek_opts =3D false) al args =3D + let optidx, posidx, cl =3D arg_info_indexes al in + match parse_opt_args ~peek_opts optidx cl args with + | Ok (cl, _) when peek_opts -> Ok cl + | Ok (cl, pargs) -> process_pos_args posidx cl pargs + | Error (errs, cl, _) -> Error (errs, cl) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_cline.mli b/tools/= ocaml/duniverse/cmdliner/src/cmdliner_cline.mli new file mode 100644 index 0000000000..63dad28acc --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_cline.mli @@ -0,0 +1,34 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** Command lines. *) + +type t + +val create : + ?peek_opts:bool -> Cmdliner_info.args -> string list -> + (t, string * t) result + +val opt_arg : t -> Cmdliner_info.arg -> (int * string * (string option)) l= ist +val pos_arg : t -> Cmdliner_info.arg -> string list +val actual_args : t -> Cmdliner_info.arg -> string list +(** Actual command line arguments from the command line *) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_docgen.ml b/tools/= ocaml/duniverse/cmdliner/src/cmdliner_docgen.ml new file mode 100644 index 0000000000..054164f6d4 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_docgen.ml @@ -0,0 +1,352 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +let rev_compare n0 n1 =3D compare n1 n0 +let strf =3D Printf.sprintf + +let esc =3D Cmdliner_manpage.escape +let term_name t =3D esc @@ Cmdliner_info.term_name t + +let sorted_items_to_blocks ~boilerplate:b items =3D + (* Items are sorted by section and then rev. sorted by appearance. + We gather them by section in correct order in a `Block and prefix + them with optional boilerplate *) + let boilerplate =3D match b with None -> (fun _ -> None) | Some b -> b in + let mk_block sec acc =3D match boilerplate sec with + | None -> (sec, `Blocks acc) + | Some b -> (sec, `Blocks (b :: acc)) + in + let rec loop secs sec acc =3D function + | (sec', it) :: its when sec' =3D sec -> loop secs sec (it :: acc) its + | (sec', it) :: its -> loop (mk_block sec acc :: secs) sec' [it] its + | [] -> (mk_block sec acc) :: secs + in + match items with + | [] -> [] + | (sec, it) :: its -> loop [] sec [it] its + +(* Doc string variables substitutions. *) + +let env_info_subst ~subst e =3D function +| "env" -> Some (strf "$(b,%s)" @@ esc (Cmdliner_info.env_var e)) +| id -> subst id + +let exit_info_subst ~subst e =3D function +| "status" -> Some (strf "%d" (fst @@ Cmdliner_info.exit_statuses e)) +| "status_max" -> Some (strf "%d" (snd @@ Cmdliner_info.exit_statuses e)) +| id -> subst id + +let arg_info_subst ~subst a =3D function +| "docv" -> + Some (strf "$(i,%s)" @@ esc (Cmdliner_info.arg_docv a)) +| "opt" when Cmdliner_info.arg_is_opt a -> + Some (strf "$(b,%s)" @@ esc (Cmdliner_info.arg_opt_name_sample a)) +| "env" as id -> + begin match Cmdliner_info.arg_env a with + | Some e -> env_info_subst ~subst e id + | None -> subst id + end +| id -> subst id + +let term_info_subst ei =3D function +| "tname" -> Some (strf "$(b,%s)" @@ term_name (Cmdliner_info.eval_term ei= )) +| "mname" -> Some (strf "$(b,%s)" @@ term_name (Cmdliner_info.eval_main ei= )) +| _ -> None + +(* Command docs *) + +let invocation ?(sep =3D ' ') ei =3D match Cmdliner_info.eval_kind ei with +| `Simple | `Multiple_main -> term_name (Cmdliner_info.eval_main ei) +| `Multiple_sub -> + strf "%s%c%s" + Cmdliner_info.(term_name @@ eval_main ei) sep + Cmdliner_info.(term_name @@ eval_term ei) + +let plain_invocation ei =3D invocation ei +let invocation ?sep ei =3D esc @@ invocation ?sep ei + +let synopsis_pos_arg a =3D + let v =3D match Cmdliner_info.arg_docv a with "" -> "ARG" | v -> v in + let v =3D strf "$(i,%s)" (esc v) in + let v =3D (if Cmdliner_info.arg_is_req a then strf "%s" else strf "[%s]"= ) v in + match Cmdliner_info.(pos_len @@ arg_pos a) with + | None -> v ^ "..." + | Some 1 -> v + | Some n -> + let rec loop n acc =3D if n <=3D 0 then acc else loop (n - 1) (v :: = acc) in + String.concat " " (loop n []) + +let synopsis ei =3D match Cmdliner_info.eval_kind ei with +| `Multiple_main -> strf "$(b,%s) $(i,COMMAND) ..." @@ invocation ei +| `Simple | `Multiple_sub -> + let rev_cli_order (a0, _) (a1, _) =3D + Cmdliner_info.rev_arg_pos_cli_order a0 a1 + in + let add_pos a acc =3D match Cmdliner_info.arg_is_opt a with + | true -> acc + | false -> (a, synopsis_pos_arg a) :: acc + in + let args =3D Cmdliner_info.(term_args @@ eval_term ei) in + let pargs =3D Cmdliner_info.Args.fold add_pos args [] in + let pargs =3D List.sort rev_cli_order pargs in + let pargs =3D String.concat " " (List.rev_map snd pargs) in + strf "$(b,%s) [$(i,OPTION)]... %s" (invocation ei) pargs + +let cmd_docs ei =3D match Cmdliner_info.eval_kind ei with +| `Simple | `Multiple_sub -> [] +| `Multiple_main -> + let add_cmd acc t =3D + let cmd =3D strf "$(b,%s)" @@ term_name t in + (Cmdliner_info.term_docs t, `I (cmd, Cmdliner_info.term_doc t)) :: a= cc + in + let by_sec_by_rev_name (s0, `I (c0, _)) (s1, `I (c1, _)) =3D + let c =3D compare s0 s1 in + if c <> 0 then c else compare c1 c0 (* N.B. reverse *) + in + let cmds =3D List.fold_left add_cmd [] (Cmdliner_info.eval_choices ei)= in + let cmds =3D List.sort by_sec_by_rev_name cmds in + let cmds =3D (cmds :> (string * Cmdliner_manpage.block) list) in + sorted_items_to_blocks ~boilerplate:None cmds + +(* Argument docs *) + +let arg_man_item_label a =3D + if Cmdliner_info.arg_is_pos a + then strf "$(i,%s)" (esc @@ Cmdliner_info.arg_docv a) else + let fmt_name var =3D match Cmdliner_info.arg_opt_kind a with + | Cmdliner_info.Flag -> fun n -> strf "$(b,%s)" (esc n) + | Cmdliner_info.Opt -> + fun n -> + if String.length n > 2 + then strf "$(b,%s)=3D$(i,%s)" (esc n) (esc var) + else strf "$(b,%s) $(i,%s)" (esc n) (esc var) + | Cmdliner_info.Opt_vopt _ -> + fun n -> + if String.length n > 2 + then strf "$(b,%s)[=3D$(i,%s)]" (esc n) (esc var) + else strf "$(b,%s) [$(i,%s)]" (esc n) (esc var) + in + let var =3D match Cmdliner_info.arg_docv a with "" -> "VAL" | v -> v in + let names =3D List.sort compare (Cmdliner_info.arg_opt_names a) in + let s =3D String.concat ", " (List.rev_map (fmt_name var) names) in + s + +let arg_to_man_item ~errs ~subst ~buf a =3D + let or_env ~value a =3D match Cmdliner_info.arg_env a with + | None -> "" + | Some e -> + let value =3D if value then " or" else "absent " in + strf "%s $(b,%s) env" value (esc @@ Cmdliner_info.env_var e) + in + let absent =3D match Cmdliner_info.arg_absent a with + | Cmdliner_info.Err -> "required" + | Cmdliner_info.Val v -> + match Lazy.force v with + | "" -> strf "%s" (or_env ~value:false a) + | v -> strf "absent=3D%s%s" v (or_env ~value:true a) + in + let optvopt =3D match Cmdliner_info.arg_opt_kind a with + | Cmdliner_info.Opt_vopt v -> strf "default=3D%s" v + | _ -> "" + in + let argvdoc =3D match optvopt, absent with + | "", "" -> "" + | s, "" | "", s -> strf " (%s)" s + | s, s' -> strf " (%s) (%s)" s s' + in + let subst =3D arg_info_subst ~subst a in + let doc =3D Cmdliner_info.arg_doc a in + let doc =3D Cmdliner_manpage.subst_vars ~errs ~subst buf doc in + (Cmdliner_info.arg_docs a, `I (arg_man_item_label a ^ argvdoc, doc)) + +let arg_docs ~errs ~subst ~buf ei =3D + let by_sec_by_arg a0 a1 =3D + let c =3D compare (Cmdliner_info.arg_docs a0) (Cmdliner_info.arg_docs = a1) in + if c <> 0 then c else + match Cmdliner_info.arg_is_opt a0, Cmdliner_info.arg_is_opt a1 with + | true, true -> (* optional by name *) + let key names =3D + let k =3D List.hd (List.sort rev_compare names) in + let k =3D String.lowercase_ascii k in + if k.[1] =3D '-' then String.sub k 1 (String.length k - 1) else k + in + compare + (key @@ Cmdliner_info.arg_opt_names a0) + (key @@ Cmdliner_info.arg_opt_names a1) + | false, false -> (* positional by variable *) + compare + (String.lowercase_ascii @@ Cmdliner_info.arg_docv a0) + (String.lowercase_ascii @@ Cmdliner_info.arg_docv a1) + | true, false -> -1 (* positional first *) + | false, true -> 1 (* optional after *) + in + let keep_arg a acc =3D + if not Cmdliner_info.(arg_is_pos a && (arg_docv a =3D "" || arg_doc a = =3D "")) + then (a :: acc) else acc + in + let args =3D Cmdliner_info.(term_args @@ eval_term ei) in + let args =3D Cmdliner_info.Args.fold keep_arg args [] in + let args =3D List.sort by_sec_by_arg args in + let args =3D List.rev_map (arg_to_man_item ~errs ~subst ~buf) args in + sorted_items_to_blocks ~boilerplate:None args + +(* Exit statuses doc *) + +let exit_boilerplate sec =3D match sec =3D Cmdliner_manpage.s_exit_status = with +| false -> None +| true -> Some (Cmdliner_manpage.s_exit_status_intro) + +let exit_docs ~errs ~subst ~buf ~has_sexit ei =3D + let by_sec (s0, _) (s1, _) =3D compare s0 s1 in + let add_exit_item acc e =3D + let subst =3D exit_info_subst ~subst e in + let min, max =3D Cmdliner_info.exit_statuses e in + let doc =3D Cmdliner_info.exit_doc e in + let label =3D if min =3D max then strf "%d" min else strf "%d-%d" min = max in + let item =3D `I (label, Cmdliner_manpage.subst_vars ~errs ~subst buf d= oc) in + Cmdliner_info.(exit_docs e, item) :: acc + in + let exits =3D Cmdliner_info.(term_exits @@ eval_term ei) in + let exits =3D List.sort Cmdliner_info.exit_order exits in + let exits =3D List.fold_left add_exit_item [] exits in + let exits =3D List.stable_sort by_sec (* sort by section *) exits in + let boilerplate =3D if has_sexit then None else Some exit_boilerplate in + sorted_items_to_blocks ~boilerplate exits + +(* Environment doc *) + +let env_boilerplate sec =3D match sec =3D Cmdliner_manpage.s_environment w= ith +| false -> None +| true -> Some (Cmdliner_manpage.s_environment_intro) + +let env_docs ~errs ~subst ~buf ~has_senv ei =3D + let add_env_item ~subst (seen, envs as acc) e =3D + if Cmdliner_info.Envs.mem e seen then acc else + let seen =3D Cmdliner_info.Envs.add e seen in + let var =3D strf "$(b,%s)" @@ esc (Cmdliner_info.env_var e) in + let doc =3D Cmdliner_info.env_doc e in + let doc =3D Cmdliner_manpage.subst_vars ~errs ~subst buf doc in + let envs =3D (Cmdliner_info.env_docs e, `I (var, doc)) :: envs in + seen, envs + in + let add_arg_env a acc =3D match Cmdliner_info.arg_env a with + | None -> acc + | Some e -> add_env_item ~subst:(arg_info_subst ~subst a) acc e + in + let add_env acc e =3D add_env_item ~subst:(env_info_subst ~subst e) acc = e in + let by_sec_by_rev_name (s0, `I (v0, _)) (s1, `I (v1, _)) =3D + let c =3D compare s0 s1 in + if c <> 0 then c else compare v1 v0 (* N.B. reverse *) + in + (* Arg envs before term envs is important here: if the same is mentioned + both in an arg and in a term the substs of the arg are allowed. *) + let args =3D Cmdliner_info.(term_args @@ eval_term ei) in + let tenvs =3D Cmdliner_info.(term_envs @@ eval_term ei) in + let init =3D Cmdliner_info.Envs.empty, [] in + let acc =3D Cmdliner_info.Args.fold add_arg_env args init in + let _, envs =3D List.fold_left add_env acc tenvs in + let envs =3D List.sort by_sec_by_rev_name envs in + let envs =3D (envs :> (string * Cmdliner_manpage.block) list) in + let boilerplate =3D if has_senv then None else Some env_boilerplate in + sorted_items_to_blocks ~boilerplate envs + +(* xref doc *) + +let xref_docs ~errs ei =3D + let main =3D Cmdliner_info.(term_name @@ eval_main ei) in + let to_xref =3D function + | `Main -> main, 1 + | `Tool tool -> tool, 1 + | `Page (name, sec) -> name, sec + | `Cmd c -> + if Cmdliner_info.eval_has_choice ei c then strf "%s-%s" main c, 1 el= se + (Format.fprintf errs "xref %s: no such term name@." c; "doc-err", 0) + in + let xref_str (name, sec) =3D strf "%s(%d)" (esc name) sec in + let xrefs =3D Cmdliner_info.(term_man_xrefs @@ eval_term ei) in + let xrefs =3D List.fold_left (fun acc x -> to_xref x :: acc) [] xrefs in + let xrefs =3D List.(rev_map xref_str (sort rev_compare xrefs)) in + if xrefs =3D [] then [] else + [Cmdliner_manpage.s_see_also, `P (String.concat ", " xrefs)] + +(* Man page construction *) + +let ensure_s_name ei sm =3D + if Cmdliner_manpage.(smap_has_section sm s_name) then sm else + let tname =3D invocation ~sep:'-' ei in + let tdoc =3D Cmdliner_info.(term_doc @@ eval_term ei) in + let tagline =3D if tdoc =3D "" then "" else strf " - %s" tdoc in + let tagline =3D `P (strf "%s%s" tname tagline) in + Cmdliner_manpage.(smap_append_block sm ~sec:s_name tagline) + +let ensure_s_synopsis ei sm =3D + if Cmdliner_manpage.(smap_has_section sm ~sec:s_synopsis) then sm else + let synopsis =3D `P (synopsis ei) in + Cmdliner_manpage.(smap_append_block sm ~sec:s_synopsis synopsis) + +let insert_term_man_docs ~errs ei sm =3D + let buf =3D Buffer.create 200 in + let subst =3D term_info_subst ei in + let ins sm (s, b) =3D Cmdliner_manpage.smap_append_block sm s b in + let has_senv =3D Cmdliner_manpage.(smap_has_section sm s_environment) in + let has_sexit =3D Cmdliner_manpage.(smap_has_section sm s_exit_status) in + let sm =3D List.fold_left ins sm (cmd_docs ei) in + let sm =3D List.fold_left ins sm (arg_docs ~errs ~subst ~buf ei) in + let sm =3D List.fold_left ins sm (exit_docs ~errs ~subst ~buf ~has_sexit= ei)in + let sm =3D List.fold_left ins sm (env_docs ~errs ~subst ~buf ~has_senv e= i) in + let sm =3D List.fold_left ins sm (xref_docs ~errs ei) in + sm + +let text ~errs ei =3D + let man =3D Cmdliner_info.(term_man @@ eval_term ei) in + let sm =3D Cmdliner_manpage.smap_of_blocks man in + let sm =3D ensure_s_name ei sm in + let sm =3D ensure_s_synopsis ei sm in + let sm =3D insert_term_man_docs ei ~errs sm in + Cmdliner_manpage.smap_to_blocks sm + +let title ei =3D + let main =3D Cmdliner_info.eval_main ei in + let exec =3D String.capitalize_ascii (Cmdliner_info.term_name main) in + let name =3D String.uppercase_ascii (invocation ~sep:'-' ei) in + let center_header =3D esc @@ strf "%s Manual" exec in + let left_footer =3D + let version =3D match Cmdliner_info.term_version main with + | None -> "" | Some v -> " " ^ v + in + esc @@ strf "%s%s" exec version + in + name, 1, "", left_footer, center_header + +let man ~errs ei =3D title ei, text ~errs ei + +let pp_man ~errs fmt ppf ei =3D + Cmdliner_manpage.print + ~errs ~subst:(term_info_subst ei) fmt ppf (man ~errs ei) + +(* Plain synopsis for usage *) + +let pp_plain_synopsis ~errs ppf ei =3D + let buf =3D Buffer.create 100 in + let subst =3D term_info_subst ei in + let syn =3D Cmdliner_manpage.doc_to_plain ~errs ~subst buf (synopsis ei)= in + Format.fprintf ppf "@[%s@]" syn + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_docgen.mli b/tools= /ocaml/duniverse/cmdliner/src/cmdliner_docgen.mli new file mode 100644 index 0000000000..05fb6a9187 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_docgen.mli @@ -0,0 +1,30 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +val plain_invocation : Cmdliner_info.eval -> string + +val pp_man : + errs:Format.formatter -> Cmdliner_manpage.format -> Format.formatter -> + Cmdliner_info.eval -> unit + +val pp_plain_synopsis : + errs:Format.formatter -> Format.formatter -> Cmdliner_info.eval -> unit + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_info.ml b/tools/oc= aml/duniverse/cmdliner/src/cmdliner_info.ml new file mode 100644 index 0000000000..418dd4d972 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_info.ml @@ -0,0 +1,233 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + + +let new_id =3D (* thread-safe UIDs, Oo.id (object end) was used befo= re. *) + let c =3D ref 0 in + fun () -> + let id =3D !c in + incr c; if id > !c then assert false (* too many ids *) else id + +(* Environments *) + +type env =3D (* information about an environment varia= ble. *) + { env_id : int; (* unique id for the env va= r. *) + env_var : string; (* the variabl= e. *) + env_doc : string; (* hel= p. *) + env_docs : string; } (* title of help section where liste= d. *) + +let env + ?docs:(env_docs =3D Cmdliner_manpage.s_environment) + ?doc:(env_doc =3D "See option $(opt).") env_var =3D + { env_id =3D new_id (); env_var; env_doc; env_docs } + +let env_var e =3D e.env_var +let env_doc e =3D e.env_doc +let env_docs e =3D e.env_docs + + +module Env =3D struct + type t =3D env + let compare a0 a1 =3D (compare : int -> int -> int) a0.env_id a1.env_id +end + +module Envs =3D Set.Make (Env) +type envs =3D Envs.t + +(* Arguments *) + +type arg_absence =3D Err | Val of string Lazy.t +type opt_kind =3D Flag | Opt | Opt_vopt of string + +type pos_kind =3D (* information about a positional argum= ent. *) + { pos_rev : bool; (* if [true] positions are counted from the en= d. *) + pos_start : int; (* start positional argumen= t. *) + pos_len : int option } (* number of arguments or [None] if unbounde= d. *) + +let pos ~rev:pos_rev ~start:pos_start ~len:pos_len =3D + { pos_rev; pos_start; pos_len} + +let pos_rev p =3D p.pos_rev +let pos_start p =3D p.pos_start +let pos_len p =3D p.pos_len + +type arg =3D (* information about a command line argum= ent. *) + { id : int; (* unique id for the argumen= t. *) + absent : arg_absence; (* behaviour if absen= t. *) + env : env option; (* environment variabl= e. *) + doc : string; (* hel= p. *) + docv : string; (* variable name for the argument in hel= p. *) + docs : string; (* title of help section where liste= d. *) + pos : pos_kind; (* positional arg kin= d. *) + opt_kind : opt_kind; (* optional arg kin= d. *) + opt_names : string list; (* names (for opt args= ). *) + opt_all : bool; } (* repeatable (for opt args= ). *) + +let dumb_pos =3D pos ~rev:false ~start:(-1) ~len:None + +let arg ?docs ?(docv =3D "") ?(doc =3D "") ?env names =3D + let dash n =3D if String.length n =3D 1 then "-" ^ n else "--" ^ n in + let opt_names =3D List.map dash names in + let docs =3D match docs with + | Some s -> s + | None -> + match names with + | [] -> Cmdliner_manpage.s_arguments + | _ -> Cmdliner_manpage.s_options + in + { id =3D new_id (); absent =3D Val (lazy ""); env; doc; docv; docs; + pos =3D dumb_pos; opt_kind =3D Flag; opt_names; opt_all =3D false; } + +let arg_id a =3D a.id +let arg_absent a =3D a.absent +let arg_env a =3D a.env +let arg_doc a =3D a.doc +let arg_docv a =3D a.docv +let arg_docs a =3D a.docs +let arg_pos a =3D a.pos +let arg_opt_kind a =3D a.opt_kind +let arg_opt_names a =3D a.opt_names +let arg_opt_all a =3D a.opt_all +let arg_opt_name_sample a =3D + (* First long or short name (in that order) in the list; this + allows the client to control which name is shown *) + let rec find =3D function + | [] -> List.hd a.opt_names + | n :: ns -> if (String.length n) > 2 then n else find ns + in + find a.opt_names + +let arg_make_req a =3D { a with absent =3D Err } +let arg_make_all_opts a =3D { a with opt_all =3D true } +let arg_make_opt ~absent ~kind:opt_kind a =3D { a with absent; opt_kind } +let arg_make_opt_all ~absent ~kind:opt_kind a =3D + { a with absent; opt_kind; opt_all =3D true } + +let arg_make_pos ~pos a =3D { a with pos } +let arg_make_pos_abs ~absent ~pos a =3D { a with absent; pos } + +let arg_is_opt a =3D a.opt_names <> [] +let arg_is_pos a =3D a.opt_names =3D [] +let arg_is_req a =3D a.absent =3D Err + +let arg_pos_cli_order a0 a1 =3D (* best-effort order on the c= li. *) + let c =3D compare (a0.pos.pos_rev) (a1.pos.pos_rev) in + if c <> 0 then c else + if a0.pos.pos_rev + then compare a1.pos.pos_start a0.pos.pos_start + else compare a0.pos.pos_start a1.pos.pos_start + +let rev_arg_pos_cli_order a0 a1 =3D arg_pos_cli_order a1 a0 + +module Arg =3D struct + type t =3D arg + let compare a0 a1 =3D (compare : int -> int -> int) a0.id a1.id +end + +module Args =3D Set.Make (Arg) +type args =3D Args.t + +(* Exit info *) + +type exit =3D + { exit_statuses : int * int; + exit_doc : string; + exit_docs : string; } + +let exit + ?docs:(exit_docs =3D Cmdliner_manpage.s_exit_status) + ?doc:(exit_doc =3D "undocumented") ?max min =3D + let max =3D match max with None -> min | Some max -> max in + { exit_statuses =3D (min, max); exit_doc; exit_docs } + +let exit_statuses e =3D e.exit_statuses +let exit_doc e =3D e.exit_doc +let exit_docs e =3D e.exit_docs +let exit_order e0 e1 =3D compare e0.exit_statuses e1.exit_statuses + +(* Term info *) + +type term_info =3D + { term_name : string; (* name of the ter= m. *) + term_version : string option; (* version (for --version= ). *) + term_doc : string; (* one line description of ter= m. *) + term_docs : string; (* title of man section where listed (commands= ). *) + term_sdocs : string; (* standard options, title of section where liste= d. *) + term_exits : exit list; (* exit codes for the ter= m. *) + term_envs : env list; (* env vars that influence the ter= m. *) + term_man : Cmdliner_manpage.block list; (* man page tex= t. *) + term_man_xrefs : Cmdliner_manpage.xref list; } (* man cross-ref= s. *) + +type term =3D + { term_info : term_info; + term_args : args; } + +let term + ?args:(term_args =3D Args.empty) ?man_xrefs:(term_man_xrefs =3D []) + ?man:(term_man =3D []) ?envs:(term_envs =3D []) ?exits:(term_exits =3D= []) + ?sdocs:(term_sdocs =3D Cmdliner_manpage.s_options) + ?docs:(term_docs =3D "COMMANDS") ?doc:(term_doc =3D "") ?version:term_= version + term_name =3D + let term_info =3D + { term_name; term_version; term_doc; term_docs; term_sdocs; term_exits; + term_envs; term_man; term_man_xrefs } + in + { term_info; term_args } + +let term_name t =3D t.term_info.term_name +let term_version t =3D t.term_info.term_version +let term_doc t =3D t.term_info.term_doc +let term_docs t =3D t.term_info.term_docs +let term_stdopts_docs t =3D t.term_info.term_sdocs +let term_exits t =3D t.term_info.term_exits +let term_envs t =3D t.term_info.term_envs +let term_man t =3D t.term_info.term_man +let term_man_xrefs t =3D t.term_info.term_man_xrefs +let term_args t =3D t.term_args + +let term_add_args t args =3D + { t with term_args =3D Args.union args t.term_args } + +(* Eval info *) + +type eval =3D (* information about the evaluation cont= ext. *) + { term : term; (* term being evaluate= d. *) + main : term; (* main ter= m. *) + choices : term list; (* all term choice= s. *) + env : string -> string option } (* environment variable looku= p. *) + +let eval ~term ~main ~choices ~env =3D { term; main; choices; env } +let eval_term e =3D e.term +let eval_main e =3D e.main +let eval_choices e =3D e.choices +let eval_env_var e v =3D e.env v + +let eval_kind ei =3D + if ei.choices =3D [] then `Simple else + if (ei.term.term_info.term_name =3D=3D ei.main.term_info.term_name) + then `Multiple_main else `Multiple_sub + +let eval_with_term ei term =3D { ei with term } + +let eval_has_choice e cmd =3D + let is_cmd t =3D t.term_info.term_name =3D cmd in + List.exists is_cmd e.choices + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_info.mli b/tools/o= caml/duniverse/cmdliner/src/cmdliner_info.mli new file mode 100644 index 0000000000..7fa60cbca0 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_info.mli @@ -0,0 +1,140 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** Terms, argument, env vars information. + + The following types keep untyped information about arguments and + terms. This data is used to parse the command line, report errors + and format man pages. *) + +(** {1:env Environment variables} *) + +type env +val env : ?docs:string -> ?doc:string -> string -> env +val env_var : env -> string +val env_doc : env -> string +val env_docs : env -> string + +module Env : Set.OrderedType with type t =3D env +module Envs : Set.S with type elt =3D env +type envs =3D Envs.t + +(** {1:arg Arguments} *) + +type arg_absence =3D +| Err (** an error is reported. *) +| Val of string Lazy.t (** if <> "", takes the given default value. *) +(** The type for what happens if the argument is absent from the cli. *) + +type opt_kind =3D +| Flag (** without value, just a flag. *) +| Opt (** with required value. *) +| Opt_vopt of string (** with optional value, takes given default. *) +(** The type for optional argument kinds. *) + +type pos_kind +val pos : rev:bool -> start:int -> len:int option -> pos_kind +val pos_rev : pos_kind -> bool +val pos_start : pos_kind -> int +val pos_len : pos_kind -> int option + +type arg +val arg : + ?docs:string -> ?docv:string -> ?doc:string -> ?env:env -> + string list -> arg + +val arg_id : arg -> int +val arg_absent : arg -> arg_absence +val arg_env : arg -> env option +val arg_doc : arg -> string +val arg_docv : arg -> string +val arg_docs : arg -> string +val arg_opt_names : arg -> string list (* has dashes *) +val arg_opt_name_sample : arg -> string (* warning must be an opt arg *) +val arg_opt_kind : arg -> opt_kind +val arg_pos : arg -> pos_kind + +val arg_make_req : arg -> arg +val arg_make_all_opts : arg -> arg +val arg_make_opt : absent:arg_absence -> kind:opt_kind -> arg -> arg +val arg_make_opt_all : absent:arg_absence -> kind:opt_kind -> arg -> arg +val arg_make_pos : pos:pos_kind -> arg -> arg +val arg_make_pos_abs : absent:arg_absence -> pos:pos_kind -> arg -> arg + +val arg_is_opt : arg -> bool +val arg_is_pos : arg -> bool +val arg_is_req : arg -> bool + +val arg_pos_cli_order : arg -> arg -> int +val rev_arg_pos_cli_order : arg -> arg -> int + +module Arg : Set.OrderedType with type t =3D arg +module Args : Set.S with type elt =3D arg +type args =3D Args.t + +(** {1:exit Exit status} *) + +type exit +val exit : ?docs:string -> ?doc:string -> ?max:int -> int -> exit +val exit_statuses : exit -> int * int +val exit_doc : exit -> string +val exit_docs : exit -> string +val exit_order : exit -> exit -> int + +(** {1:term Term information} *) + +type term + +val term : + ?args:args -> ?man_xrefs:Cmdliner_manpage.xref list -> + ?man:Cmdliner_manpage.block list -> ?envs:env list -> ?exits:exit list -> + ?sdocs:string -> ?docs:string -> ?doc:string -> ?version:string -> + string -> term + +val term_name : term -> string +val term_version : term -> string option +val term_doc : term -> string +val term_docs : term -> string +val term_stdopts_docs : term -> string +val term_exits : term -> exit list +val term_envs : term -> env list +val term_man : term -> Cmdliner_manpage.block list +val term_man_xrefs : term -> Cmdliner_manpage.xref list +val term_args : term -> args + +val term_add_args : term -> args -> term + +(** {1:eval Evaluation information} *) + +type eval + +val eval : + term:term -> main:term -> choices:term list -> + env:(string -> string option) -> eval + +val eval_term : eval -> term +val eval_main : eval -> term +val eval_choices : eval -> term list +val eval_env_var : eval -> string -> string option +val eval_kind : eval -> [> `Multiple_main | `Multiple_sub | `Simple ] +val eval_with_term : eval -> term -> eval +val eval_has_choice : eval -> string -> bool + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_manpage.ml b/tools= /ocaml/duniverse/cmdliner/src/cmdliner_manpage.ml new file mode 100644 index 0000000000..2dbd1f6dd4 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_manpage.ml @@ -0,0 +1,502 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(* Manpages *) + +type block =3D + [ `S of string | `P of string | `Pre of string | `I of string * string + | `Noblank | `Blocks of block list ] + +type title =3D string * int * string * string * string + +type t =3D title * block list + +type xref =3D + [ `Main | `Cmd of string | `Tool of string | `Page of string * int ] + +(* Standard sections *) + +let s_name =3D "NAME" +let s_synopsis =3D "SYNOPSIS" +let s_description =3D "DESCRIPTION" +let s_commands =3D "COMMANDS" +let s_arguments =3D "ARGUMENTS" +let s_options =3D "OPTIONS" +let s_common_options =3D "COMMON OPTIONS" +let s_exit_status =3D "EXIT STATUS" +let s_exit_status_intro =3D + `P "$(tname) exits with the following status:" + +let s_environment =3D "ENVIRONMENT" +let s_environment_intro =3D + `P "These environment variables affect the execution of $(tname):" + +let s_files =3D "FILES" +let s_examples =3D "EXAMPLES" +let s_bugs =3D "BUGS" +let s_authors =3D "AUTHORS" +let s_see_also =3D "SEE ALSO" + +(* Section order *) + +let s_created =3D "" +let order =3D + [| s_name; s_synopsis; s_description; s_created; s_commands; + s_arguments; s_options; s_common_options; s_exit_status; + s_environment; s_files; s_examples; s_bugs; s_authors; s_see_also; |] + +let order_synopsis =3D 1 +let order_created =3D 3 + +let section_of_order i =3D order.(i) +let section_to_order ~on_unknown s =3D + let max =3D Array.length order - 1 in + let rec loop i =3D match i > max with + | true -> on_unknown + | false -> if order.(i) =3D s then i else loop (i + 1) + in + loop 0 + +(* Section maps + + Section maps, maps section names to their section order and reversed + content blocks (content is not reversed in `Block blocks). The sections + are listed in reversed order. Unknown sections get the order of the last + known section. *) + +type smap =3D (string * (int * block list)) list + +let smap_of_blocks bs =3D (* N.B. this flattens `Blocks, not t.r. *) + let rec loop s s_o rbs smap =3D function + | [] -> s, s_o, rbs, smap + | `S new_sec :: bs -> + let new_o =3D section_to_order ~on_unknown:s_o new_sec in + loop new_sec new_o [] ((s, (s_o, rbs)):: smap) bs + | `Blocks blist :: bs -> + let s, s_o, rbs, rmap =3D loop s s_o rbs smap blist (* not t.r. *) in + loop s s_o rbs rmap bs + | (`P _ | `Pre _ | `I _ | `Noblank as c) :: bs -> + loop s s_o (c :: rbs) smap bs + in + let first, (bs : block list) =3D match bs with + | `S s :: bs -> s, bs + | `Blocks (`S s :: blist) :: bs -> s, (`Blocks blist) :: bs + | _ -> "", bs + in + let first_o =3D section_to_order ~on_unknown:order_synopsis first in + let s, s_o, rc, smap =3D loop first first_o [] [] bs in + (s, (s_o, rc)) :: smap + +let smap_to_blocks smap =3D (* N.B. this leaves `Blocks content untouched.= *) + let rec loop acc smap s =3D function + | b :: rbs -> loop (b :: acc) smap s rbs + | [] -> + let acc =3D if s =3D "" then acc else `S s :: acc in + match smap with + | (s, (_, rbs)) :: smap -> loop acc smap s rbs + | [] -> acc + in + match smap with + | [] -> [] + | (s, (_, rbs)) :: smap -> loop [] smap s rbs + +let smap_has_section smap ~sec =3D List.exists (fun (s, _) -> sec =3D s) s= map +let smap_append_block smap ~sec b =3D + let o =3D section_to_order ~on_unknown:order_created sec in + let try_insert =3D + let rec loop max_lt_o left =3D function + | (s', (o, rbs)) :: right when s' =3D sec -> + Ok (List.rev_append ((sec, (o, b :: rbs)) :: left) right) + | (_, (o', _) as s) :: right -> + let max_lt_o =3D if o' < o then max o' max_lt_o else max_lt_o in + loop max_lt_o (s :: left) right + | [] -> + if max_lt_o <> -1 then Error max_lt_o else + Ok (List.rev ((sec, (o, [b])) :: left)) + in + loop (-1) [] smap + in + match try_insert with + | Ok smap -> smap + | Error insert_before -> + let rec loop left =3D function + | (s', (o', _)) :: _ as right when o' =3D insert_before -> + List.rev_append ((sec, (o, [b])) :: left) right + | s :: ss -> loop (s :: left) ss + | [] -> assert false + in + loop [] smap + +(* Formatting tools *) + +let strf =3D Printf.sprintf +let pf =3D Format.fprintf +let pp_str =3D Format.pp_print_string +let pp_char =3D Format.pp_print_char +let pp_indent ppf c =3D for i =3D 1 to c do pp_char ppf ' ' done +let pp_lines =3D Cmdliner_base.pp_lines +let pp_tokens =3D Cmdliner_base.pp_tokens + +(* Cmdliner markup handling *) + +let err e fmt =3D pf e ("cmdliner error: " ^^ fmt ^^ "@.") +let err_unescaped ~errs c s =3D err errs "unescaped %C in %S" c s +let err_malformed ~errs s =3D err errs "Malformed $(...) in %S" s +let err_unclosed ~errs s =3D err errs "Unclosed $(...) in %S" s +let err_undef ~errs id s =3D err errs "Undefined variable $(%s) in %S" id s +let err_illegal_esc ~errs c s =3D err errs "Illegal escape char %C in %S" = c s +let err_markup ~errs dir s =3D + err errs "Unknown cmdliner markup $(%c,...) in %S" dir s + +let is_markup_dir =3D function 'i' | 'b' -> true | _ -> false +let is_markup_esc =3D function '$' | '\\' | '(' | ')' -> true | _ -> false +let markup_need_esc =3D function '\\' | '$' -> true | _ -> false +let markup_text_need_esc =3D function '\\' | '$' | ')' -> true | _ -> false + +let escape s =3D (* escapes [s] from doc language. *) + let max_i =3D String.length s - 1 in + let rec escaped_len i l =3D + if i > max_i then l else + if markup_text_need_esc s.[i] then escaped_len (i + 1) (l + 2) else + escaped_len (i + 1) (l + 1) + in + let escaped_len =3D escaped_len 0 0 in + if escaped_len =3D String.length s then s else + let b =3D Bytes.create escaped_len in + let rec loop i k =3D + if i > max_i then Bytes.unsafe_to_string b else + let c =3D String.unsafe_get s i in + if not (markup_text_need_esc c) + then (Bytes.unsafe_set b k c; loop (i + 1) (k + 1)) + else (Bytes.unsafe_set b k '\\'; Bytes.unsafe_set b (k + 1) c; + loop (i + 1) (k + 2)) + in + loop 0 0 + +let subst_vars ~errs ~subst b s =3D + let max_i =3D String.length s - 1 in + let flush start stop =3D match start > max_i with + | true -> () + | false -> Buffer.add_substring b s start (stop - start + 1) + in + let skip_escape k start i =3D + if i > max_i then err_unescaped ~errs '\\' s else k start (i + 1) + in + let rec skip_markup k start i =3D + if i > max_i then (err_unclosed ~errs s; k start i) else + match s.[i] with + | '\\' -> skip_escape (skip_markup k) start (i + 1) + | ')' -> k start (i + 1) + | c -> skip_markup k start (i + 1) + in + let rec add_subst start i =3D + if i > max_i then (err_unclosed ~errs s; loop start i) else + if s.[i] <> ')' then add_subst start (i + 1) else + let id =3D String.sub s start (i - start) in + let next =3D i + 1 in + begin match subst id with + | None -> err_undef ~errs id s; Buffer.add_string b "undefined"; + | Some v -> Buffer.add_string b v + end; + loop next next + and loop start i =3D + if i > max_i then flush start max_i else + let next =3D i + 1 in + match s.[i] with + | '\\' -> skip_escape loop start next + | '$' -> + if next > max_i then err_unescaped ~errs '$' s else + begin match s.[next] with + | '(' -> + let min =3D next + 2 in + if min > max_i then (err_unclosed ~errs s; loop start next) el= se + begin match s.[min] with + | ',' -> skip_markup loop start (min + 1) + | _ -> + let start_id =3D next + 1 in + flush start (i - 1); add_subst start_id start_id + end + | _ -> err_unescaped ~errs '$' s; loop start next + end; + | c -> loop start next + in + (Buffer.clear b; loop 0 0; Buffer.contents b) + +let add_markup_esc ~errs k b s start next target_need_escape target_escape= =3D + let max_i =3D String.length s - 1 in + if next > max_i then err_unescaped ~errs '\\' s else + match s.[next] with + | c when not (is_markup_esc s.[next]) -> + err_illegal_esc ~errs c s; + k (next + 1) (next + 1) + | c -> + (if target_need_escape c then target_escape b c else Buffer.add_char= b c); + k (next + 1) (next + 1) + +let add_markup_text ~errs k b s start target_need_escape target_escape =3D + let max_i =3D String.length s - 1 in + let flush start stop =3D match start > max_i with + | true -> () + | false -> Buffer.add_substring b s start (stop - start + 1) + in + let rec loop start i =3D + if i > max_i then (err_unclosed ~errs s; flush start max_i) else + let next =3D i + 1 in + match s.[i] with + | '\\' -> (* unescape *) + flush start (i - 1); + add_markup_esc ~errs loop b s start next + target_need_escape target_escape + | ')' -> flush start (i - 1); k next next + | c when markup_text_need_esc c -> + err_unescaped ~errs c s; flush start (i - 1); loop next next + | c when target_need_escape c -> + flush start (i - 1); target_escape b c; loop next next + | c -> loop start next + in + loop start start + +(* Plain text output *) + +let markup_to_plain ~errs b s =3D + let max_i =3D String.length s - 1 in + let flush start stop =3D match start > max_i with + | true -> () + | false -> Buffer.add_substring b s start (stop - start + 1) + in + let need_escape _ =3D false in + let escape _ _ =3D assert false in + let rec loop start i =3D + if i > max_i then flush start max_i else + let next =3D i + 1 in + match s.[i] with + | '\\' -> + flush start (i - 1); + add_markup_esc ~errs loop b s start next need_escape escape + | '$' -> + if next > max_i then err_unescaped ~errs '$' s else + begin match s.[next] with + | '(' -> + let min =3D next + 2 in + if min > max_i then (err_unclosed ~errs s; loop start next) el= se + begin match s.[min] with + | ',' -> + let markup =3D s.[min - 1] in + if not (is_markup_dir markup) + then (err_markup ~errs markup s; loop start next) else + let start_data =3D min + 1 in + (flush start (i - 1); + add_markup_text ~errs loop b s start_data need_escape esc= ape) + | _ -> + err_malformed ~errs s; loop start next + end + | _ -> err_unescaped ~errs '$' s; loop start next + end + | c when markup_need_esc c -> + err_unescaped ~errs c s; flush start (i - 1); loop next next + | c -> loop start next + in + (Buffer.clear b; loop 0 0; Buffer.contents b) + +let doc_to_plain ~errs ~subst b s =3D + markup_to_plain ~errs b (subst_vars ~errs ~subst b s) + +let p_indent =3D 7 (* paragraph indentati= on. *) +let l_indent =3D 4 (* label indentati= on. *) + +let pp_plain_blocks ~errs subst ppf ts =3D + let b =3D Buffer.create 1024 in + let markup t =3D doc_to_plain ~errs b ~subst t in + let pp_tokens ppf t =3D pp_tokens ~spaces:true ppf t in + let rec loop =3D function + | [] -> () + | t :: ts -> + begin match t with + | `Noblank -> () + | `Blocks bs -> loop bs (* not T.R. *) + | `P s -> pf ppf "%a@[%a@]@," pp_indent p_indent pp_tokens (markup s) + | `S s -> pf ppf "@[%a@]" pp_tokens (markup s) + | `Pre s -> pf ppf "%a@[%a@]@," pp_indent p_indent pp_lines (markup = s) + | `I (label, s) -> + let label =3D markup label in + let s =3D markup s in + pf ppf "@[%a@[%a@]" pp_indent p_indent pp_tokens label; + if s =3D "" then pf ppf "@]@," else + let ll =3D String.length label in + begin match ll < l_indent with + | true -> + pf ppf "%a@[%a@]@]" pp_indent (l_indent - ll) pp_tokens s + | false -> + pf ppf "@\n%a@[%a@]@]" + pp_indent (p_indent + l_indent) pp_tokens s + end; + match ts with `I _ :: _ -> pf ppf "@," | _ -> () + end; + begin match ts with + | `Noblank :: ts -> loop ts + | ts -> Format.pp_print_cut ppf (); loop ts + end + in + loop ts + +let pp_plain_page ~errs subst ppf (_, text) =3D + pf ppf "@[%a@]" (pp_plain_blocks ~errs subst) text + +(* Groff output *) + +let markup_to_groff ~errs b s =3D + let max_i =3D String.length s - 1 in + let flush start stop =3D match start > max_i with + | true -> () + | false -> Buffer.add_substring b s start (stop - start + 1) + in + let need_escape =3D function '.' | '\'' | '-' | '\\' -> true | _ -> fals= e in + let escape b c =3D Printf.bprintf b "\\N'%d'" (Char.code c) in + let rec end_text start i =3D Buffer.add_string b "\\fR"; loop start i + and loop start i =3D + if i > max_i then flush start max_i else + let next =3D i + 1 in + match s.[i] with + | '\\' -> + flush start (i - 1); + add_markup_esc ~errs loop b s start next need_escape escape + | '$' -> + if next > max_i then err_unescaped ~errs '$' s else + begin match s.[next] with + | '(' -> + let min =3D next + 2 in + if min > max_i then (err_unclosed ~errs s; loop start next) el= se + begin match s.[min] with + | ',' -> + let start_data =3D min + 1 in + flush start (i - 1); + begin match s.[min - 1] with + | 'i' -> Buffer.add_string b "\\fI" + | 'b' -> Buffer.add_string b "\\fB" + | markup -> err_markup ~errs markup s + end; + add_markup_text ~errs end_text b s start_data need_escape = escape + | _ -> err_malformed ~errs s; loop start next + end + | _ -> err_unescaped ~errs '$' s; flush start (i - 1); loop next n= ext + end + | c when markup_need_esc c -> + err_unescaped ~errs c s; flush start (i - 1); loop next next + | c when need_escape c -> + flush start (i - 1); escape b c; loop next next + | c -> loop start next + in + (Buffer.clear b; loop 0 0; Buffer.contents b) + +let doc_to_groff ~errs ~subst b s =3D + markup_to_groff ~errs b (subst_vars ~errs ~subst b s) + +let pp_groff_blocks ~errs subst ppf text =3D + let buf =3D Buffer.create 1024 in + let markup t =3D doc_to_groff ~errs ~subst buf t in + let pp_tokens ppf t =3D pp_tokens ~spaces:false ppf t in + let rec pp_block =3D function + | `Blocks bs -> List.iter pp_block bs (* not T.R. *) + | `P s -> pf ppf "@\n.P@\n%a" pp_tokens (markup s) + | `Pre s -> pf ppf "@\n.P@\n.nf@\n%a@\n.fi" pp_lines (markup s) + | `S s -> pf ppf "@\n.SH %a" pp_tokens (markup s) + | `Noblank -> pf ppf "@\n.sp -1" + | `I (l, s) -> + pf ppf "@\n.TP 4@\n%a@\n%a" pp_tokens (markup l) pp_tokens (markup s) + in + List.iter pp_block text + +let pp_groff_page ~errs subst ppf ((n, s, a1, a2, a3), t) =3D + pf ppf ".\\\" Pipe this output to groff -Tutf8 | less@\n\ + .\\\"@\n\ + .mso an.tmac@\n\ + .TH \"%s\" %d \"%s\" \"%s\" \"%s\"@\n\ + .\\\" Disable hyphenation and ragged-right@\n\ + .nh@\n\ + .ad l\ + %a@?" + n s a1 a2 a3 (pp_groff_blocks ~errs subst) t + +(* Printing to a pager *) + +let pp_to_temp_file pp_v v =3D + try + let exec =3D Filename.basename Sys.argv.(0) in + let file, oc =3D Filename.open_temp_file exec "out" in + let ppf =3D Format.formatter_of_out_channel oc in + pp_v ppf v; Format.pp_print_flush ppf (); close_out oc; + at_exit (fun () -> try Sys.remove file with Sys_error e -> ()); + Some file + with Sys_error _ -> None + +let find_cmd cmds =3D + let test, null =3D match Sys.os_type with + | "Win32" -> "where", " NUL" + | _ -> "type", "/dev/null" + in + let cmd c =3D Sys.command (strf "%s %s 1>%s 2>%s" test c null null) =3D = 0 in + try Some (List.find cmd cmds) with Not_found -> None + +let pp_to_pager print ppf v =3D + let pager =3D + let cmds =3D ["less"; "more"] in + let cmds =3D try (Sys.getenv "PAGER") :: cmds with Not_found -> cmds in + let cmds =3D try (Sys.getenv "MANPAGER") :: cmds with Not_found -> cmd= s in + find_cmd cmds + in + match pager with + | None -> print `Plain ppf v + | Some pager -> + let cmd =3D match (find_cmd ["groff"; "nroff"]) with + | None -> + begin match pp_to_temp_file (print `Plain) v with + | None -> None + | Some f -> Some (strf "%s < %s" pager f) + end + | Some c -> + begin match pp_to_temp_file (print `Groff) v with + | None -> None + | Some f -> + (* TODO use -Tutf8, but annoyingly maps U+002D to U+2212. *) + let xroff =3D if c =3D "groff" then c ^ " -Tascii -P-c" else= c in + Some (strf "%s < %s | %s" xroff f pager) + end + in + match cmd with + | None -> print `Plain ppf v + | Some cmd -> if (Sys.command cmd) <> 0 then print `Plain ppf v + +(* Output *) + +type format =3D [ `Auto | `Pager | `Plain | `Groff ] + +let rec print + ?(errs =3D Format.err_formatter) + ?(subst =3D fun x -> None) fmt ppf page =3D + match fmt with + | `Pager -> pp_to_pager (print ~errs ~subst) ppf page + | `Plain -> pp_plain_page ~errs subst ppf page + | `Groff -> pp_groff_page ~errs subst ppf page + | `Auto -> + match try (Some (Sys.getenv "TERM")) with Not_found -> None with + | None | Some "dumb" -> print ~errs ~subst `Plain ppf page + | Some _ -> print ~errs ~subst `Pager ppf page + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_manpage.mli b/tool= s/ocaml/duniverse/cmdliner/src/cmdliner_manpage.mli new file mode 100644 index 0000000000..3bbbb53c68 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_manpage.mli @@ -0,0 +1,100 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** Manpages. + + See {!Cmdliner.Manpage}. *) + +type block =3D + [ `S of string | `P of string | `Pre of string | `I of string * string + | `Noblank | `Blocks of block list ] + +val escape : string -> string +(** [escape s] escapes [s] from the doc language. *) + +type title =3D string * int * string * string * string + +type t =3D title * block list + +type xref =3D + [ `Main | `Cmd of string | `Tool of string | `Page of string * int ] + +(** {1 Standard section names} *) + +val s_name : string +val s_synopsis : string +val s_description : string +val s_commands : string +val s_arguments : string +val s_options : string +val s_common_options : string +val s_exit_status : string +val s_environment : string +val s_files : string +val s_bugs : string +val s_examples : string +val s_authors : string +val s_see_also : string + +(** {1 Section maps} + + Used for handling the merging of metadata doc strings. *) + +type smap +val smap_of_blocks : block list -> smap +val smap_to_blocks : smap -> block list +val smap_has_section : smap -> sec:string -> bool +val smap_append_block : smap -> sec:string -> block -> smap +(** [smap_append_block smap sec b] appends [b] at the end of section + [sec] creating it at the right place if needed. *) + +(** {1 Content boilerplate} *) + +val s_exit_status_intro : block +val s_environment_intro : block + +(** {1 Output} *) + +type format =3D [ `Auto | `Pager | `Plain | `Groff ] +val print : + ?errs:Format.formatter -> ?subst:(string -> string option) -> format -> + Format.formatter -> t -> unit + +(** {1 Printers and escapes used by Cmdliner module} *) + +val subst_vars : + errs:Format.formatter -> subst:(string -> string option) -> Buffer.t -> + string -> string +(** [subst b ~subst s], using [b], substitutes in [s] variables of the form + "$(doc)" by their [subst] definition. This leaves escapes and markup + directives $(markup,...) intact. + + @raise Invalid_argument in case of illegal syntax. *) + +val doc_to_plain : + errs:Format.formatter -> subst:(string -> string option) -> Buffer.t -> + string -> string +(** [doc_to_plain b ~subst s] using [b], subsitutes in [s] variables by + their [subst] definition and renders cmdliner directives to plain + text. + + @raise Invalid_argument in case of illegal syntax. *) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_msg.ml b/tools/oca= ml/duniverse/cmdliner/src/cmdliner_msg.ml new file mode 100644 index 0000000000..e26599b8a1 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_msg.ml @@ -0,0 +1,116 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +let strf =3D Printf.sprintf +let quote =3D Cmdliner_base.quote + +let pp =3D Format.fprintf +let pp_text =3D Cmdliner_base.pp_text +let pp_lines =3D Cmdliner_base.pp_lines + +(* Environment variable errors *) + +let err_env_parse env ~err =3D + let var =3D Cmdliner_info.env_var env in + strf "environment variable %s: %s" (quote var) err + +(* Positional argument errors *) + +let err_pos_excess excess =3D + strf "too many arguments, don't know what to do with %s" + (String.concat ", " (List.map quote excess)) + +let err_pos_miss a =3D match Cmdliner_info.arg_docv a with +| "" -> "a required argument is missing" +| v -> strf "required argument %s is missing" v + +let err_pos_misses =3D function +| [] -> assert false +| [a] -> err_pos_miss a +| args -> + let add_arg acc a =3D match Cmdliner_info.arg_docv a with + | "" -> "ARG" :: acc + | argv -> argv :: acc + in + let rev_args =3D List.sort Cmdliner_info.rev_arg_pos_cli_order args in + let args =3D List.fold_left add_arg [] rev_args in + let args =3D String.concat ", " args in + strf "required arguments %s are missing" args + +let err_pos_parse a ~err =3D match Cmdliner_info.arg_docv a with +| "" -> err +| argv -> + match Cmdliner_info.(pos_len @@ arg_pos a) with + | Some 1 -> strf "%s argument: %s" argv err + | None | Some _ -> strf "%s... arguments: %s" argv err + +(* Optional argument errors *) + +let err_flag_value flag v =3D + strf "option %s is a flag, it cannot take the argument %s" + (quote flag) (quote v) + +let err_opt_value_missing f =3D strf "option %s needs an argument" (quote = f) +let err_opt_parse f ~err =3D strf "option %s: %s" (quote f) err +let err_opt_repeated f f' =3D + if f =3D f' then strf "option %s cannot be repeated" (quote f) else + strf "options %s and %s cannot be present at the same time" + (quote f) (quote f') + +(* Argument errors *) + +let err_arg_missing a =3D + if Cmdliner_info.arg_is_pos a then err_pos_miss a else + strf "required option %s is missing" (Cmdliner_info.arg_opt_name_sample = a) + +(* Other messages *) + +let exec_name ei =3D Cmdliner_info.(term_name @@ eval_main ei) + +let pp_version ppf ei =3D match Cmdliner_info.(term_version @@ eval_main e= i) with +| None -> assert false +| Some v -> pp ppf "@[%a@]@." Cmdliner_base.pp_text v + +let pp_try_help ppf ei =3D match Cmdliner_info.eval_kind ei with +| `Simple | `Multiple_main -> + pp ppf "@[<2>Try `%s --help' for more information.@]" (exec_name ei) +| `Multiple_sub -> + let exec_cmd =3D Cmdliner_docgen.plain_invocation ei in + pp ppf "@[<2>Try `%s --help' or `%s --help' for more information.@]" + exec_cmd (exec_name ei) + +let pp_err ppf ei ~err =3D pp ppf "%s: @[%a@]@." (exec_name ei) pp_lines e= rr + +let pp_err_usage ppf ei ~err_lines ~err =3D + let pp_err =3D if err_lines then pp_lines else pp_text in + pp ppf "@[%s: @[%a@]@,@[Usage: @[%a@]@]@,%a@]@." + (exec_name ei) pp_err err (Cmdliner_docgen.pp_plain_synopsis ~errs:ppf= ) ei + pp_try_help ei + +let pp_backtrace ppf ei e bt =3D + let bt =3D Printexc.raw_backtrace_to_string bt in + let bt =3D + let len =3D String.length bt in + if len > 0 then String.sub bt 0 (len - 1) (* remove final '\n' *) else= bt + in + pp ppf "%s: @[internal error, uncaught exception:@\n%a@]@." + (exec_name ei) pp_lines (strf "%s\n%s" (Printexc.to_string e) bt) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_msg.mli b/tools/oc= aml/duniverse/cmdliner/src/cmdliner_msg.mli new file mode 100644 index 0000000000..9c69d50ec1 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_msg.mli @@ -0,0 +1,56 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** Messages for the end-user. *) + +(** {1:env_err Environment variable errors} *) + +val err_env_parse : Cmdliner_info.env -> err:string -> string + +(** {1:pos_err Positional argument errors} *) + +val err_pos_excess : string list -> string +val err_pos_misses : Cmdliner_info.arg list -> string +val err_pos_parse : Cmdliner_info.arg -> err:string -> string + +(** {1:opt_err Optional argument errors} *) + +val err_flag_value : string -> string -> string +val err_opt_value_missing : string -> string +val err_opt_parse : string -> err:string -> string +val err_opt_repeated : string -> string -> string + +(** {1:arg_err Argument errors} *) + +val err_arg_missing : Cmdliner_info.arg -> string + +(** {1:msgs Other messages} *) + +val pp_version : Format.formatter -> Cmdliner_info.eval -> unit +val pp_try_help : Format.formatter -> Cmdliner_info.eval -> unit +val pp_err : Format.formatter -> Cmdliner_info.eval -> err:string -> unit +val pp_err_usage : + Format.formatter -> Cmdliner_info.eval -> err_lines:bool -> err:string -= > unit + +val pp_backtrace : + Format.formatter -> + Cmdliner_info.eval -> exn -> Printexc.raw_backtrace -> unit + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_suggest.ml b/tools= /ocaml/duniverse/cmdliner/src/cmdliner_suggest.ml new file mode 100644 index 0000000000..d333604eae --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_suggest.ml @@ -0,0 +1,54 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +let levenshtein_distance s t =3D + (* As found here http://rosettacode.org/wiki/Levenshtein_distance#OCaml = *) + let minimum a b c =3D min a (min b c) in + let m =3D String.length s in + let n =3D String.length t in + (* for all i and j, d.(i).(j) will hold the Levenshtein distance between + the first i characters of s and the first j characters of t *) + let d =3D Array.make_matrix (m+1) (n+1) 0 in + for i =3D 0 to m do d.(i).(0) <- i done; + for j =3D 0 to n do d.(0).(j) <- j done; + for j =3D 1 to n do + for i =3D 1 to m do + if s.[i-1] =3D t.[j-1] then + d.(i).(j) <- d.(i-1).(j-1) (* no operation required *) + else + d.(i).(j) <- minimum + (d.(i-1).(j) + 1) (* a deletion *) + (d.(i).(j-1) + 1) (* an insertion *) + (d.(i-1).(j-1) + 1) (* a substitution *) + done; + done; + d.(m).(n) + +let value s candidates =3D + let add (min, acc) name =3D + let d =3D levenshtein_distance s name in + if d =3D min then min, (name :: acc) else + if d < min then d, [name] else + min, acc + in + let dist, suggs =3D List.fold_left add (max_int, []) candidates in + if dist < 3 (* suggest only if not too far *) then suggs else [] + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_suggest.mli b/tool= s/ocaml/duniverse/cmdliner/src/cmdliner_suggest.mli new file mode 100644 index 0000000000..70fa815661 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_suggest.mli @@ -0,0 +1,25 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +val value : string -> string list -> string list +(** [value near candidates] suggests values from [candidates] + not to far from near. *) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_term.ml b/tools/oc= aml/duniverse/cmdliner/src/cmdliner_term.ml new file mode 100644 index 0000000000..2e405bacf5 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_term.ml @@ -0,0 +1,41 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +type term_escape =3D + [ `Error of bool * string + | `Help of Cmdliner_manpage.format * string option ] + +type 'a parser =3D + Cmdliner_info.eval -> Cmdliner_cline.t -> + ('a, [ `Parse of string | term_escape ]) result + +type 'a t =3D Cmdliner_info.args * 'a parser + +let const v =3D Cmdliner_info.Args.empty, (fun _ _ -> Ok v) +let app (args_f, f) (args_v, v) =3D + Cmdliner_info.Args.union args_f args_v, + fun ei cl -> match (f ei cl) with + | Error _ as e -> e + | Ok f -> + match v ei cl with + | Error _ as e -> e + | Ok v -> Ok (f v) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_term.mli b/tools/o= caml/duniverse/cmdliner/src/cmdliner_term.mli new file mode 100644 index 0000000000..e9472f75aa --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_term.mli @@ -0,0 +1,40 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** Terms *) + +type term_escape =3D + [ `Error of bool * string + | `Help of Cmdliner_manpage.format * string option ] + +type 'a parser =3D + Cmdliner_info.eval -> Cmdliner_cline.t -> + ('a, [ `Parse of string | term_escape ]) result +(** Type type for command line parser. given static information about + the command line and a command line to parse returns an OCaml value. *) + +type 'a t =3D Cmdliner_info.args * 'a parser +(** The type for terms. The list of arguments it can parse and the parsing + function that does so. *) + +val const : 'a -> 'a t +val app : ('a -> 'b) t -> 'a t -> 'b t + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_trie.ml b/tools/oc= aml/duniverse/cmdliner/src/cmdliner_trie.ml new file mode 100644 index 0000000000..0aaf53f38b --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_trie.ml @@ -0,0 +1,97 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +module Cmap =3D Map.Make (Char) (* character map= s. *) + +type 'a value =3D (* type for holding a bound valu= e. *) +| Pre of 'a (* value is bound by the prefix of a key. *) +| Key of 'a (* value is bound by an entire key. *) +| Amb (* no value bound because of ambiguous prefix. *) +| Nil (* not bound (only for the empty trie). *) + +type 'a t =3D { v : 'a value; succs : 'a t Cmap.t } +let empty =3D { v =3D Nil; succs =3D Cmap.empty } +let is_empty t =3D t =3D empty + +(* N.B. If we replace a non-ambiguous key, it becomes ambiguous but it's + not important for our use. Also the following is not tail recursive but + the stack is bounded by key length. *) +let add t k d =3D + let rec loop t k len i d pre_d =3D match i =3D len with + | true -> + let t' =3D { v =3D Key d; succs =3D t.succs } in + begin match t.v with + | Key old -> `Replaced (old, t') + | _ -> `New t' + end + | false -> + let v =3D match t.v with + | Amb | Pre _ -> Amb | Key _ as v -> v | Nil -> pre_d + in + let t' =3D try Cmap.find k.[i] t.succs with Not_found -> empty in + match loop t' k len (i + 1) d pre_d with + | `New n -> `New { v; succs =3D Cmap.add k.[i] n t.succs } + | `Replaced (o, n) -> + `Replaced (o, { v; succs =3D Cmap.add k.[i] n t.succs }) + in + loop t k (String.length k) 0 d (Pre d (* allocate less *)) + +let find_node t k =3D + let rec aux t k len i =3D + if i =3D len then t else + aux (Cmap.find k.[i] t.succs) k len (i + 1) + in + aux t k (String.length k) 0 + +let find t k =3D + try match (find_node t k).v with + | Key v | Pre v -> `Ok v | Amb -> `Ambiguous | Nil -> `Not_found + with Not_found -> `Not_found + +let ambiguities t p =3D (* ambiguities of [p] in [t= ]. *) + try + let t =3D find_node t p in + match t.v with + | Key _ | Pre _ | Nil -> [] + | Amb -> + let add_char s c =3D s ^ (String.make 1 c) in + let rem_char s =3D String.sub s 0 ((String.length s) - 1) in + let to_list m =3D Cmap.fold (fun k t acc -> (k,t) :: acc) m [] in + let rec aux acc p =3D function + | ((c, t) :: succs) :: rest -> + let p' =3D add_char p c in + let acc' =3D match t.v with + | Pre _ | Amb -> acc + | Key _ -> (p' :: acc) + | Nil -> assert false + in + aux acc' p' ((to_list t.succs) :: succs :: rest) + | [] :: [] -> acc + | [] :: rest -> aux acc (rem_char p) rest + | [] -> assert false + in + aux [] p (to_list t.succs :: []) + with Not_found -> [] + +let of_list l =3D + let add t (s, v) =3D match add t s v with `New t -> t | `Replaced (_, t)= -> t in + List.fold_left add empty l + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/cmdliner_trie.mli b/tools/o= caml/duniverse/cmdliner/src/cmdliner_trie.mli new file mode 100644 index 0000000000..01d4029177 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/cmdliner_trie.mli @@ -0,0 +1,35 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** Tries. + + This implementation also maps any non ambiguous prefix of a + key to its value. *) + +type 'a t + +val empty : 'a t +val is_empty : 'a t -> bool +val add : 'a t -> string -> 'a -> [ `New of 'a t | `Replaced of 'a * 'a t ] +val find : 'a t -> string -> [ `Ok of 'a | `Ambiguous | `Not_found ] +val ambiguities : 'a t -> string -> string list +val of_list : (string * 'a) list -> 'a t + +(*------------------------------------------------------------------------= --- + Copyright (c) 2011 Daniel C. B=C3=BCnzli + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/cmdliner/src/dune b/tools/ocaml/dunivers= e/cmdliner/src/dune new file mode 100644 index 0000000000..b9ef5c9a15 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/src/dune @@ -0,0 +1,4 @@ +(library + (public_name cmdliner) + (flags :standard -w -3-6-27-32-35) + (wrapped false)) diff --git a/tools/ocaml/duniverse/cmdliner/test/chorus.ml b/tools/ocaml/du= niverse/cmdliner/test/chorus.ml new file mode 100644 index 0000000000..5cf4c20ca9 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/chorus.ml @@ -0,0 +1,31 @@ +(* Example from the documentation, this code is in public domain. *) + +(* Implementation of the command *) + +let chorus count msg =3D for i =3D 1 to count do print_endline msg done + +(* Command line interface *) + +open Cmdliner + +let count =3D + let doc =3D "Repeat the message $(docv) times." in + Arg.(value & opt int 10 & info ["c"; "count"] ~docv:"COUNT" ~doc) + +let msg =3D + let doc =3D "Overrides the default message to print." in + let env =3D Arg.env_var "CHORUS_MSG" ~doc in + let doc =3D "The message to print." in + Arg.(value & pos 0 string "Revolt!" & info [] ~env ~docv:"MSG" ~doc) + +let chorus_t =3D Term.(const chorus $ count $ msg) + +let info =3D + let doc =3D "print a customizable message repeatedly" in + let man =3D [ + `S Manpage.s_bugs; + `P "Email bug reports to ." ] + in + Term.info "chorus" ~version:"%%VERSION%%" ~doc ~exits:Term.default_exits= ~man + +let () =3D Term.exit @@ Term.eval (chorus_t, info) diff --git a/tools/ocaml/duniverse/cmdliner/test/cp_ex.ml b/tools/ocaml/dun= iverse/cmdliner/test/cp_ex.ml new file mode 100644 index 0000000000..381509fba4 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/cp_ex.ml @@ -0,0 +1,54 @@ +(* Example from the documentation, this code is in public domain. *) + +(* Implementation, we check the dest argument and print the args *) + +let cp verbose recurse force srcs dest =3D + if List.length srcs > 1 && + (not (Sys.file_exists dest) || not (Sys.is_directory dest)) + then + `Error (false, dest ^ " is not a directory") + else + `Ok (Printf.printf + "verbose =3D %B\nrecurse =3D %B\nforce =3D %B\nsrcs =3D %s\ndes= t =3D %s\n" + verbose recurse force (String.concat ", " srcs) dest) + +(* Command line interface *) + +open Cmdliner + +let verbose =3D + let doc =3D "Print file names as they are copied." in + Arg.(value & flag & info ["v"; "verbose"] ~doc) + +let recurse =3D + let doc =3D "Copy directories recursively." in + Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc) + +let force =3D + let doc =3D "If a destination file cannot be opened, remove it and try a= gain."in + Arg.(value & flag & info ["f"; "force"] ~doc) + +let srcs =3D + let doc =3D "Source file(s) to copy." in + Arg.(non_empty & pos_left ~rev:true 0 file [] & info [] ~docv:"SOURCE" ~= doc) + +let dest =3D + let doc =3D "Destination of the copy. Must be a directory if there is mo= re + than one $(i,SOURCE)." in + let docv =3D "DEST" in + Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv ~doc) + +let cmd =3D + let doc =3D "copy files" in + let man_xrefs =3D + [ `Tool "mv"; `Tool "scp"; `Page ("umask", 2); `Page ("symlink", 7) ] + in + let exits =3D Term.default_exits in + let man =3D + [ `S Manpage.s_bugs; + `P "Email them to ."; ] + in + Term.(ret (const cp $ verbose $ recurse $ force $ srcs $ dest)), + Term.info "cp" ~version:"%%VERSION%%" ~doc ~exits ~man ~man_xrefs + +let () =3D Term.(exit @@ eval cmd) diff --git a/tools/ocaml/duniverse/cmdliner/test/darcs_ex.ml b/tools/ocaml/= duniverse/cmdliner/test/darcs_ex.ml new file mode 100644 index 0000000000..a7fd5196d7 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/darcs_ex.ml @@ -0,0 +1,149 @@ +(* Example from the documentation, this code is in public domain. *) + +(* Implementations, just print the args. *) + +type verb =3D Normal | Quiet | Verbose +type copts =3D { debug : bool; verb : verb; prehook : string option } + +let str =3D Printf.sprintf +let opt_str sv =3D function None -> "None" | Some v -> str "Some(%s)" (sv = v) +let opt_str_str =3D opt_str (fun s -> s) +let verb_str =3D function + | Normal -> "normal" | Quiet -> "quiet" | Verbose -> "verbose" + +let pr_copts oc copts =3D Printf.fprintf oc + "debug =3D %B\nverbosity =3D %s\nprehook =3D %s\n" + copts.debug (verb_str copts.verb) (opt_str_str copts.prehook) + +let initialize copts repodir =3D Printf.printf + "%arepodir =3D %s\n" pr_copts copts repodir + +let record copts name email all ask_deps files =3D Printf.printf + "%aname =3D %s\nemail =3D %s\nall =3D %B\nask-deps =3D %B\nfiles =3D %= s\n" + pr_copts copts (opt_str_str name) (opt_str_str email) all ask_deps + (String.concat ", " files) + +let help copts man_format cmds topic =3D match topic with +| None -> `Help (`Pager, None) (* help about the program. *) +| Some topic -> + let topics =3D "topics" :: "patterns" :: "environment" :: cmds in + let conv, _ =3D Cmdliner.Arg.enum (List.rev_map (fun s -> (s, s)) topi= cs) in + match conv topic with + | `Error e -> `Error (false, e) + | `Ok t when t =3D "topics" -> List.iter print_endline topics; `Ok () + | `Ok t when List.mem t cmds -> `Help (man_format, Some t) + | `Ok t -> + let page =3D (topic, 7, "", "", ""), [`S topic; `P "Say something"= ;] in + `Ok (Cmdliner.Manpage.print man_format Format.std_formatter page) + +open Cmdliner + +(* Help sections common to all commands *) + +let help_secs =3D [ + `S Manpage.s_common_options; + `P "These options are common to all commands."; + `S "MORE HELP"; + `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command.";`No= blank; + `P "Use `$(mname) help patterns' for help on patch matching."; `Noblank; + `P "Use `$(mname) help environment' for help on environment variables."; + `S Manpage.s_bugs; `P "Check bug reports at http://bugs.example.org.";] + +(* Options common to all commands *) + +let copts debug verb prehook =3D { debug; verb; prehook } +let copts_t =3D + let docs =3D Manpage.s_common_options in + let debug =3D + let doc =3D "Give only debug output." in + Arg.(value & flag & info ["debug"] ~docs ~doc) + in + let verb =3D + let doc =3D "Suppress informational output." in + let quiet =3D Quiet, Arg.info ["q"; "quiet"] ~docs ~doc in + let doc =3D "Give verbose output." in + let verbose =3D Verbose, Arg.info ["v"; "verbose"] ~docs ~doc in + Arg.(last & vflag_all [Normal] [quiet; verbose]) + in + let prehook =3D + let doc =3D "Specify command to run before this $(mname) command." in + Arg.(value & opt (some string) None & info ["prehook"] ~docs ~doc) + in + Term.(const copts $ debug $ verb $ prehook) + +(* Commands *) + +let initialize_cmd =3D + let repodir =3D + let doc =3D "Run the program in repository directory $(docv)." in + Arg.(value & opt file Filename.current_dir_name & info ["repodir"] + ~docv:"DIR" ~doc) + in + let doc =3D "make the current directory a repository" in + let exits =3D Term.default_exits in + let man =3D [ + `S Manpage.s_description; + `P "Turns the current directory into a Darcs repository. Any + existing files and subdirectories become ..."; + `Blocks help_secs; ] + in + Term.(const initialize $ copts_t $ repodir), + Term.info "initialize" ~doc ~sdocs:Manpage.s_common_options ~exits ~man + +let record_cmd =3D + let pname =3D + let doc =3D "Name of the patch." in + Arg.(value & opt (some string) None & info ["m"; "patch-name"] ~docv:"= NAME" + ~doc) + in + let author =3D + let doc =3D "Specifies the author's identity." in + Arg.(value & opt (some string) None & info ["A"; "author"] ~docv:"EMAI= L" + ~doc) + in + let all =3D + let doc =3D "Answer yes to all patches." in + Arg.(value & flag & info ["a"; "all"] ~doc) + in + let ask_deps =3D + let doc =3D "Ask for extra dependencies." in + Arg.(value & flag & info ["ask-deps"] ~doc) + in + let files =3D Arg.(value & (pos_all file) [] & info [] ~docv:"FILE or DI= R") in + let doc =3D "create a patch from unrecorded changes" in + let exits =3D Term.default_exits in + let man =3D + [`S Manpage.s_description; + `P "Creates a patch from changes in the working tree. If you specify + a set of files ..."; + `Blocks help_secs; ] + in + Term.(const record $ copts_t $ pname $ author $ all $ ask_deps $ files), + Term.info "record" ~doc ~sdocs:Manpage.s_common_options ~exits ~man + +let help_cmd =3D + let topic =3D + let doc =3D "The topic to get help on. `topics' lists the topics." in + Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) + in + let doc =3D "display help about darcs and darcs commands" in + let exits =3D Term.default_exits in + let man =3D + [`S Manpage.s_description; + `P "Prints help about darcs commands and other subjects..."; + `Blocks help_secs; ] + in + Term.(ret (const help $ copts_t $ Arg.man_format $ Term.choice_names $to= pic)), + Term.info "help" ~doc ~exits ~man + +let default_cmd =3D + let doc =3D "a revision control system" in + let sdocs =3D Manpage.s_common_options in + let exits =3D Term.default_exits in + let man =3D help_secs in + Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)), + Term.info "darcs" ~version:"%%VERSION%%" ~doc ~sdocs ~exits ~man + +let cmds =3D [initialize_cmd; record_cmd; help_cmd] + +let () =3D Term.(exit @@ eval_choice default_cmd cmds) diff --git a/tools/ocaml/duniverse/cmdliner/test/dune b/tools/ocaml/duniver= se/cmdliner/test/dune new file mode 100644 index 0000000000..012c36aebf --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/dune @@ -0,0 +1,12 @@ +(executables + (names test_man + test_man_utf8 + test_pos + test_pos_rev + test_pos_all + test_pos_left + test_pos_req + test_opt_req + test_term_dups + test_with_used_args) + (libraries cmdliner)) diff --git a/tools/ocaml/duniverse/cmdliner/test/revolt.ml b/tools/ocaml/du= niverse/cmdliner/test/revolt.ml new file mode 100644 index 0000000000..f372e1d497 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/revolt.ml @@ -0,0 +1,9 @@ +(* Example from the documentation, this code is in public domain. *) + +let revolt () =3D print_endline "Revolt!" + +open Cmdliner + +let revolt_t =3D Term.(const revolt $ const ()) + +let () =3D Term.(exit @@ eval (revolt_t, Term.info "revolt")) diff --git a/tools/ocaml/duniverse/cmdliner/test/rm_ex.ml b/tools/ocaml/dun= iverse/cmdliner/test/rm_ex.ml new file mode 100644 index 0000000000..ba6344a886 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/rm_ex.ml @@ -0,0 +1,53 @@ +(* Example from the documentation, this code is in public domain. *) + +(* Implementation of the command, we just print the args. *) + +type prompt =3D Always | Once | Never +let prompt_str =3D function +| Always -> "always" | Once -> "once" | Never -> "never" + +let rm prompt recurse files =3D + Printf.printf "prompt =3D %s\nrecurse =3D %B\nfiles =3D %s\n" + (prompt_str prompt) recurse (String.concat ", " files) + +(* Command line interface *) + +open Cmdliner + +let files =3D Arg.(non_empty & pos_all file [] & info [] ~docv:"FILE") +let prompt =3D + let doc =3D "Prompt before every removal." in + let always =3D Always, Arg.info ["i"] ~doc in + let doc =3D "Ignore nonexistent files and never prompt." in + let never =3D Never, Arg.info ["f"; "force"] ~doc in + let doc =3D "Prompt once before removing more than three files, or when + removing recursively. Less intrusive than $(b,-i), while + still giving protection against most mistakes." + in + let once =3D Once, Arg.info ["I"] ~doc in + Arg.(last & vflag_all [Always] [always; never; once]) + +let recursive =3D + let doc =3D "Remove directories and their contents recursively." in + Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc) + +let cmd =3D + let doc =3D "remove files or directories" in + let man =3D [ + `S Manpage.s_description; + `P "$(tname) removes each specified $(i,FILE). By default it does not + remove directories, to also remove them and their contents, use the + option $(b,--recursive) ($(b,-r) or $(b,-R))."; + `P "To remove a file whose name starts with a `-', for example + `-foo', use one of these commands:"; + `Pre "$(mname) -- -foo\n\ + $(mname) ./-foo"; + `P "$(tname) removes symbolic links, not the files referenced by the + links."; + `S Manpage.s_bugs; `P "Report bugs to ."; + `S Manpage.s_see_also; `P "$(b,rmdir)(1), $(b,unlink)(2)" ] + in + Term.(const rm $ prompt $ recursive $ files), + Term.info "rm" ~version:"%%VERSION%%" ~doc ~exits:Term.default_exits ~man + +let () =3D Term.(exit @@ eval cmd) diff --git a/tools/ocaml/duniverse/cmdliner/test/tail_ex.ml b/tools/ocaml/d= universe/cmdliner/test/tail_ex.ml new file mode 100644 index 0000000000..3786ee2750 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/tail_ex.ml @@ -0,0 +1,73 @@ +(* Example from the documentation, this code is in public domain. *) + +(* Implementation of the command, we just print the args. *) + +type loc =3D bool * int +type verb =3D Verbose | Quiet +type follow =3D Name | Descriptor + +let str =3D Printf.sprintf +let opt_str sv =3D function None -> "None" | Some v -> str "Some(%s)" (sv = v) +let loc_str (rev, k) =3D if rev then str "%d" k else str "+%d" k +let follow_str =3D function Name -> "name" | Descriptor -> "descriptor" +let verb_str =3D function Verbose -> "verbose" | Quiet -> "quiet" + +let tail lines follow verb pid files =3D + Printf.printf "lines =3D %s\nfollow =3D %s\nverb =3D %s\npid =3D %s\nfil= es =3D %s\n" + (loc_str lines) (opt_str follow_str follow) (verb_str verb) + (opt_str string_of_int pid) (String.concat ", " files) + +(* Command line interface *) + +open Cmdliner + +let lines =3D + let loc =3D + let parse s =3D + try + if s <> "" && s.[0] <> '+' then Ok (true, int_of_string s) else + Ok (false, int_of_string (String.sub s 1 (String.length s - 1))) + with Failure _ -> Error (`Msg "unable to parse integer") + in + let print ppf p =3D Format.fprintf ppf "%s" (loc_str p) in + Arg.conv ~docv:"N" (parse, print) + in + Arg.(value & opt loc (true, 10) & info ["n"; "lines"] ~docv:"N" + ~doc:"Output the last $(docv) lines or use $(i,+)$(docv) to start + output after the $(i,N)-1th line.") +let follow =3D + let doc =3D "Output appended data as the file grows. $(docv) specifies h= ow the + file should be tracked, by its `name' or by its `descriptor'.= " in + let follow =3D Arg.enum ["name", Name; "descriptor", Descriptor] in + Arg.(value & opt (some follow) ~vopt:(Some Descriptor) None & + info ["f"; "follow"] ~docv:"ID" ~doc) + +let verb =3D + let doc =3D "Never output headers giving file names." in + let quiet =3D Quiet, Arg.info ["q"; "quiet"; "silent"] ~doc in + let doc =3D "Always output headers giving file names." in + let verbose =3D Verbose, Arg.info ["v"; "verbose"] ~doc in + Arg.(last & vflag_all [Quiet] [quiet; verbose]) + +let pid =3D + let doc =3D "With -f, terminate after process $(docv) dies." in + Arg.(value & opt (some int) None & info ["pid"] ~docv:"PID" ~doc) + +let files =3D Arg.(value & (pos_all non_dir_file []) & info [] ~docv:"FILE= ") + +let cmd =3D + let doc =3D "display the last part of a file" in + let man =3D [ + `S Manpage.s_description; + `P "$(tname) prints the last lines of each $(i,FILE) to standard outpu= t. If + no file is specified reads standard input. The number of printed + lines can be specified with the $(b,-n) option."; + `S Manpage.s_bugs; + `P "Report them to ."; + `S Manpage.s_see_also; + `P "$(b,cat)(1), $(b,head)(1)" ] + in + Term.(const tail $ lines $ follow $ verb $ pid $ files), + Term.info "tail" ~version:"%%VERSION%%" ~doc ~exits:Term.default_exits ~= man + +let () =3D Term.(exit @@ eval cmd) diff --git a/tools/ocaml/duniverse/cmdliner/test/test_man.ml b/tools/ocaml/= duniverse/cmdliner/test/test_man.ml new file mode 100644 index 0000000000..46822c8275 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/test_man.ml @@ -0,0 +1,100 @@ + +open Cmdliner + +let hey =3D + let doc =3D "Equivalent to set $(opt)." in + let env =3D Arg.env_var "TEST_ENV" ~doc in + let doc =3D "Set hey." in + Arg.(value & flag & info ["hey"; "y"] ~env ~doc) + +let repodir =3D + let doc =3D "See option $(opt)." in + let env =3D Arg.env_var "TEST_REPODDIR" ~doc in + let doc =3D "Run the program in repository directory $(docv)." in + Arg.(value & opt file Filename.current_dir_name & info ["repodir"] ~env + ~docv:"DIR" ~doc) + +let id =3D + let doc =3D "See option $(opt)." in + let env =3D Arg.env_var "TEST_ID" ~doc in + let doc =3D "Whatever $(docv) bla $(env) and $(opt)." in + Arg.(value & opt int ~vopt:10 0 & info ["id"; "i"] ~env ~docv:"ID)" ~doc) + +let miaouw =3D + let doc =3D "See option $(opt). These are term names $(mname) $(tname)" = in + let docs =3D "MIAOUW SECTION (non-standard unpositioned do not do this)"= in + let env =3D Arg.env_var "TEST_MIAOUW" ~doc ~docs in + let doc =3D "Whatever this is the doc var $(docv) this is the env var $(= env) \ + this is the opt $(opt) and this is $(i,italic) and this is + $(b,bold) and this $(b,\\$(opt\\)) is \\$(opt) in bold and th= is + \\$ is a dollar. $(mname) is the main term name, $(tname) is = the + term name." + in + Arg.(value & opt string "miaouw" & info ["m";] ~env ~docv:"MIAOUW" ~doc) + +let test hey repodir id miaouw =3D + Format.printf "hey: %B@.repodir: %s@.id: %d@.miaouw: %s@." + hey repodir id miaouw + +let man_test_t =3D Term.(const test $ hey $ repodir $ id $ miaouw) + +let info =3D + let doc =3D "print a customizable message repeatedly" in + let envs =3D [ Term.env_info "TEST_IT" ~doc:"This is $(env) for $(tname)= " ] in + let exits =3D [ Term.exit_info ~doc:"This is a $(status) for $(tname)" 1; + Term.exit_info ~doc:"Ranges from $(status) to $(status_max= )" + ~max:10 2; ] @ Term.default_exits + in + let man =3D [ + `S "THIS IS A SECTION FOR $(mname)"; + `P "$(mname) subst at begin and end $(mname)"; + `P "$(i,italic) and $(b,bold)"; + `P "\\$ escaped \\$\\$ escaped \\$"; + `P "This does not fail \\$(a)"; + `P ". this is a paragraph starting with a dot."; + `P "' this is a paragraph starting with a quote."; + `P "This: \\\\(rs is a backslash for groff and you should not see a \\= \\"; + `P "This: \\\\N'46' is a quote for groff and you should not see a '"; + `P "This: \\\\\" is a groff comment and it should not be one."; + `P "This is a non preformatted paragraph, filling will occur. This will + be properly layout on 80 columns."; + `Pre "This is a preformatted paragraph for $(mname) no filling will \ + occur do the $(i,ASCII) art $(b,here) this will overflow on 80 \ + columns \n\ + 01234556789\ + 01234556789\ + 01234556789\ + 01234556789\ + 01234556789\ + 01234556789\ + 01234556789\ + 01234556789\n\n\ + ... Should not break\n\ + a... Should not break\n\ + +---+\n\ + | /|\n\ + | / | ----> Let's swim to the moon.\n\ + |/ |\n\ + +---+"; + `P "These are escapes escaped \\$ \\( \\) \\\\"; + `P "() does not need to be escaped outside directives."; + `Blocks [ + `P "The following to paragraphs are spliced in."; + `P "This dollar needs escape \\$(var) this one aswell $(b,\\$(bla\\)= )"; + `P "This is another paragraph \\$(bla) $(i,\\$(bla\\)) $(b,\\$\\(bla= \\))"; + ]; + `Noblank; + `Pre "This is another preformatted paragraph.\n\ + There should be no blanks before and after it."; + `Noblank; + `P "Hey ho"; + `I ("label", "item label"); + `I ("lebal", "item lebal"); + `P "The last paragraph"; + `S Manpage.s_bugs; + `P "Email bug reports to .";] + in + let man_xrefs =3D [`Page ("ascii", 7); `Main; `Tool "grep";] in + Term.info "man_test" ~version:"%%VERSION%%" ~doc ~envs ~exits ~man ~man_= xrefs + +let () =3D Term.exit @@ Term.eval (man_test_t, info) diff --git a/tools/ocaml/duniverse/cmdliner/test/test_man_utf8.ml b/tools/o= caml/duniverse/cmdliner/test/test_man_utf8.ml new file mode 100644 index 0000000000..e4112a9caf --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/test_man_utf8.ml @@ -0,0 +1,11 @@ +open Cmdliner + +let nop () =3D print_endline "It's the manual that is of interest." + + +let test_pos =3D + Term.(const nop $ const ()), + Term.info "test_pos" + ~doc:"UTF-8 test: =C3=AD=C3=B6=C3=BC=C3=B3=C5=91=C3=BA=C5=B1=C3=A9=C3= =A1=C4=83=C3=AE=C3=A2=C8=99=C8=9B =C3=8D=C3=9C=C3=93=C5=90=C3=9A=C5=B0=C3= =89=C3=81=C4=82=C3=8E=C3=82=C8=98=C8=9A =E9=9B=99=E5=B3=B0=E9=A7=B1=E9=A7= =9D" + +let () =3D Term.(exit @@ eval test_pos) diff --git a/tools/ocaml/duniverse/cmdliner/test/test_opt_req.ml b/tools/oc= aml/duniverse/cmdliner/test/test_opt_req.ml new file mode 100644 index 0000000000..4cb525deba --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/test_opt_req.ml @@ -0,0 +1,13 @@ +open Cmdliner + +let opt o =3D print_endline o + +let test_opt =3D + let req =3D + Arg.(required & opt (some string) None & info ["r"; "req"] ~docv:"ARG") + in + Term.(const opt $ req), + Term.info "test_opt_req" + ~doc:"Test optional required arguments (don't do this)" + +let () =3D Term.(exit @@ eval test_opt) diff --git a/tools/ocaml/duniverse/cmdliner/test/test_pos.ml b/tools/ocaml/= duniverse/cmdliner/test/test_pos.ml new file mode 100644 index 0000000000..fd6e101f48 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/test_pos.ml @@ -0,0 +1,13 @@ +open Cmdliner + +let pos l t r =3D + print_endline (String.concat "\n" (l @ ["--"; t; "--"] @ r)) + +let test_pos =3D + let l =3D Arg.(value & pos_left 2 string [] & info [] ~docv:"LEFT") in + let t =3D Arg.(value & pos 2 string "undefined" & info [] ~docv:"TWO") in + let r =3D Arg.(value & pos_right 2 string [] & info [] ~docv:"RIGHT") in + Term.(const pos $ l $ t $ r), + Term.info "test_pos" ~doc:"Test pos arguments" + +let () =3D Term.(exit @@ eval test_pos) diff --git a/tools/ocaml/duniverse/cmdliner/test/test_pos_all.ml b/tools/oc= aml/duniverse/cmdliner/test/test_pos_all.ml new file mode 100644 index 0000000000..b5dc7082a8 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/test_pos_all.ml @@ -0,0 +1,11 @@ +open Cmdliner + +let pos_all all =3D print_endline (String.concat "\n" all) + +let test_pos_all =3D + let docv =3D "THEARG" in + let all =3D Arg.(value & pos_all string [] & info [] ~docv) in + Term.(const pos_all $ all), + Term.info "test_pos_all" ~doc:"Test pos all" + +let () =3D Term.(exit @@ eval test_pos_all) diff --git a/tools/ocaml/duniverse/cmdliner/test/test_pos_left.ml b/tools/o= caml/duniverse/cmdliner/test/test_pos_left.ml new file mode 100644 index 0000000000..90e4fbe13c --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/test_pos_left.ml @@ -0,0 +1,11 @@ +open Cmdliner + +let pos l =3D + print_endline (String.concat "\n" l) + +let test_pos_left =3D + let l =3D Arg.(value & pos_left 2 string [] & info [] ~docv:"LEFT") in + Term.(const pos $ l), + Term.info "test_pos" ~doc:"Test pos left" + +let () =3D Term.(exit @@ eval test_pos_left) diff --git a/tools/ocaml/duniverse/cmdliner/test/test_pos_req.ml b/tools/oc= aml/duniverse/cmdliner/test/test_pos_req.ml new file mode 100644 index 0000000000..282a77a877 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/test_pos_req.ml @@ -0,0 +1,15 @@ +open Cmdliner + +let pos r a1 a0 a2 =3D + print_endline (String.concat "\n" ([a0; a1; a2; "--"] @ r)) + +let test_pos =3D + let req p =3D + let docv =3D Printf.sprintf "ARG%d" p in + Arg.(required & pos p (some string) None & info [] ~docv) + in + let right =3D Arg.(non_empty & pos_right 2 string [] & info [] ~docv:"RI= GHT") in + Term.(const pos $ right $ req 1 $ req 0 $ req 2), + Term.info "test_pos_req" ~doc:"Test pos req arguments" + +let () =3D Term.(exit @@ eval test_pos) diff --git a/tools/ocaml/duniverse/cmdliner/test/test_pos_rev.ml b/tools/oc= aml/duniverse/cmdliner/test/test_pos_rev.ml new file mode 100644 index 0000000000..d8321aa861 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/test_pos_rev.ml @@ -0,0 +1,14 @@ +open Cmdliner + +let pos l t r =3D + print_endline (String.concat "\n" (l @ ["--"; t; "--"] @ r)) + +let test_pos =3D + let rev =3D true in + let l =3D Arg.(value & pos_left ~rev 2 string [] & info [] ~docv:"LEFT")= in + let t =3D Arg.(value & pos ~rev 2 string "undefined" & info [] ~docv:"TW= O") in + let r =3D Arg.(value & pos_right ~rev 2 string [] & info [] ~docv:"RIGHT= ") in + Term.(const pos $ l $ t $ r), + Term.info "test_pos" ~doc:"Test pos rev arguments" + +let () =3D Term.(exit @@ eval test_pos) diff --git a/tools/ocaml/duniverse/cmdliner/test/test_term_dups.ml b/tools/= ocaml/duniverse/cmdliner/test/test_term_dups.ml new file mode 100644 index 0000000000..c6462761c7 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/test_term_dups.ml @@ -0,0 +1,19 @@ +open Cmdliner + +let dups p p_dup o o_dup =3D + let b =3D string_of_bool in + print_endline (String.concat "\n" [p; p_dup; b o; b o_dup;]) + +let test_pos =3D + let p =3D + let doc =3D "First pos argument should show up only once in the docs" = in + Arg.(value & pos 0 string "undefined" & info [] ~doc ~docv:"POS") + in + let o =3D + let doc =3D "This should show up only once in the docs" in + Arg.(value & flag & info ["f"; "flag"] ~doc) + in + Term.(const dups $ p $ p $ o $ o), + Term.info "test_term_dups" ~doc:"Test multiple term usage" + +let () =3D Term.(exit @@ eval test_pos) diff --git a/tools/ocaml/duniverse/cmdliner/test/test_with_used_args.ml b/t= ools/ocaml/duniverse/cmdliner/test/test_with_used_args.ml new file mode 100644 index 0000000000..0a45d07775 --- /dev/null +++ b/tools/ocaml/duniverse/cmdliner/test/test_with_used_args.ml @@ -0,0 +1,18 @@ +open Cmdliner + +let print_args ((), args) _other =3D + print_endline (String.concat " " args) + +let test_pos_left =3D + let a =3D Arg.(value & flag & info ["a"; "aaa"]) in + let b =3D Arg.(value & opt (some string) None & info ["b"; "bbb"]) in + let c =3D Arg.(value & pos_all string [] & info []) in + let main =3D + let ignore_values _a _b _c =3D () in + Term.(with_used_args (const ignore_values $ a $ b $ c)) + in + let other =3D Arg.(value & flag & info ["other"]) in + Term.(const print_args $ main $ other), + Term.info "test_capture" ~doc:"Test pos left" + +let () =3D Term.(exit @@ eval test_pos_left) diff --git a/tools/ocaml/duniverse/cppo/.gitignore b/tools/ocaml/duniverse/= cppo/.gitignore new file mode 100644 index 0000000000..1d0dd35c65 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/.gitignore @@ -0,0 +1,5 @@ +*~ +_build +.merlin +*.install +.*.swp diff --git a/tools/ocaml/duniverse/cppo/.ocp-indent b/tools/ocaml/duniverse= /cppo/.ocp-indent new file mode 100644 index 0000000000..fb580a5b4b --- /dev/null +++ b/tools/ocaml/duniverse/cppo/.ocp-indent @@ -0,0 +1,22 @@ +# See https://github.com/OCamlPro/ocp-indent/blob/master/.ocp-indent for m= ore + +# Indent for clauses inside a pattern-match (after the arrow): +# match foo with +# | _ -> +# ^^^^bar +# the default is 2, which aligns the pattern and the expression +match_clause =3D 4 + +# When nesting expressions on the same line, their indentation are in +# some cases stacked, so that it remains correct if you close them one +# at a line. This may lead to large indents in complex code though, so +# this parameter can be used to set a maximum value. Note that it only +# affects indentation after function arrows and opening parens at end +# of line. +# +# for example (left: `none`; right: `4`) +# let f =3D g (h (i (fun x -> # let f =3D g (h (i (fun x -> +# x) # x) +# ) # ) +# ) # ) +max_indent =3D 2 diff --git a/tools/ocaml/duniverse/cppo/.travis.yml b/tools/ocaml/duniverse= /cppo/.travis.yml new file mode 100644 index 0000000000..1f17d1158d --- /dev/null +++ b/tools/ocaml/duniverse/cppo/.travis.yml @@ -0,0 +1,16 @@ +language: c +sudo: required +install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/mas= ter/.travis-opam.sh +script: bash -ex .travis-opam.sh +env: + global: + - PACKAGE=3Dcppo + matrix: + - OCAML_VERSION=3D4.03 + - OCAML_VERSION=3D4.04 + - OCAML_VERSION=3D4.05 + - OCAML_VERSION=3D4.06 + - OCAML_VERSION=3D4.07 +os: + - linux + - osx diff --git a/tools/ocaml/duniverse/cppo/CODEOWNERS b/tools/ocaml/duniverse/= cppo/CODEOWNERS new file mode 100644 index 0000000000..2a7c825096 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/CODEOWNERS @@ -0,0 +1,8 @@ +# We're looking for one or more volunteers to take the lead of cppo, +# with the help of ocaml-community. +# +# Call for volunteers: https://github.com/ocaml-community/meta/issues/27 +# About ocaml-community: https://github.com/ocaml-community/meta +# +# Interim maintainers who won't be very responsive :-( +* @mjambon @pmetzger diff --git a/tools/ocaml/duniverse/cppo/Changes b/tools/ocaml/duniverse/cpp= o/Changes new file mode 100644 index 0000000000..48581b7c1c --- /dev/null +++ b/tools/ocaml/duniverse/cppo/Changes @@ -0,0 +1,85 @@ +## v1.6.7 (2020-12-21) +- [compat] Treat ~ and - the same in semver in order to parse + OCaml 4.12.0 pre-release versions. +- [compat] Restore 4.02.3 compatibility. + +## v1.6.6 (2019-05-27) +- [pkg] port build system to dune from jbuilder. +- [pkg] upgrade opam metadata to 2.0 format. +- [pkg] remove topkg and use dune-release. +- [compat] Use `String.capitalize_ascii` to remove warning. + +## v1.6.5 (2018-09-12) +- [bug] Fix 'asr' operator (#61) + +## v1.6.4 (2018-02-26) +- [compat] Tests should now work with older versions of jbuilder. + +## v1.6.3 (2018-02-21) +- [compat] Fix tests. + +## v1.6.1 (2018-01-25) +- [compat] Emit line directives always containing the file name, + as mandated starting with ocaml 4.07. + +## v1.6.0 (2017-08-07) +- [pkg] BREAKING: cppo and cppo_ocamlbuild are now two distinct opam + packages. + +## v1.5.0 (2017-04-24) +- [+ui] Added the `CAPITALIZE()` function. + +## v1.4.0 (2016-08-19) +- [compat] Cppo is now safe-string ready. + +## v1.3.2 (2016-04-20) +- [pkg] Cppo can now be built on MSVC. + +## v1.3.1 (2015-09-20) +- [bug] Possible to have #endif between two matching parenthesis. + +## v1.3.0 (2015-09-13) +- [+ui] Removed the need for escaping commas and parenthesis in macros. +- [+ui] Blanks is now allowed in argument list in macro definitions. +- [+ui] #directive with wrong arguments is now giving a proper error. +- [bug] Fixed expansion of __FILE__ and __LINE__. + +## v1.1.2 (2014-11-10) +- [+ui] Ocamlbuild_cppo: added the ocamlbuild flag `cppo_V(NAME:VERSION)`, + equivalent to `-V NAME:VERSION` (for _tags file). + +## v1.1.1 (2014-11-10) +- [+ui] Ocamlbuild_cppo: added the ocamlbuild flag `cppo_V_OCAML`, + equivalent to `-V OCAML:VERSION` (for _tags file). + +## v1.1.0 (2014-11-04) +- [+ui] Added the `-V NAME:VERSION` option. +- [+ui] Support for tuples in comparisons: tuples can be constructed + and compared, e.g. `#if (2 + 2, 5) < (4, 5)`. + +## v1.0.1 (2014-10-20) +- [+ui] `#elif` and `#else` can now be used in the same #if-#else statemen= t. +- [bug] Fixed the Ocamlbuild flag `cppo_n`. + +## v1.0.0 (2014-09-06) +- [bug] OCaml comments are now better parsed. For example, (* '"' *) works. + +## v0.9.4 (2014-06-10) +- [+ui] Added the ocamlbuild_cppo plugin for Ocamlbuild. To use it: + `-plugin(cppo_ocamlbuild)`. + +## v0.9.3 (2012-02-03) +- [pkg] New way of building the tar.gz archive. + +## v0.9.2 (2011-08-12) +- [+ui] Added two predefined macros STRINGIFY and CONCAT for making + string literals and for building identifiers respectively. + +## v0.9.1 (2011-07-20) +- [+ui] Added support for processing sections of files using external prog= rams + (#ext/#endext, -x option) +- [doc] Moved and extended documentation into the README file. + +## v0.9.0 (2009-11-17) + +- initial public release diff --git a/tools/ocaml/duniverse/cppo/INSTALL.md b/tools/ocaml/duniverse/= cppo/INSTALL.md new file mode 100644 index 0000000000..ce1da139a0 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/INSTALL.md @@ -0,0 +1,17 @@ +Installation instructions for cppo +=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D + +Building cppo requires GNU Make and a standard OCaml +installation. It can be installed with opam or manually as follows: + +Build: + +``` +make +``` + +Install: + +``` +make DESTDIR=3D/some/path install +``` diff --git a/tools/ocaml/duniverse/cppo/LICENSE.md b/tools/ocaml/duniverse/= cppo/LICENSE.md new file mode 100644 index 0000000000..f1725ba4ef --- /dev/null +++ b/tools/ocaml/duniverse/cppo/LICENSE.md @@ -0,0 +1,24 @@ +Copyright (c) 2009-2011 Martin Jambon +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/tools/ocaml/duniverse/cppo/Makefile b/tools/ocaml/duniverse/cp= po/Makefile new file mode 100644 index 0000000000..c69d27e470 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/Makefile @@ -0,0 +1,18 @@ +all: + @dune build + +test: + @dune runtest + +install: + @dune install + +uninstall: + @dune uninstall + +check: test + +.PHONY: clean all check test install uninstall + +clean: + dune clean diff --git a/tools/ocaml/duniverse/cppo/README.md b/tools/ocaml/duniverse/c= ppo/README.md new file mode 100644 index 0000000000..8d5093af17 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/README.md @@ -0,0 +1,521 @@ +[![Build status](https://ci.appveyor.com/api/projects/status/ft3167hf8yr2n= 5d3?svg=3Dtrue)](https://ci.appveyor.com/project/Chris00/cppo-pnjtx) + +Cppo: cpp for OCaml +=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D + +Cppo is an equivalent of the C preprocessor for OCaml programs. +It allows the definition of simple macros and file inclusion. + +Cppo is: + +* more OCaml-friendly than cpp +* easy to learn without consulting a manual +* reasonably fast +* simple to install and to maintain + +User guide +---------- + +Cppo is a preprocessor for programming languages that follow lexical rules +compatible with OCaml including OCaml-style comments `(* ... *)`. These in= clude Ocamllex, Ocamlyacc, Menhir, and extensions of OCaml based on Camlp4,= Camlp5, or ppx. Cppo should work with Bucklescript as well. It won't work = so well with Reason code because Reason uses C-style comment delimiters `/*= ` and `*/`. + +Cppo supports a number of directives. A directive is a `#` sign placed +at the beginning of a line, possibly preceded by some whitespace, and foll= owed +by a valid directive name or by a number: + +```ocaml +BLANK* "#" BLANK* ("define"|"undef" + |"if"|"ifdef"|"ifndef"|"else"|"elif"|"endif" + |"include" + |"warning"|"error" + |"ext"|"endext") ... +``` + +Directives can be split into multiple lines by placing a backslash `\` at +the end of the line to be continued. In general, any special character +can used as a normal character by preceding it with backslash. + + +File inclusion +-------------- + +```ocaml +#include "hello.ml" +``` + +This is how a source file `hello.ml` can be included. +Relative paths are searched first in the directory of the current file +and then in the search paths added on the command line using `-I`, if any. + + +Macros +------ + +This is a simple macro that doesn't take an argument ("object-like +macro" in the cpp jargon): + +```ocaml +#define Ms Mississippi + +match state with + Ms -> true + | _ -> false +``` + +After preprocessing by cppo, the code above becomes: + +```ocaml +match state with + Mississippi -> true + | _ -> false +``` + +If needed, defined macros can be undefined. This is required prior to +redefining a macro: + +```ocaml +#undef X +``` + +An important distinction with cpp is that only previously-defined +macros are accessible. Defining, undefining or redefining a macro has +no effect on how previous macros will expand. + +Macros can take arguments ("function-like macro" in the cpp +jargon). Both in the definition (`#define`) and in macro application the +opening parenthesis must stick to the macro's identifier: + +```ocaml +#define debug(args) if !debugging then Printf.eprintf args else () + +debug("Testing %i" (1 + 1)) +``` + +is expanded into: + +```ocaml +if !debugging then Printf.eprintf "Testing %i" (1 + 1) else () +``` + +Here is a multiline macro definition. Newlines occurring between +tokens must be protected by a backslash: + +```ocaml +#define repeat_until(action,condition) \ + action; \ + while not (condition) do \ + action \ + done +``` + +All user-definable macros are constant. There are however two +predefined variable macros: `__FILE__` and `__LINE__` which take the value +of the position in the source file where the macro is being expanded. + +```ocaml +#define loc (Printf.sprintf "File %S, line %i" __FILE__ __LINE__) +``` + +Macros can be defined on the command line as follows: + +```ocaml +# preprocessing only +cppo -D 'VERSION 1.0' example.ml + +# preprocessing and compiling +ocamlopt -c -pp "cppo -D 'VERSION 1.0'" example.ml +``` + +Conditionals +------------ + +Here is a quick reference on conditionals available in cppo. If you +are not familiar with `#ifdef`, `#ifndef`, `#if`, `#else` and `#elif`, ple= ase +refer to the corresponding section in the cpp manual. + +```ocaml +#ifndef VERSION +#warning "VERSION is undefined" +#define VERSION "n/a" +#endif +#ifndef VERSION +#error "VERSION is undefined" +#endif +#if OCAML_MAJOR >=3D 3 && OCAML_MINOR >=3D 10 +... +#endif +#ifdef X +... +#elif defined Y +... +#else +... +#endif +``` + +The boolean expressions following `#if` and `#elif` may perform arithmetic +operations and tests over 64-bit ints. + +Boolean expressions: + +* `defined` ... followed by an identifier, returns true if such a macro e= xists +* `true` +* `false` +* `(` ... `)` +* ... `&&` ... +* ... `||` ... +* `not` ... + +Arithmetic comparisons used in boolean expressions: + +* ... `=3D` ... +* ... `<` ... +* ... `>` ... +* ... `<>` ... +* ... `<=3D` ... +* ... `>=3D` ... + +Arithmetic operators over signed 64-bit ints: + +* `(` ... `)` +* ... `+` ... +* ... `-` ... +* ... `*` ... +* ... `/` ... +* ... `mod` ... +* ... `lsl` ... +* ... `lsr` ... +* ... `asr` ... +* ... `land` ... +* ... `lor` ... +* ... `lxor` ... +* `lnot` ... + +Macro identifiers can be used in place of ints as long as they expand +to an int literal or a tuple of int literals, e.g.: + +```ocaml +#define one 1 + +#if one + one <> 2 +#error "Something's wrong." +#endif + +#define VERSION (1, 0, 5) +#if VERSION <=3D (1, 0, 2) +#error "Version 1.0.2 or greater is required." +#endif +``` + +Version strings (http://semver.org/) can also be passed to cppo on the +command line. This results in multiple variables being defined, all +sharing the same prefix. See the output of `cppo -help` (copied at the +bottom of this page). + +``` +$ cppo -V OCAML:`ocamlc -version` +#if OCAML_VERSION >=3D (4, 0, 0) +(* All is well. *) +#else + #error "This version of OCaml is not supported." +#endif +``` + +Output: +``` +# 2 "" +(* All is well. *) +``` + +Source file location +-------------------- + +Location directives are the same as in OCaml and are echoed in the +output. They consist of a line number optionally followed by a file name: + +```ocaml +# 123 +# 456 "source" +``` + +Messages +-------- + +Warnings and error messages can be produced by the preprocessor: + +```ocaml +#ifndef X + #warning "Assuming default value for X" + #define X 1 +#elif X =3D 0 + #error "X may not be null" +#endif +``` + +Calling an external processor +----------------------------- + +Cppo provides a mechanism for converting sections of a file using +and external program. Such a section must be placed between `#ext` and +`#endext` directives. + +```bash +$ cat foo +ABC +#ext lowercase +DEF +#endext +GHI +#ext lowercase +KLM +NOP +#endext +QRS + +$ cppo -x lowercase:'tr "[A-Z]" "[a-z]"' foo +# 1 "foo" +ABC +def +# 5 "foo" +GHI +klm +nop +# 10 "foo" +QRS +``` + +In the example above, `lowercase` is the name given on the +command-line to external command `'tr "[A-Z]" "[a-z]"'` that reads +input from stdin and writes its output to stdout. + + +Escaping +-------- + +The following characters can be escaped by a backslash when needed: + +```ocaml +( +) +, +# +``` + +In OCaml `#` is used for method calls. It is usually not a problem +because in order to be interpreted as a preprocessor directive, it +must be the first non-blank character of a line and be a known +directive. If an object has a define method and you want `#` to appear +first on a line, you would have to use `\#` instead: + +```ocaml +obj + \#define +``` + +Line directives in the usual format supported by OCaml are correctly +interpreted by cppo. + +Comments and string literals constitute single tokens even when they +span across multiple lines. Therefore newlines within string literals +and comments should remain as-is (no preceding backslash) even in a +macro body: + +```ocaml +#define welcome \ +"********** +*Welcome!* +********** +" +``` + +Concatenation +------------- + +`CONCAT()` is a predefined macro that takes two arguments, removes any +whitespace between and around them and fuses them into a single identifier. +The result of the concatenation must be a valid identifier of the +form [A-Za-z_][A-Za-z0-9_]+ or [A-Za-z], or empty. + +For example, + +```ocaml +#define x 123 +CONCAT(z, x) +``` + +expands into: + +```ocaml +z123 +``` + +However the following is illegal: + +```ocaml +#define x 123 +CONCAT(x, z) +``` + +because 123z does not form a valid identifier. + +`CONCAT(a,b)` is roughly equivalent to `a##b` in cpp syntax. + +CAPITALIZE +--------------- + +`CAPITALIZE()` is a predefined macro that takes one argument, +removes any leading and trailing whitespace, reduces each internal +whitespace sequence to a single space character and produces +a valid OCaml identifer with first character. + +For example, +```ocaml +#define EVENT(n,ty) external CONCAT(on,CAPITALIZE(n)) : ty =3D STRINGIFY(n= ) [@@bs.val]=20 +EVENT(exit, unit -> unit) +``` +is expanded into: + +```ocaml +external onExit : unit -> unit =3D "exit" [@@bs.val] +``` + +Stringification +--------------- + +`STRINGIFY()` is a predefined macro that takes one argument, +removes any leading and trailing whitespace, reduces each internal +whitespace sequence to a single space character and produces +a valid OCaml string literal. + +For example, + +```ocaml +#define TRACE(f) Printf.printf ">>> %s\n" STRINGIFY(f); f +TRACE(print_endline) "Hello" +``` + +is expanded into: + +```ocaml +Printf.printf ">>> %s\n" "print_endline"; print_endline "Hello" +``` + +`STRINGIFY(x)` is the equivalent of `#x` in cpp syntax. + + +Ocamlbuild plugin +------------------ + +An ocamlbuild plugin is available. To use it, you can call ocamlbuild +with the argument `-plugin-tag package(cppo_ocamlbuild)` (only since +ocaml 4.01 and cppo >=3D 0.9.4). + +Starting from **cppo >=3D 1.6.0**, the `cppo_ocamlbuild` plugin is in a +separate OPAM package (`opam install cppo_ocamlbuild`). + +With Oasis : +``` +OCamlVersion: >=3D 4.01 +AlphaFeatures: ocamlbuild_more_args +XOCamlbuildPluginTags: package(cppo_ocamlbuild) +``` + +After that, you need to add in your `myocamlbuild.ml` : +```ocaml +let () =3D + Ocamlbuild_plugin.dispatch + (fun hook -> + Ocamlbuild_cppo.dispatcher hook ; + ) +``` + +By default the plugin will apply cppo on all files ending in `.cppo.ml` +`cppo.mli`, and `cppo.mlpack`, in order to produce `.ml`, `.mli`, +and`.mlpack` files. The following tags are available: +* `cppo_D(X)` =E2=89=A1 `-D X` +* `cppo_U(X)` =E2=89=A1 `-U X` +* `cppo_q` =E2=89=A1 `-q` +* `cppo_s` =E2=89=A1 `-s` +* `cppo_n` =E2=89=A1 `-n` +* `cppo_x(NAME:CMD_TEMPLATE)` =E2=89=A1 `-x NAME:CMD_TEMPLATE` +* The tag `cppo_I(foo)` can behave in two way: + * If `foo` is a directory, it's equivalent to `-I foo`. + * If `foo` is a file, it adds `foo` as a dependency and apply `-I + parent(foo)`. +* `cppo_V(NAME:VERSION)` =E2=89=A1 `-V NAME:VERSION` +* `cppo_V_OCAML` =E2=89=A1 `-V OCAML:VERSION`, where `VERSION` + is the version of OCaml that ocamlbuild uses. + +Detailed command-line usage and options +--------------------------------------- + +``` +Usage: ./cppo [OPTIONS] [FILE1 [FILE2 ...]] +Options: + -D DEF + Equivalent of interpreting '#define DEF' before processing the + input + -U IDENT + Equivalent of interpreting '#undef IDENT' before processing the + input + -I DIR + Add directory DIR to the search path for included files + -V VAR:MAJOR.MINOR.PATCH-OPTPRERELEASE+OPTBUILD + Define the following variables extracted from a version string + (following the Semantic Versioning syntax http://semver.org/): + + VAR_MAJOR must be a non-negative int + VAR_MINOR must be a non-negative int + VAR_PATCH must be a non-negative int + VAR_PRERELEASE if the OPTPRERELEASE part exists + VAR_BUILD if the OPTBUILD part exists + VAR_VERSION is the tuple (MAJOR, MINOR, PATCH) + VAR_VERSION_STRING is the string MAJOR.MINOR.PATCH + VAR_VERSION_FULL is the original string + + Example: cppo -V OCAML:4.02.1 + + -o FILE + Output file + -q + Identify and preserve camlp4 quotations + -s + Output line directives pointing to the exact source location of + each token, including those coming from the body of macro + definitions. This behavior is off by default. + -n + Do not output any line directive other than those found in the + input (overrides -s). + -version + Print the version of the program and exit. + -x NAME:CMD_TEMPLATE + Define a custom preprocessor target section starting with: + #ext "NAME" + and ending with: + #endext + + NAME must be a lowercase identifier of the form [a-z][A-Za-z0-9_= ]* + + CMD_TEMPLATE is a command template supporting the following + special sequences: + %F file name (unescaped; beware of potential scripting attack= s) + %B number of the first line + %E number of the last line + %% a single percent sign + + Filename, first line number and last line number are also + available from the following environment variables: + CPPO_FILE, CPPO_FIRST_LINE, CPPO_LAST_LINE. + + The command produced is expected to read the data lines from std= in + and to write its output to stdout. + -help Display this list of options + --help Display this list of options +``` + + +Contributing +------------ + +See our contribution guidelines at +https://github.com/mjambon/documents/blob/master/how-to-contribute.md diff --git a/tools/ocaml/duniverse/cppo/VERSION b/tools/ocaml/duniverse/cpp= o/VERSION new file mode 100644 index 0000000000..ec70f75560 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/VERSION @@ -0,0 +1 @@ +1.6.6 diff --git a/tools/ocaml/duniverse/cppo/appveyor.yml b/tools/ocaml/dunivers= e/cppo/appveyor.yml new file mode 100644 index 0000000000..456a4cc206 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/appveyor.yml @@ -0,0 +1,14 @@ + +environment: + matrix: + - OCAML_BRANCH: 4.05 + - OCAML_BRANCH: 4.06 + +install: + - appveyor DownloadFile "https://raw.githubusercontent.com/Chris00/ocaml= -appveyor/master/install_ocaml.cmd" -FileName "C:\install_ocaml.cmd" + - C:\install_ocaml.cmd + +build_script: + - cd "%APPVEYOR_BUILD_FOLDER%" + - dune subst + - dune build -p cppo diff --git a/tools/ocaml/duniverse/cppo/cppo.opam b/tools/ocaml/duniverse/c= ppo/cppo.opam new file mode 100644 index 0000000000..33258eb4c9 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/cppo.opam @@ -0,0 +1,31 @@ +version: "1.6.7" +opam-version: "2.0" +maintainer: "martin@mjambon.com" +authors: "Martin Jambon" +license: "BSD-3-Clause" +homepage: "https://github.com/ocaml-community/cppo" +doc: "https://ocaml-community.github.io/cppo/" +bug-reports: "https://github.com/ocaml-community/cppo/issues" +depends: [ + "ocaml" {>=3D "4.02.3"} + "dune" {>=3D "1.0"} + "base-unix" +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/ocaml-community/cppo.git" +synopsis: "Code preprocessor like cpp for OCaml" +description: """ +Cppo is an equivalent of the C preprocessor for OCaml programs. +It allows the definition of simple macros and file inclusion. + +Cppo is: + +* more OCaml-friendly than cpp +* easy to learn without consulting a manual +* reasonably fast +* simple to install and to maintain +""" \ No newline at end of file diff --git a/tools/ocaml/duniverse/cppo/cppo_ocamlbuild.opam b/tools/ocaml/= duniverse/cppo/cppo_ocamlbuild.opam new file mode 100644 index 0000000000..22fa8ce630 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/cppo_ocamlbuild.opam @@ -0,0 +1,27 @@ +version: "1.6.7" +opam-version: "2.0" +maintainer: "martin@mjambon.com" +authors: "Martin Jambon" +license: "BSD-3-Clause" +homepage: "https://github.com/ocaml-community/cppo" +doc: "https://ocaml-community.github.io/cppo/" +bug-reports: "https://github.com/ocaml-community/cppo/issues" +depends: [ + "ocaml" + "dune" {>=3D "1.0"} + "ocamlbuild" + "ocamlfind" +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/ocaml-community/cppo.git" +synopsis: "Plugin to use cppo with ocamlbuild" +description: """ +This ocamlbuild plugin lets you use cppo in ocamlbuild projects. + +To use it, you can call ocamlbuild with the argument `-plugin-tag +package(cppo_ocamlbuild)` (only since ocaml 4.01 and cppo >=3D 0.9.4). +""" \ No newline at end of file diff --git a/tools/ocaml/duniverse/cppo/dune-project b/tools/ocaml/dunivers= e/cppo/dune-project new file mode 100644 index 0000000000..3f91b7266a --- /dev/null +++ b/tools/ocaml/duniverse/cppo/dune-project @@ -0,0 +1,3 @@ +(lang dune 1.0) +(name cppo) +(version v1.6.7) diff --git a/tools/ocaml/duniverse/cppo/examples/Makefile b/tools/ocaml/dun= iverse/cppo/examples/Makefile new file mode 100644 index 0000000000..f9dd33fbfd --- /dev/null +++ b/tools/ocaml/duniverse/cppo/examples/Makefile @@ -0,0 +1,8 @@ +.PHONY: all clean +all: + ../cppo debug.ml > debug.out + ../cppo french.ml > french.out + ocamllex lexer.mll + ../cppo lexer.ml > lexer.out +clean: + rm -f *.out lexer.ml diff --git a/tools/ocaml/duniverse/cppo/examples/debug.ml b/tools/ocaml/dun= iverse/cppo/examples/debug.ml new file mode 100644 index 0000000000..d47b512224 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/examples/debug.ml @@ -0,0 +1,7 @@ +#ifdef DEBUG +#define debug(s) Printf.eprintf "[%S %i] %s\n%!" __FILE__ __LINE__ s +#else +#define debug(s) () +#endif + +debug("test") diff --git a/tools/ocaml/duniverse/cppo/examples/dune b/tools/ocaml/duniver= se/cppo/examples/dune new file mode 100644 index 0000000000..f4d9de7c6f --- /dev/null +++ b/tools/ocaml/duniverse/cppo/examples/dune @@ -0,0 +1,32 @@ +(ocamllex lexer) + +(rule + (deps + (:< debug.ml)) + (targets debug.out) + (action + (with-stdout-to + %{targets} + (run %{bin:cppo} %{<})))) + +(rule + (deps + (:< french.ml)) + (targets french.out) + (action + (with-stdout-to + %{targets} + (run %{bin:cppo} %{<})))) + +(rule + (deps + (:< lexer.ml)) + (targets lexer.out) + (action + (with-stdout-to + %{targets} + (run %{bin:cppo} %{<})))) + +(alias + (name DEFAULT) + (deps debug.out french.out lexer.out)) diff --git a/tools/ocaml/duniverse/cppo/examples/french.ml b/tools/ocaml/du= niverse/cppo/examples/french.ml new file mode 100644 index 0000000000..e173a1fe1c --- /dev/null +++ b/tools/ocaml/duniverse/cppo/examples/french.ml @@ -0,0 +1,34 @@ +#define soit let +#define fonction function +#define fon fun +#define dans in +#define si if +#define alors then +#define sinon else + +#define Liste List +#define Affichef Printf +#define affichef printf + +#define separation split +#define tri sort + +soit rec separation x =3D fonction + y :: l -> + soit l1, l2 =3D separation x l dans + si y < x alors (y :: l1), l2 + sinon l1, (y :: l2) + | [] -> + [], [] + +soit rec tri =3D fonction + x :: l -> + soit l1, l2 =3D separation x l dans + tri l1 @ [x] @ tri l2 + | [] -> + [] + +soit () =3D + soit l =3D tri [ 5; 3; 7; 1; 7; 4; 99; 22 ] dans + Liste.iter (fon i -> Affichef.affichef "%i " i) l; + Affichef.affichef "\n" diff --git a/tools/ocaml/duniverse/cppo/examples/lexer.mll b/tools/ocaml/du= niverse/cppo/examples/lexer.mll new file mode 100644 index 0000000000..446e8eef28 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/examples/lexer.mll @@ -0,0 +1,9 @@ +(* Warning: ocamllex doesn't accept cppo directives + within the rules section. *) +rule token =3D parse + ['a'-'z']+ { `String (Lexing.lexeme lexbuf) } +{ +#ifndef NOFOO + let foo () =3D () +#endif +} diff --git a/tools/ocaml/duniverse/cppo/ocamlbuild_plugin/_tags b/tools/oca= ml/duniverse/cppo/ocamlbuild_plugin/_tags new file mode 100644 index 0000000000..dc946a1c24 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/ocamlbuild_plugin/_tags @@ -0,0 +1 @@ +true: package(ocamlbuild) diff --git a/tools/ocaml/duniverse/cppo/ocamlbuild_plugin/dune b/tools/ocam= l/duniverse/cppo/ocamlbuild_plugin/dune new file mode 100644 index 0000000000..b512a12f29 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/ocamlbuild_plugin/dune @@ -0,0 +1,6 @@ +(library + (name cppo_ocamlbuild) + (public_name cppo_ocamlbuild) + (wrapped false) + (synopsis "Cppo ocamlbuild plugin") + (libraries ocamlbuild)) diff --git a/tools/ocaml/duniverse/cppo/ocamlbuild_plugin/ocamlbuild_cppo.m= l b/tools/ocaml/duniverse/cppo/ocamlbuild_plugin/ocamlbuild_cppo.ml new file mode 100644 index 0000000000..f301c36240 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/ocamlbuild_plugin/ocamlbuild_cppo.ml @@ -0,0 +1,35 @@ + +open Ocamlbuild_plugin + +let cppo_rules ext =3D + let dep =3D "%(name).cppo"-.-ext + and prod1 =3D "%(name: <*> and not <*.cppo>)"-.-ext + and prod2 =3D "%(name: <**/*> and not <**/*.cppo>)"-.-ext in + let cppo_rule prod env _build =3D + let dep =3D env dep in + let prod =3D env prod in + let tags =3D tags_of_pathname prod ++ "cppo" in + Cmd (S[A "cppo"; T tags; S [A "-o"; P prod]; P dep ]) + in + rule ("cppo: *.cppo."-.-ext^" -> *."-.-ext) ~dep ~prod:prod1 (cppo_rule= prod1); + rule ("cppo: **/*.cppo."-.-ext^" -> **/*."-.-ext) ~dep ~prod:prod2 (cpp= o_rule prod2) + +let dispatcher =3D function + | After_rules -> begin + List.iter cppo_rules ["ml"; "mli"; "mlpack"]; + pflag ["cppo"] "cppo_D" (fun s -> S [A "-D"; A s]) ; + pflag ["cppo"] "cppo_U" (fun s -> S [A "-U"; A s]) ; + pflag ["cppo"] "cppo_I" (fun s -> + if Pathname.is_directory s then S [A "-I"; P s] + else S [A "-I"; P (Pathname.dirname s)] + ) ; + pdep ["cppo"] "cppo_I" (fun s -> + if Pathname.is_directory s then [] else [s]) ; + flag ["cppo"; "cppo_q"] (A "-q") ; + flag ["cppo"; "cppo_s"] (A "-s") ; + flag ["cppo"; "cppo_n"] (A "-n") ; + pflag ["cppo"] "cppo_x" (fun s -> S [A "-x"; A s]); + pflag ["cppo"] "cppo_V" (fun s -> S [A "-V"; A s]); + flag ["cppo"; "cppo_V_OCAML"] & S [A "-V"; A ("OCAML:" ^ Sys.ocaml_v= ersion)] + end + | _ -> () diff --git a/tools/ocaml/duniverse/cppo/ocamlbuild_plugin/ocamlbuild_cppo.m= li b/tools/ocaml/duniverse/cppo/ocamlbuild_plugin/ocamlbuild_cppo.mli new file mode 100644 index 0000000000..212435857f --- /dev/null +++ b/tools/ocaml/duniverse/cppo/ocamlbuild_plugin/ocamlbuild_cppo.mli @@ -0,0 +1,9 @@ + +(** [cppo_rules extension] will add rules to Ocamlbuild so that + cppo is applied to files ending in "cppo.[extension]". + + By default rules are inserted for files ending with "ml", "mli" and + "mlpack". *) +val cppo_rules : string -> unit + +val dispatcher : Ocamlbuild_plugin.hook -> unit diff --git a/tools/ocaml/duniverse/cppo/src/compat.ml b/tools/ocaml/duniver= se/cppo/src/compat.ml new file mode 100644 index 0000000000..5cd4a1b58d --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/compat.ml @@ -0,0 +1,7 @@ +if Filename.check_suffix Sys.argv.(1) ".ml" && + Scanf.sscanf Sys.ocaml_version "%d.%d" (fun a b -> (a, b)) < (4, 03) th= en + print_endline "\ +module String =3D struct + include String + let capitalize_ascii =3D capitalize +end" diff --git a/tools/ocaml/duniverse/cppo/src/cppo_command.ml b/tools/ocaml/d= universe/cppo/src/cppo_command.ml new file mode 100644 index 0000000000..5c61028c9a --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/cppo_command.ml @@ -0,0 +1,63 @@ +open Printf + +type command_token =3D + [ `Text of string + | `Loc_file + | `Loc_first_line + | `Loc_last_line ] + +type command_template =3D command_token list + +let parse s : command_template =3D + let rec loop acc buf s len i =3D + if i >=3D len then + let s =3D Buffer.contents buf in + if s =3D "" then acc + else `Text s :: acc + else if i =3D len - 1 then ( + Buffer.add_char buf s.[i]; + `Text (Buffer.contents buf) :: acc + ) + else + let c =3D s.[i] in + if c =3D '%' then + let acc =3D + let s =3D Buffer.contents buf in + Buffer.clear buf; + if s =3D "" then acc + else + `Text s :: acc + in + let x =3D + match s.[i+1] with + 'F' -> `Loc_file + | 'B' -> `Loc_first_line + | 'E' -> `Loc_last_line + | '%' -> `Text "%" + | _ -> + failwith ( + sprintf "Invalid escape sequence in command template %S.= \ + Use %%%% for a %% sign." s + ) + in + loop (x :: acc) buf s len (i + 2) + else ( + Buffer.add_char buf c; + loop acc buf s len (i + 1) + ) + in + let len =3D String.length s in + List.rev (loop [] (Buffer.create len) s len 0) + + +let subst (cmd : command_template) file first last =3D + let l =3D + List.map ( + function + `Text s -> s + | `Loc_file -> file + | `Loc_first_line -> string_of_int first + | `Loc_last_line -> string_of_int last + ) cmd + in + String.concat "" l diff --git a/tools/ocaml/duniverse/cppo/src/cppo_command.mli b/tools/ocaml/= duniverse/cppo/src/cppo_command.mli new file mode 100644 index 0000000000..af57d8cbfc --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/cppo_command.mli @@ -0,0 +1,11 @@ +type command_token =3D + [ `Text of string + | `Loc_file + | `Loc_first_line + | `Loc_last_line ] + +type command_template =3D command_token list + +val subst : command_template -> string -> int -> int -> string + +val parse : string -> command_template diff --git a/tools/ocaml/duniverse/cppo/src/cppo_eval.ml b/tools/ocaml/duni= verse/cppo/src/cppo_eval.ml new file mode 100644 index 0000000000..fb3f9de1e0 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/cppo_eval.ml @@ -0,0 +1,697 @@ +open Printf + +open Cppo_types + +module S =3D Set.Make (String) +module M =3D Map.Make (String) + +let builtins =3D [ + "__FILE__", (fun _env -> `Special); + "__LINE__", (fun _env -> `Special); + "STRINGIFY", (fun env -> + `Defun (dummy_loc, "STRINGIFY", + ["x"], + [`Stringify (`Ident (dummy_loc, "x", None))], + env) + ); + "CONCAT", (fun env -> + `Defun (dummy_loc, "CONCAT", + ["x";"y"], + [`Concat (`Ident (dummy_loc, "x", None), + `Ident (dummy_loc, "y", None))], + env) + ); + "CAPITALIZE", (fun env -> + `Defun (dummy_loc, "CAPITALIZE", + ["x"], + [`Capitalize (`Ident (dummy_loc, "x", None))], + env) + ); + +] + +let is_reserved s =3D + List.exists (fun (s', _) -> s =3D s') builtins + +let builtin_env =3D + List.fold_left (fun env (s, f) -> M.add s (f env) env) M.empty builtins + +let line_directive buf pos =3D + let len =3D Buffer.length buf in + if len > 0 && Buffer.nth buf (len - 1) <> '\n' then + Buffer.add_char buf '\n'; + bprintf buf "# %i %S\n" + pos.Lexing.pos_lnum + pos.Lexing.pos_fname; + bprintf buf "%s" (String.make (pos.Lexing.pos_cnum - pos.Lexing.pos_bol)= ' ') + +let rec add_sep sep last =3D function + [] -> [ last ] + | [x] -> [ x; last ] + | x :: l -> x :: sep :: add_sep sep last l + + +let remove_space l =3D + List.filter (function `Text (_, true, _) -> false | _ -> true) l + +let trim_and_compact buf s =3D + let started =3D ref false in + let need_space =3D ref false in + for i =3D 0 to String.length s - 1 do + match s.[i] with + ' ' | '\t' | '\n' | '\r' -> + if !started then + need_space :=3D true + | c -> + if !need_space then + Buffer.add_char buf ' '; + (match c with + '\"' -> Buffer.add_string buf "\\\"" + | '\\' -> Buffer.add_string buf "\\\\" + | c -> Buffer.add_char buf c); + started :=3D true; + need_space :=3D false + done + +let stringify buf s =3D + Buffer.add_char buf '\"'; + trim_and_compact buf s; + Buffer.add_char buf '\"' + +let trim_and_compact_string s =3D + let buf =3D Buffer.create (String.length s) in + trim_and_compact buf s; + Buffer.contents buf + +let trim_compact_and_capitalize_string s =3D + let buf =3D Buffer.create (String.length s) in + trim_and_compact buf s; + String.capitalize_ascii (Buffer.contents buf) + +let is_ident s =3D + let len =3D String.length s in + len > 0 + && + (match s.[0] with + 'A'..'Z' | 'a'..'z' -> true + | '_' when len > 1 -> true + | _ -> false) + && + (try + for i =3D 1 to len - 1 do + match s.[i] with + 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> () + | _ -> raise Exit + done; + true + with Exit -> + false) + +let concat loc x y =3D + let s =3D trim_and_compact_string x ^ trim_and_compact_string y in + if not (s =3D "" || is_ident s) then + error loc + (sprintf "CONCAT() does not expand into a valid identifier nor \ + into whitespace:\n%S" s) + else + if s =3D "" then " " + else " " ^ s ^ " " + +(* + Expand the contents of a variable used in a boolean expression. + + Ideally, we should first completely expand the contents bound + to the variable, and then parse the result as an int or an int tuple. + This is a bit complicated to do well, and we don't want to implement + a full programming language here either. + + Instead we only accept int literals, int tuple literals, and variables = that + themselves expand into one those. + + In particular: + - We do not support arithmetic operations + - We do not support tuples containing variables such as (x, y) + + Example of contents that we support: + - 123 + - (1, 2, 3) + - x, where x expands into 123. +*) +let rec eval_ident env loc name =3D + let l =3D + try + match M.find name env with + | `Def (_, _, l, _) -> l + | `Defun _ -> + error loc (sprintf "%S expects arguments" name) + | `Special -> assert false + with Not_found -> error loc (sprintf "Undefined identifier %S" name) + in + let expansion_error () =3D + error loc + (sprintf "\ +Variable %s found in cppo boolean expression must expand +into an int literal, into a tuple of int literals, +or into a variable with the same properties." + name) + in + (try + match remove_space l with + [ `Ident (loc, name, None) ] -> + (* single identifier that we expand recursively *) + eval_ident env loc name + | _ -> + (* int literal or int tuple literal; variables not allowed *) + let text =3D + List.map ( + function + `Text (_, _is_space, s) -> s + | _ -> + expansion_error () + ) (Cppo_types.flatten_nodes l) + in + let s =3D String.concat "" text in + (match Cppo_lexer.int_tuple_of_string s with + Some [i] -> `Int i + | Some l -> `Tuple (loc, List.map (fun i -> `Int i) l) + | None -> + expansion_error () + ) + with Cppo_error _ -> + expansion_error () + ) + +let rec replace_idents env (x : arith_expr) : arith_expr =3D + match x with + | `Ident (loc, name) -> eval_ident env loc name + + | `Int x -> `Int x + | `Neg x -> `Neg (replace_idents env x) + | `Add (a, b) -> `Add (replace_idents env a, replace_idents env b) + | `Sub (a, b) -> `Sub (replace_idents env a, replace_idents env b) + | `Mul (a, b) -> `Mul (replace_idents env a, replace_idents env b) + | `Div (loc, a, b) -> `Div (loc, replace_idents env a, replace_idents = env b) + | `Mod (loc, a, b) -> `Mod (loc, replace_idents env a, replace_idents = env b) + | `Lnot a -> `Lnot (replace_idents env a) + | `Lsl (a, b) -> `Lsl (replace_idents env a, replace_idents env b) + | `Lsr (a, b) -> `Lsr (replace_idents env a, replace_idents env b) + | `Asr (a, b) -> `Asr (replace_idents env a, replace_idents env b) + | `Land (a, b) -> `Land (replace_idents env a, replace_idents env b) + | `Lor (a, b) -> `Lor (replace_idents env a, replace_idents env b) + | `Lxor (a, b) -> `Lxor (replace_idents env a, replace_idents env b) + | `Tuple (loc, l) -> `Tuple (loc, List.map (replace_idents env) l) + +let rec eval_int env (x : arith_expr) : int64 =3D + match x with + | `Ident (loc, name) -> eval_int env (eval_ident env loc name) + + | `Int x -> x + | `Neg x -> Int64.neg (eval_int env x) + | `Add (a, b) -> Int64.add (eval_int env a) (eval_int env b) + | `Sub (a, b) -> Int64.sub (eval_int env a) (eval_int env b) + | `Mul (a, b) -> Int64.mul (eval_int env a) (eval_int env b) + | `Div (loc, a, b) -> + (try Int64.div (eval_int env a) (eval_int env b) + with Division_by_zero -> + error loc "Division by zero") + + | `Mod (loc, a, b) -> + (try Int64.rem (eval_int env a) (eval_int env b) + with Division_by_zero -> + error loc "Division by zero") + + | `Lnot a -> Int64.lognot (eval_int env a) + + | `Lsl (a, b) -> + let n =3D eval_int env a in + let shift =3D eval_int env b in + let shift =3D + if shift >=3D 64L then 64L + else if shift <=3D -64L then -64L + else shift + in + Int64.shift_left n (Int64.to_int shift) + + | `Lsr (a, b) -> + let n =3D eval_int env a in + let shift =3D eval_int env b in + let shift =3D + if shift >=3D 64L then 64L + else if shift <=3D -64L then -64L + else shift + in + Int64.shift_right_logical n (Int64.to_int shift) + + | `Asr (a, b) -> + let n =3D eval_int env a in + let shift =3D eval_int env b in + let shift =3D + if shift >=3D 64L then 64L + else if shift <=3D -64L then -64L + else shift + in + Int64.shift_right n (Int64.to_int shift) + + | `Land (a, b) -> Int64.logand (eval_int env a) (eval_int env b) + | `Lor (a, b) -> Int64.logor (eval_int env a) (eval_int env b) + | `Lxor (a, b) -> Int64.logxor (eval_int env a) (eval_int env b) + | `Tuple (loc, l) -> + assert (List.length l <> 1); + error loc "Operation not supported on tuples" + +let rec compare_lists al bl =3D + match al, bl with + | a :: al, b :: bl -> + let c =3D Int64.compare a b in + if c <> 0 then c + else compare_lists al bl + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + +let compare_tuples env (a : arith_expr) (b : arith_expr) =3D + (* We replace the identifiers first to get a better error message + on such input: + + #define x (1, 2) + #if x >=3D (1, 2) + + since variables must represent a single int, not a tuple. + *) + let a =3D replace_idents env a in + let b =3D replace_idents env b in + match a, b with + | `Tuple (_, al), `Tuple (_, bl) when List.length al =3D List.length bl = -> + let eval_list l =3D List.map (eval_int env) l in + compare_lists (eval_list al) (eval_list bl) + + | `Tuple (_loc1, al), `Tuple (loc2, bl) -> + error loc2 + (sprintf "Tuple of length %i cannot be compared to a tuple of leng= th %i" + (List.length bl) (List.length al) + ) + + | `Tuple (loc, _), _ + | _, `Tuple (loc, _) -> + error loc "Tuple cannot be compared to an int" + + | a, b -> + Int64.compare (eval_int env a) (eval_int env b) + +let rec eval_bool env (x : bool_expr) =3D + match x with + `True -> true + | `False -> false + | `Defined s -> M.mem s env + | `Not x -> not (eval_bool env x) + | `And (a, b) -> eval_bool env a && eval_bool env b + | `Or (a, b) -> eval_bool env a || eval_bool env b + | `Eq (a, b) -> compare_tuples env a b =3D 0 + | `Lt (a, b) -> compare_tuples env a b < 0 + | `Gt (a, b) -> compare_tuples env a b > 0 + + +type globals =3D { + call_loc : Cppo_types.loc; + (* location used to set the value of + __FILE__ and __LINE__ global variables *) + + mutable buf : Buffer.t; + (* buffer where the output is written *) + + included : S.t; + (* set of already-included files *) + + require_location : bool ref; + (* whether a line directive should be printed before outputting the ne= xt + token *) + + show_exact_locations : bool; + (* whether line directives should be printed even for expanded macro + bodies *) + + enable_loc : bool ref; + (* whether line directives should be printed *) + + g_preserve_quotations : bool; + (* identify and preserve camlp4 quotations *) + + incdirs : string list; + (* directories for finding included files *) + + current_directory : string; + (* directory containing the current file *) + + extensions : (string, Cppo_command.command_template) Hashtbl.t; + (* mapping from extension ID to pipeline command *) +} + + + +let parse ~preserve_quotations file lexbuf =3D + let lexer_env =3D Cppo_lexer.init ~preserve_quotations file lexbuf in + try + Cppo_parser.main (Cppo_lexer.line lexer_env) lexbuf + with + Parsing.Parse_error -> + error (Cppo_lexer.loc lexbuf) "syntax error" + | Cppo_types.Cppo_error _ as e -> + raise e + | e -> + error (Cppo_lexer.loc lexbuf) (Printexc.to_string e) + +let plural n =3D + if abs n <=3D 1 then "" + else "s" + + +let maybe_print_location g pos =3D + if !(g.enable_loc) then + if !(g.require_location) then ( + line_directive g.buf pos + ) + +let expand_ext g loc id data =3D + let cmd_tpl =3D + try Hashtbl.find g.extensions id + with Not_found -> + error loc (sprintf "Undefined extension %s" id) + in + let p1, p2 =3D loc in + let file =3D p1.Lexing.pos_fname in + let first =3D p1.Lexing.pos_lnum in + let last =3D p2.Lexing.pos_lnum in + let cmd =3D Cppo_command.subst cmd_tpl file first last in + Unix.putenv "CPPO_FILE" file; + Unix.putenv "CPPO_FIRST_LINE" (string_of_int first); + Unix.putenv "CPPO_LAST_LINE" (string_of_int last); + let (ic, oc) as p =3D Unix.open_process cmd in + output_string oc data; + close_out oc; + (try + while true do + bprintf g.buf "%s\n" (input_line ic) + done + with End_of_file -> () + ); + match Unix.close_process p with + Unix.WEXITED 0 -> () + | Unix.WEXITED n -> + failwith (sprintf "Command %S exited with status %i" cmd n) + | _ -> + failwith (sprintf "Command %S failed" cmd) + +let rec include_file g loc rel_file env =3D + let file =3D + if not (Filename.is_relative rel_file) then + if Sys.file_exists rel_file then + rel_file + else + error loc (sprintf "Included file %S does not exist" rel_file) + else + try + let dir =3D + List.find ( + fun dir -> + let file =3D Filename.concat dir rel_file in + Sys.file_exists file + ) (g.current_directory :: g.incdirs) + in + if dir =3D Filename.current_dir_name then + rel_file + else + Filename.concat dir rel_file + with Not_found -> + error loc (sprintf "Cannot find included file %S" rel_file) + in + if S.mem file g.included then + failwith (sprintf "Cyclic inclusion of file %S" file) + else + let ic =3D open_in file in + let lexbuf =3D Lexing.from_channel ic in + let l =3D parse ~preserve_quotations:g.g_preserve_quotations file lexb= uf in + close_in ic; + expand_list { g with + included =3D S.add file g.included; + current_directory =3D Filename.dirname file + } env l + +and expand_list ?(top =3D false) g env l =3D + List.fold_left (expand_node ~top g) env l + +and expand_node ?(top =3D false) g env0 (x : node) =3D + match x with + `Ident (loc, name, opt_args) -> + + let def =3D + try Some (M.find name env0) + with Not_found -> None + in + let g =3D + if top && def <> None || g.call_loc =3D=3D dummy_loc then + { g with call_loc =3D loc } + else g + in + + let enable_loc0 =3D !(g.enable_loc) in + + if def <> None then ( + g.require_location :=3D true; + + if not g.show_exact_locations then ( + (* error reports will point more or less to the point + where the code is included rather than the source location + of the macro definition *) + maybe_print_location g (fst loc); + g.enable_loc :=3D false + ) + ); + + let env =3D + match def, opt_args with + None, None -> + expand_node g env0 (`Text (loc, false, name)) + | None, Some args -> + let with_sep =3D + add_sep + [`Text (loc, false, ",")] + [`Text (loc, false, ")")] + args in + let l =3D + `Text (loc, false, name ^ "(") :: List.flatten with_sep = in + expand_list g env0 l + + | Some (`Defun (_, _, arg_names, _, _)), None -> + error loc + (sprintf "%S expects %i arguments but is applied to none= ." + name (List.length arg_names)) + + | Some (`Def _), Some _ -> + error loc + (sprintf "%S expects no arguments" name) + + | Some (`Def (_, _, l, env)), None -> + ignore (expand_list g env l); + env0 + + | Some (`Defun (_, _, arg_names, l, env)), Some args -> + let argc =3D List.length arg_names in + let n =3D List.length args in + let args =3D + (* it's ok to pass an empty arg if one arg + is expected *) + if n =3D 0 && argc =3D 1 then [[]] + else args + in + if argc <> n then + error loc + (sprintf "%S expects %i argument%s but is applied to \ + %i argument%s." + name argc (plural argc) n (plural n)) + else + let app_env =3D + List.fold_left2 ( + fun env name l -> + M.add name (`Def (loc, name, l, env0)) env + ) env arg_names args + in + ignore (expand_list g app_env l); + env0 + + | Some `Special, _ -> assert false + in + + if def =3D None then + g.require_location :=3D false + else + g.require_location :=3D true; + + (* restore initial setting *) + g.enable_loc :=3D enable_loc0; + + env + + + | `Def (loc, name, body)-> + g.require_location :=3D true; + if M.mem name env0 then + error loc (sprintf "%S is already defined" name) + else + M.add name (`Def (loc, name, body, env0)) env0 + + | `Defun (loc, name, arg_names, body) -> + g.require_location :=3D true; + if M.mem name env0 then + error loc (sprintf "%S is already defined" name) + else + M.add name (`Defun (loc, name, arg_names, body, env0)) env0 + + | `Undef (loc, name) -> + g.require_location :=3D true; + if is_reserved name then + error loc + (sprintf "%S is a built-in variable that cannot be undefined" = name) + else + M.remove name env0 + + | `Include (loc, file) -> + g.require_location :=3D true; + let env =3D include_file g loc file env0 in + g.require_location :=3D true; + env + + | `Ext (loc, id, data) -> + g.require_location :=3D true; + expand_ext g loc id data; + g.require_location :=3D true; + env0 + + | `Cond (_loc, test, if_true, if_false) -> + let l =3D + if eval_bool env0 test then if_true + else if_false + in + g.require_location :=3D true; + let env =3D expand_list g env0 l in + g.require_location :=3D true; + env + + | `Error (loc, msg) -> + error loc msg + + | `Warning (loc, msg) -> + warning loc msg; + env0 + + | `Text (loc, is_space, s) -> + if not is_space then ( + maybe_print_location g (fst loc); + g.require_location :=3D false + ); + Buffer.add_string g.buf s; + env0 + + | `Seq l -> + expand_list g env0 l + + | `Stringify x -> + let enable_loc0 =3D !(g.enable_loc) in + g.enable_loc :=3D false; + let buf0 =3D g.buf in + let local_buf =3D Buffer.create 100 in + g.buf <- local_buf; + ignore (expand_node g env0 x); + stringify buf0 (Buffer.contents local_buf); + g.buf <- buf0; + g.enable_loc :=3D enable_loc0; + env0 + + | `Capitalize (x : node) -> + let enable_loc0 =3D !(g.enable_loc) in + g.enable_loc :=3D false; + let buf0 =3D g.buf in + let local_buf =3D Buffer.create 100 in + g.buf <- local_buf; + ignore (expand_node g env0 x); + let xs =3D Buffer.contents local_buf in + let s =3D trim_compact_and_capitalize_string xs in + (* stringify buf0 (Buffer.contents local_buf); *) + Buffer.add_string buf0 s ; + g.buf <- buf0; + g.enable_loc :=3D enable_loc0; + env0 + | `Concat (x, y) -> + let enable_loc0 =3D !(g.enable_loc) in + g.enable_loc :=3D false; + let buf0 =3D g.buf in + let local_buf =3D Buffer.create 100 in + g.buf <- local_buf; + ignore (expand_node g env0 x); + let xs =3D Buffer.contents local_buf in + Buffer.clear local_buf; + ignore (expand_node g env0 y); + let ys =3D Buffer.contents local_buf in + let s =3D concat g.call_loc xs ys in + Buffer.add_string buf0 s; + g.buf <- buf0; + g.enable_loc :=3D enable_loc0; + env0 + + | `Line (loc, opt_file, n) -> + (* printing a line directive is not strictly needed *) + (match opt_file with + None -> + maybe_print_location g (fst loc); + bprintf g.buf "\n# %i\n" n + | Some file -> + bprintf g.buf "\n# %i %S\n" n file + ); + (* printing the location next time is needed because it just chang= ed *) + g.require_location :=3D true; + env0 + + | `Current_line loc -> + maybe_print_location g (fst loc); + g.require_location :=3D true; + let pos, _ =3D g.call_loc in + bprintf g.buf " %i " pos.Lexing.pos_lnum; + env0 + + | `Current_file loc -> + maybe_print_location g (fst loc); + g.require_location :=3D true; + let pos, _ =3D g.call_loc in + bprintf g.buf " %S " pos.Lexing.pos_fname; + env0 + + + + +let include_inputs + ~extensions + ~preserve_quotations + ~incdirs + ~show_exact_locations + ~show_no_locations + buf env l =3D + + let enable_loc =3D not show_no_locations in + List.fold_left ( + fun env (dir, file, open_, close) -> + let l =3D parse ~preserve_quotations file (open_ ()) in + close (); + let g =3D { + call_loc =3D dummy_loc; + buf =3D buf; + included =3D S.empty; + require_location =3D ref true; + show_exact_locations =3D show_exact_locations; + enable_loc =3D ref enable_loc; + g_preserve_quotations =3D preserve_quotations; + incdirs =3D incdirs; + current_directory =3D dir; + extensions =3D extensions; + } + in + expand_list ~top:true { g with included =3D S.add file g.included } = env l + ) env l diff --git a/tools/ocaml/duniverse/cppo/src/cppo_eval.mli b/tools/ocaml/dun= iverse/cppo/src/cppo_eval.mli new file mode 100644 index 0000000000..d4302f02d5 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/cppo_eval.mli @@ -0,0 +1,29 @@ +(** The type signatures in this module are not yet for public consumption. + + Please don't rely on them in any way.*) + +module S : Set.S with type elt =3D string +module M : Map.S with type key =3D string + +val builtin_env + : [> `Defun of + Cppo_types.loc * string * string list * + [> `Capitalize of Cppo_types.node + | `Concat of (Cppo_types.node * Cppo_types.node) + | `Stringify of Cppo_types.node ] list * 'a + | `Special ] M.t as 'a + +val include_inputs + : extensions:(string, Cppo_command.command_template) Hashtbl.t + -> preserve_quotations:bool + -> incdirs:string list + -> show_exact_locations:bool + -> show_no_locations:bool + -> Buffer.t + -> (([< `Def of Cppo_types.loc * string * Cppo_types.node list * 'a + | `Defun of Cppo_types.loc * string * string list * Cppo_types.node= list * 'a + | `Special + > `Def `Defun ] + as 'b) + M.t as 'a) + -> (string * string * (unit -> Lexing.lexbuf) * (unit -> unit)) list -> = 'a diff --git a/tools/ocaml/duniverse/cppo/src/cppo_lexer.mll b/tools/ocaml/du= niverse/cppo/src/cppo_lexer.mll new file mode 100644 index 0000000000..93ae9013d6 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/cppo_lexer.mll @@ -0,0 +1,721 @@ +{ +open Printf +open Lexing + +open Cppo_types +open Cppo_parser + +let pos1 lexbuf =3D lexbuf.lex_start_p +let pos2 lexbuf =3D lexbuf.lex_curr_p +let loc lexbuf =3D (pos1 lexbuf, pos2 lexbuf) + +let lexer_error lexbuf descr =3D + error (loc lexbuf) descr + +let new_file lb name =3D + lb.lex_curr_p <- { lb.lex_curr_p with pos_fname =3D name } + +let lex_new_lines lb =3D + let n =3D ref 0 in + let s =3D lb.lex_buffer in + for i =3D lb.lex_start_pos to lb.lex_curr_pos do + if Bytes.get s i =3D '\n' then + incr n + done; + let p =3D lb.lex_curr_p in + lb.lex_curr_p <- + { p with + pos_lnum =3D p.pos_lnum + !n; + pos_bol =3D p.pos_cnum + } + +let count_new_lines lb n =3D + let p =3D lb.lex_curr_p in + lb.lex_curr_p <- + { p with + pos_lnum =3D p.pos_lnum + n; + pos_bol =3D p.pos_cnum + } + +(* must start a new line *) +let update_pos lb p added_chars added_breaks =3D + let cnum =3D p.pos_cnum + added_chars in + lb.lex_curr_p <- + { pos_fname =3D p.pos_fname; + pos_lnum =3D p.pos_lnum + added_breaks; + pos_bol =3D cnum; + pos_cnum =3D cnum } + +let set_lnum lb opt_file lnum =3D + let p =3D lb.lex_curr_p in + let cnum =3D p.pos_cnum in + let fname =3D + match opt_file with + None -> p.pos_fname + | Some file -> file + in + lb.lex_curr_p <- + { pos_fname =3D fname; + pos_bol =3D cnum; + pos_cnum =3D cnum; + pos_lnum =3D lnum } + +let shift lb n =3D + let p =3D lb.lex_curr_p in + lb.lex_curr_p <- { p with pos_cnum =3D p.pos_cnum + n } + +let read_hexdigit c =3D + match c with + '0'..'9' -> Char.code c - 48 + | 'A'..'F' -> Char.code c - 55 + | 'a'..'z' -> Char.code c - 87 + | _ -> invalid_arg "read_hexdigit" + +let read_hex2 c1 c2 =3D + Char.chr (read_hexdigit c1 * 16 + read_hexdigit c2) + +type env =3D { + preserve_quotations : bool; + mutable lexer : [ `Ocaml | `Test ]; + mutable line_start : bool; + mutable in_directive : bool; (* true while processing a directive, until= the + final newline *) + buf : Buffer.t; + mutable token_start : Lexing.position; + lexbuf : Lexing.lexbuf; +} + +let new_line env =3D + env.line_start <- true; + count_new_lines env.lexbuf 1 + +let clear env =3D Buffer.clear env.buf + +let add env s =3D + env.line_start <- false; + Buffer.add_string env.buf s + +let add_char env c =3D + env.line_start <- false; + Buffer.add_char env.buf c + +let get env =3D Buffer.contents env.buf + +let long_loc e =3D (e.token_start, pos2 e.lexbuf) + +let cppo_directives =3D [ + "define"; + "elif"; + "else"; + "endif"; + "error"; + "if"; + "ifdef"; + "ifndef"; + "include"; + "undef"; + "warning"; +] + +let is_reserved_directive =3D + let tbl =3D Hashtbl.create 20 in + List.iter (fun s -> Hashtbl.add tbl s ()) cppo_directives; + fun s -> Hashtbl.mem tbl s + +} + +(* standard character classes used for macro identifiers *) +let upper =3D ['A'-'Z'] +let lower =3D ['a'-'z'] +let digit =3D ['0'-'9'] + +let identchar =3D upper | lower | digit | [ '_' '\'' ] + + +(* iso-8859-1 upper and lower characters used for ocaml identifiers *) +let oc_upper =3D ['A'-'Z' '\192'-'\214' '\216'-'\222'] +let oc_lower =3D ['a'-'z' '\223'-'\246' '\248'-'\255'] +let oc_identchar =3D oc_upper | oc_lower | digit | ['_' '\''] + +(* + Identifiers: ident is used for macro names and is a subset of oc_ident +*) +let ident =3D (lower | '_' identchar | upper) identchar* +let oc_ident =3D (oc_lower | '_' oc_identchar | oc_upper) oc_identchar* + + + +let hex =3D ['0'-'9' 'a'-'f' 'A'-'F'] +let oct =3D ['0'-'7'] +let bin =3D ['0'-'1'] + +let operator_char =3D + [ '!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=3D' '>' '?' '@' '^' '|' = '~'] +let infix_symbol =3D + ['=3D' '<' '>' '@' '^' '|' '&' '+' '-' '*' '/' '$' '%'] operator_char* +let prefix_symbol =3D ['!' '?' '~'] operator_char* + +let blank =3D [ ' ' '\t' ] +let space =3D [ ' ' '\t' '\r' '\n' ] + +let line =3D ( [^'\n'] | '\\' ('\r'? '\n') )* ('\n' | eof) + +let dblank0 =3D (blank | '\\' '\r'? '\n')* +let dblank1 =3D blank (blank | '\\' '\r'? '\n')* + +rule token e =3D parse + "" + { + (* + We use two different lexers for boolean expressions in #if direc= tives + and for regular OCaml tokens. + *) + match e.lexer with + `Ocaml -> ocaml_token e lexbuf + | `Test -> test_token e lexbuf + } + +and line e =3D parse + blank* "#" as s + { + match e.lexer with + `Test -> lexer_error lexbuf "Syntax error in boolean express= ion" + | `Ocaml -> + if e.line_start then ( + e.in_directive <- true; + clear e; + add e s; + e.token_start <- pos1 lexbuf; + e.line_start <- false; + directive e lexbuf + ) + else ( + e.line_start <- false; + clear e; + TEXT (loc lexbuf, false, s) + ) + } + + | "" { clear e; + token e lexbuf } + +and directive e =3D parse + blank* "define" dblank1 (ident as id) "(" + { DEFUN (long_loc e, id) } + + | blank* "define" dblank1 (ident as id) + { assert e.in_directive; + DEF (long_loc e, id) } + + | blank* "undef" dblank1 (ident as id) + { blank_until_eol e lexbuf; + UNDEF (long_loc e, id) } + + | blank* "if" dblank1 { e.lexer <- `Test; + IF (long_loc e) } + | blank* "elif" dblank1 { e.lexer <- `Test; + ELIF (long_loc e) } + + | blank* "ifdef" dblank1 (ident as id) + { blank_until_eol e lexbuf; + IFDEF (long_loc e, `Defined id) } + + | blank* "ifndef" dblank1 (ident as id) + { blank_until_eol e lexbuf; + IFDEF (long_loc e, `Not (`Defined id)) } + + | blank* "ext" dblank1 (ident as id) + { blank_until_eol e lexbuf; + clear e; + let s =3D read_ext e lexbuf in + EXT (long_loc e, id, s) } + + | blank* "define" dblank1 oc_ident + | blank* "undef" dblank1 oc_ident + | blank* "ifdef" dblank1 oc_ident + | blank* "ifndef" dblank1 oc_ident + | blank* "ext" dblank1 oc_ident + { error (loc lexbuf) + "Identifiers containing non-ASCII characters \ + may not be used as macro identifiers" } + + | blank* "else" + { blank_until_eol e lexbuf; + ELSE (long_loc e) } + + | blank* "endif" + { blank_until_eol e lexbuf; + ENDIF (long_loc e) } + + | blank* "include" dblank0 '"' + { clear e; + eval_string e lexbuf; + blank_until_eol e lexbuf; + INCLUDE (long_loc e, get e) } + + | blank* "error" dblank0 '"' + { clear e; + eval_string e lexbuf; + blank_until_eol e lexbuf; + ERROR (long_loc e, get e) } + + | blank* "warning" dblank0 '"' + { clear e; + eval_string e lexbuf; + blank_until_eol e lexbuf; + WARNING (long_loc e, get e) } + + | blank* (['0'-'9']+ as lnum) dblank0 '\r'? '\n' + { e.in_directive <- false; + new_line e; + let here =3D long_loc e in + let fname =3D None in + let lnum =3D int_of_string lnum in + (* Apply line directive regardless of possible #if condition. *) + set_lnum lexbuf fname lnum; + LINE (here, None, lnum) } + + | blank* (['0'-'9']+ as lnum) dblank0 '"' + { clear e; + eval_string e lexbuf; + blank_until_eol e lexbuf; + let here =3D long_loc e in + let fname =3D Some (get e) in + let lnum =3D int_of_string lnum in + (* Apply line directive regardless of possible #if condition. *) + set_lnum lexbuf fname lnum; + LINE (here, fname, lnum) } + + | blank* + { e.in_directive <- false; + add e (lexeme lexbuf); + TEXT (long_loc e, true, get e) } + + | blank* (['a'-'z']+ as s) + { if is_reserved_directive s then + error (loc lexbuf) "cppo directive with missing or wrong argumen= ts"; + e.in_directive <- false; + add e (lexeme lexbuf); + TEXT (long_loc e, false, get e) } + + +and blank_until_eol e =3D parse + blank* eof + | blank* '\r'? '\n' { new_line e; + e.in_directive <- false } + | "" { lexer_error lexbuf "syntax error in directive" } + +and read_ext e =3D parse + blank* "#" blank* "endext" blank* ('\r'? '\n' | eof) + { let s =3D get e in + clear e; + new_line e; + e.in_directive <- false; + s } + + | (blank* as a) "\\" ("#" blank* "endext" blank* '\r'? '\n' as b) + { add e a; + add e b; + new_line e; + read_ext e lexbuf } + + | [^'\n']* '\n' as x + { add e x; + new_line e; + read_ext e lexbuf } + + | eof + { lexer_error lexbuf "End of file within #ext ... #endext" } + +and ocaml_token e =3D parse + "__LINE__" + { e.line_start <- false; + CURRENT_LINE (loc lexbuf) } + + | "__FILE__" + { e.line_start <- false; + CURRENT_FILE (loc lexbuf) } + + | ident as s + { e.line_start <- false; + IDENT (loc lexbuf, s) } + + | oc_ident as s + { e.line_start <- false; + TEXT (loc lexbuf, false, s) } + + | ident as s "(" + { e.line_start <- false; + FUNIDENT (loc lexbuf, s) } + + | "'\n'" + | "'\r\n'" + { new_line e; + TEXT (loc lexbuf, false, lexeme lexbuf) } + + | "(" { e.line_start <- false; OP_PAREN (loc lexbuf) } + | ")" { e.line_start <- false; CL_PAREN (loc lexbuf) } + | "," { e.line_start <- false; COMMA (loc lexbuf) } + + | "\\)" { e.line_start <- false; TEXT (loc lexbuf, false, " )") } + | "\\," { e.line_start <- false; TEXT (loc lexbuf, false, " ,") } + | "\\(" { e.line_start <- false; TEXT (loc lexbuf, false, " (") } + | "\\#" { e.line_start <- false; TEXT (loc lexbuf, false, " #") } + + | '`' + | "!=3D" | "#" | "&" | "&&" | "(" | "*" | "+" | "-" + | "-." | "->" | "." | ".. :" | "::" | ":=3D" | ":>" | ";" | ";;" | "<" + | "<-" | "=3D" | ">" | ">]" | ">}" | "?" | "??" | "[" | "[<" | "[>" | "[= |" + | "]" | "_" | "`" | "{" | "{<" | "|" | "|]" | "}" | "~" + | ">>" + | prefix_symbol + | infix_symbol + | "'" ([^ '\'' '\\'] + | '\\' (_ | digit digit digit | 'x' hex hex)) "'" + + { e.line_start <- false; + TEXT (loc lexbuf, false, lexeme lexbuf) } + + | blank+ + { TEXT (loc lexbuf, true, lexeme lexbuf) } + + | '\\' ('\r'? '\n' as nl) + + { + new_line e; + if e.in_directive then + TEXT (loc lexbuf, true, nl) + else + TEXT (loc lexbuf, false, lexeme lexbuf) + } + + | '\r'? '\n' + { + new_line e; + if e.in_directive then ( + e.in_directive <- false; + ENDEF (loc lexbuf) + ) + else + TEXT (loc lexbuf, true, lexeme lexbuf) + } + + | "(*" + { clear e; + add e "(*"; + e.token_start <- pos1 lexbuf; + comment (loc lexbuf) e 1 lexbuf } + + | '"' + { clear e; + add e "\""; + e.token_start <- pos1 lexbuf; + string e lexbuf; + e.line_start <- false; + TEXT (long_loc e, false, get e) } + + | "<:" + | "<<" + { if e.preserve_quotations then ( + clear e; + add e (lexeme lexbuf); + e.token_start <- pos1 lexbuf; + quotation e lexbuf; + e.line_start <- false; + TEXT (long_loc e, false, get e) + ) + else ( + e.line_start <- false; + TEXT (loc lexbuf, false, lexeme lexbuf) + ) + } + + + | '-'? ( digit (digit | '_')* + | ("0x"| "0X") hex (hex | '_')* + | ("0o"| "0O") oct (oct | '_')* + | ("0b"| "0B") bin (bin | '_')* ) + + | '-'? digit (digit | '_')* ('.' (digit | '_')* )? + (['e' 'E'] ['+' '-']? digit (digit | '_')* )? + { e.line_start <- false; + TEXT (loc lexbuf, false, lexeme lexbuf) } + + | blank+ + { TEXT (loc lexbuf, true, lexeme lexbuf) } + + | _ + { e.line_start <- false; + TEXT (loc lexbuf, false, lexeme lexbuf) } + + | eof + { EOF } + + +and comment startloc e depth =3D parse + "(*" + { add e "(*"; + comment startloc e (depth + 1) lexbuf } + + | "*)" + { let depth =3D depth - 1 in + add e "*)"; + if depth > 0 then + comment startloc e depth lexbuf + else ( + e.line_start <- false; + TEXT (long_loc e, false, get e) + ) + } + | '"' + { add_char e '"'; + string e lexbuf; + comment startloc e depth lexbuf } + + | "'\n'" + | "'\r\n'" + { new_line e; + add e (lexeme lexbuf); + comment startloc e depth lexbuf } + + | "'" ([^ '\'' '\\'] + | '\\' (_ | digit digit digit | 'x' hex hex)) "'" + { add e (lexeme lexbuf); + comment startloc e depth lexbuf } + + | '\r'? '\n' + { + new_line e; + add e (lexeme lexbuf); + comment startloc e depth lexbuf + } + + | [^'(' '*' '"' '\'' '\r' '\n']+ + { + add e (lexeme lexbuf); + comment startloc e depth lexbuf + } + + | _ + { add e (lexeme lexbuf); + comment startloc e depth lexbuf } + + | eof + { error startloc "Unterminated comment reaching the end of file" } + + +and string e =3D parse + '"' + { add_char e '"' } + + | "\\\\" + | '\\' '"' + { add e (lexeme lexbuf); + string e lexbuf } + + | '\\' '\r'? '\n' + { + add e (lexeme lexbuf); + new_line e; + string e lexbuf + } + + | '\r'? '\n' + { + if e.in_directive then + lexer_error lexbuf "Unterminated string literal" + else ( + add e (lexeme lexbuf); + new_line e; + string e lexbuf + ) + } + + | _ as c + { add_char e c; + string e lexbuf } + + | eof + { } + + +and eval_string e =3D parse + '"' + { } + + | '\\' (['\'' '\"' '\\'] as c) + { add_char e c; + eval_string e lexbuf } + + | '\\' '\r'? '\n' + { assert e.in_directive; + eval_string e lexbuf } + + | '\r'? '\n' + { assert e.in_directive; + lexer_error lexbuf "Unterminated string literal" } + + | '\\' (digit digit digit as s) + { add_char e (Char.chr (int_of_string s)); + eval_string e lexbuf } + + | '\\' 'x' (hex as c1) (hex as c2) + { add_char e (read_hex2 c1 c2); + eval_string e lexbuf } + + | '\\' 'b' + { add_char e '\b'; + eval_string e lexbuf } + + | '\\' 'n' + { add_char e '\n'; + eval_string e lexbuf } + + | '\\' 'r' + { add_char e '\r'; + eval_string e lexbuf } + + | '\\' 't' + { add_char e '\t'; + eval_string e lexbuf } + + | [^ '\"' '\\']+ + { add e (lexeme lexbuf); + eval_string e lexbuf } + + | eof + { lexer_error lexbuf "Unterminated string literal" } + + +and quotation e =3D parse + ">>" + { add e ">>" } + + | "\\>>" + { add e "\\>>"; + quotation e lexbuf } + + | '\\' '\r'? '\n' + { + if e.in_directive then ( + new_line e; + quotation e lexbuf + ) + else ( + add e (lexeme lexbuf); + new_line e; + quotation e lexbuf + ) + } + + | '\r'? '\n' + { + if e.in_directive then + lexer_error lexbuf "Unterminated quotation" + else ( + add e (lexeme lexbuf); + new_line e; + quotation e lexbuf + ) + } + + | [^'>' '\\' '\r' '\n']+ + { add e (lexeme lexbuf); + quotation e lexbuf } + + | eof + { lexer_error lexbuf "Unterminated quotation" } + +and test_token e =3D parse + "true" { TRUE } + | "false" { FALSE } + | "defined" { DEFINED } + | "(" { OP_PAREN (loc lexbuf) } + | ")" { CL_PAREN (loc lexbuf) } + | "&&" { AND } + | "||" { OR } + | "not" { NOT } + | "=3D" { EQ } + | "<" { LT } + | ">" { GT } + | "<>" { NE } + | "<=3D" { LE } + | ">=3D" { GE } + + | '-'? ( digit (digit | '_')* + | ("0x"| "0X") hex (hex | '_')* + | ("0o"| "0O") oct (oct | '_')* + | ("0b"| "0B") bin (bin | '_')* ) + { let s =3D Lexing.lexeme lexbuf in + try INT (Int64.of_string s) + with _ -> + error (loc lexbuf) + (sprintf "Integer constant %s is out the valid range for int64= " s) + } + + | "+" { PLUS } + | "-" { MINUS } + | "*" { STAR } + | "/" { SLASH (loc lexbuf) } + | "mod" { MOD (loc lexbuf) } + | "lsl" { LSL } + | "lsr" { LSR } + | "asr" { ASR } + | "land" { LAND } + | "lor" { LOR } + | "lxor" { LXOR } + | "lnot" { LNOT } + + | "," { COMMA (loc lexbuf) } + + | ident + { IDENT (loc lexbuf, lexeme lexbuf) } + + | blank+ { test_token e lexbuf } + | '\\' '\r'? '\n' { new_line e; + test_token e lexbuf } + | '\r'? '\n' + | eof { assert e.in_directive; + e.in_directive <- false; + new_line e; + e.lexer <- `Ocaml; + ENDTEST (loc lexbuf) } + | _ { error (loc lexbuf) + (sprintf "Invalid token %s" (Lexing.lexeme lexbuf)) } + + +(* Parse just an int or a tuple of ints *) +and int_tuple =3D parse + | space* (([^'(']#space)+ as s) space* eof + { [Int64.of_string s] } + + | space* "(" { int_tuple_content lexbuf } + + | eof | _ { failwith "Not an int nor a tuple" } + +and int_tuple_content =3D parse + | space* (([^',' ')']#space)+ as s) space* "," + { let x =3D Int64.of_string s in + x :: int_tuple_content lexbuf } + + | space* (([^',' ')']#space)+ as s) space* ")" space* eof + { [Int64.of_string s] } + + +{ + let init ~preserve_quotations file lexbuf =3D + new_file lexbuf file; + { + preserve_quotations =3D preserve_quotations; + lexer =3D `Ocaml; + line_start =3D true; + in_directive =3D false; + buf =3D Buffer.create 200; + token_start =3D Lexing.dummy_pos; + lexbuf =3D lexbuf; + } + + let int_tuple_of_string s =3D + try Some (int_tuple (Lexing.from_string s)) + with _ -> None +} diff --git a/tools/ocaml/duniverse/cppo/src/cppo_main.ml b/tools/ocaml/duni= verse/cppo/src/cppo_main.ml new file mode 100644 index 0000000000..93dd6477e4 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/cppo_main.ml @@ -0,0 +1,230 @@ +open Printf + +let add_extension tbl s =3D + let i =3D + try String.index s ':' + with Not_found -> + failwith "Invalid -x argument" + in + let id =3D String.sub s 0 i in + let raw_tpl =3D String.sub s (i+1) (String.length s - i - 1) in + let cmd_tpl =3D Cppo_command.parse raw_tpl in + if Hashtbl.mem tbl id then + failwith ("Multiple definitions for extension " ^ id) + else + Hashtbl.add tbl id cmd_tpl + +let semver_re =3D Str.regexp "\ +\\([0-9]+\\)\ +\\.\\([0-9]+\\)\ +\\.\\([0-9]+\\)\ +\\([~-]\\([^+]*\\)\\)?\ +\\(\\+\\(.*\\)\\)?\ +\r?$" + +let parse_semver s =3D + if not (Str.string_match semver_re s 0) then + None + else + let major =3D Str.matched_group 1 s in + let minor =3D Str.matched_group 2 s in + let patch =3D Str.matched_group 3 s in + let prerelease =3D try Some (Str.matched_group 5 s) with Not_found -> = None in + let build =3D try Some (Str.matched_group 7 s) with Not_found -> None = in + Some (major, minor, patch, prerelease, build) + +let define var s =3D + [sprintf "#define %s %s\n" var s] + +let opt_define var o =3D + match o with + | None -> [] + | Some s -> define var s + +let parse_version_spec s =3D + let error () =3D + failwith (sprintf "Invalid version specification: %S" s) + in + let prefix, version_full =3D + try + let len =3D String.index s ':' in + String.sub s 0 len, String.sub s (len+1) (String.length s - (len+1)) + with Not_found -> + error () + in + match parse_semver version_full with + | None -> + error () + | Some (major, minor, patch, opt_prerelease, opt_build) -> + let version =3D sprintf "(%s, %s, %s)" major minor patch in + let version_string =3D sprintf "%s.%s.%s" major minor patch in + List.flatten [ + define (prefix ^ "_MAJOR") major; + define (prefix ^ "_MINOR") minor; + define (prefix ^ "_PATCH") patch; + opt_define (prefix ^ "_PRERELEASE") opt_prerelease; + opt_define (prefix ^ "_BUILD") opt_build; + define (prefix ^ "_VERSION") version; + define (prefix ^ "_VERSION_STRING") version_string; + define (prefix ^ "_VERSION_FULL") s; + ] + +let main () =3D + let extensions =3D Hashtbl.create 10 in + let files =3D ref [] in + let header =3D ref [] in + let incdirs =3D ref [] in + let out_file =3D ref None in + let preserve_quotations =3D ref false in + let show_exact_locations =3D ref false in + let show_no_locations =3D ref false in + let options =3D [ + "-D", Arg.String (fun s -> header :=3D ("#define " ^ s ^ "\n") :: !hea= der), + "DEF + Equivalent of interpreting '#define DEF' before processing the + input, e.g. `cppo -D 'VERSION \"1.2.3\"'` (no equal sign)"; + + "-U", Arg.String (fun s -> header :=3D ("#undef " ^ s ^ "\n") :: !head= er), + "IDENT + Equivalent of interpreting '#undef IDENT' before processing the + input"; + + "-I", Arg.String (fun s -> incdirs :=3D s :: !incdirs), + "DIR + Add directory DIR to the search path for included files"; + + "-V", Arg.String (fun s -> header :=3D parse_version_spec s @ !header), + "VAR:MAJOR.MINOR.PATCH-OPTPRERELEASE+OPTBUILD + Define the following variables extracted from a version string + (following the Semantic Versioning syntax http://semver.org/): + + VAR_MAJOR must be a non-negative int + VAR_MINOR must be a non-negative int + VAR_PATCH must be a non-negative int + VAR_PRERELEASE if the OPTPRERELEASE part exists + VAR_BUILD if the OPTBUILD part exists + VAR_VERSION is the tuple (MAJOR, MINOR, PATCH) + VAR_VERSION_STRING is the string MAJOR.MINOR.PATCH + VAR_VERSION_FULL is the original string + + Example: cppo -V OCAML:4.02.1 + + Note that cppo recognises both '-' and '~' preceding the pre-rel= ease + meaning -V OCAML:4.11.0+alpha1 sets OCAML_BUILD to alpha1 but + -V OCAML:4.12.0~alpha1 sets OCAML_PRERELEASE to alpha1. +"; + + "-o", Arg.String (fun s -> out_file :=3D Some s), + "FILE + Output file"; + + "-q", Arg.Set preserve_quotations, + " + Identify and preserve camlp4 quotations"; + + "-s", Arg.Set show_exact_locations, + " + Output line directives pointing to the exact source location of + each token, including those coming from the body of macro + definitions. This behavior is off by default."; + + "-n", Arg.Set show_no_locations, + " + Do not output any line directive other than those found in the + input (overrides -s)."; + + "-version", Arg.Unit (fun () -> + print_endline Cppo_version.cppo_version; + exit 0), + " + Print the version of the program and exit."; + + "-x", Arg.String (fun s -> add_extension extensions s), + "NAME:CMD_TEMPLATE + Define a custom preprocessor target section starting with: + #ext \"NAME\" + and ending with: + #endext + + NAME must be a lowercase identifier of the form [a-z][A-Za-z0-9_= ]* + + CMD_TEMPLATE is a command template supporting the following + special sequences: + %F file name (unescaped; beware of potential scripting attack= s) + %B number of the first line + %E number of the last line + %% a single percent sign + + Filename, first line number and last line number are also + available from the following environment variables: + CPPO_FILE, CPPO_FIRST_LINE, CPPO_LAST_LINE. + + The command produced is expected to read the data lines from std= in + and to write its output to stdout." + ] + in + let msg =3D sprintf "\ +Usage: %s [OPTIONS] [FILE1 [FILE2 ...]] +Options:" Sys.argv.(0) in + let add_file s =3D files :=3D s :: !files in + Arg.parse options add_file msg; + + let inputs =3D + let preliminaries =3D + match List.rev !header with + [] -> [] + | l -> + let s =3D String.concat "" l in + [ Sys.getcwd (), + "", + (fun () -> Lexing.from_string s), + (fun () -> ()) ] + in + let main =3D + match List.rev !files with + [] -> [ Sys.getcwd (), + "", + (fun () -> Lexing.from_channel stdin), + (fun () -> ()) ] + | l -> + List.map ( + fun file -> + let ic =3D lazy (open_in file) in + Filename.dirname file, + file, + (fun () -> Lexing.from_channel (Lazy.force ic)), + (fun () -> close_in (Lazy.force ic)) + ) l + in + preliminaries @ main + in + + let env =3D Cppo_eval.builtin_env in + let buf =3D Buffer.create 10_000 in + let _env =3D + Cppo_eval.include_inputs + ~extensions + ~preserve_quotations: !preserve_quotations + ~incdirs: (List.rev !incdirs) + ~show_exact_locations: !show_exact_locations + ~show_no_locations: !show_no_locations + buf env inputs + in + match !out_file with + None -> + print_string (Buffer.contents buf); + flush stdout + | Some file -> + let oc =3D open_out file in + output_string oc (Buffer.contents buf); + close_out oc + +let () =3D + if not !Sys.interactive then + try + main () + with + | Cppo_types.Cppo_error msg + | Failure msg -> + eprintf "Error: %s\n%!" msg; + exit 1 diff --git a/tools/ocaml/duniverse/cppo/src/cppo_parser.mly b/tools/ocaml/d= universe/cppo/src/cppo_parser.mly new file mode 100644 index 0000000000..21d2cddb30 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/cppo_parser.mly @@ -0,0 +1,266 @@ +%{ + open Cppo_types +%} + +/* Directives */ +%token < Cppo_types.loc * string > DEF DEFUN UNDEF INCLUDE WARNING ERROR +%token < Cppo_types.loc * string option * int > LINE +%token < Cppo_types.loc * Cppo_types.bool_expr > IFDEF +%token < Cppo_types.loc * string * string > EXT +%token < Cppo_types.loc > ENDEF IF ELIF ELSE ENDIF ENDTEST + +/* Boolean expressions in #if/#elif directives */ +%token TRUE FALSE DEFINED NOT AND OR EQ LT GT NE LE GE + PLUS MINUS STAR LNOT LSL LSR ASR LAND LOR LXOR +%token < Cppo_types.loc > OP_PAREN SLASH MOD +%token < int64 > INT + + +/* Regular program and shared terminals */ +%token < Cppo_types.loc > CL_PAREN COMMA CURRENT_LINE CURRENT_FILE +%token < Cppo_types.loc * string > IDENT FUNIDENT +%token < Cppo_types.loc * bool * string > TEXT /* bool means "is space" */ +%token EOF + +/* Priorities for boolean expressions */ +%left OR +%left AND + +/* Priorities for arithmetics */ +%left PLUS MINUS +%left STAR SLASH +%left MOD LSL LSR ASR LAND LOR LXOR +%nonassoc NOT +%nonassoc LNOT +%nonassoc UMINUS + +%start main +%type < Cppo_types.node list > main +%% + +main: +| unode main { $1 :: $2 } +| EOF { [] } +; + +unode_list0: +| unode unode_list0 { $1 :: $2 } +| { [] } +; + +pnode_list0: +| pnode pnode_list0 { $1 :: $2 } +| { [] } +; + +/* node in which opening and closing parentheses don't need to match */ +unode: +| node { $1 } +| OP_PAREN { `Text ($1, false, "(") } +| CL_PAREN { `Text ($1, false, ")") } +| COMMA { `Text ($1, false, ",") } +; + +/* node in which parentheses must be closed */ +pnode: +| node { $1 } +| OP_PAREN pnode_or_comma_list0 CL_PAREN + { `Seq [`Text ($1, false, "("); + `Seq $2; + `Text ($3, false, ")")] } +; + +/* node without parentheses handling (need to use unode or pnode) */ +node: +| TEXT { `Text $1 } + +| IDENT { let loc, name =3D $1 in + `Ident (loc, name, None) } + +| FUNIDENT args1 CL_PAREN + { + (* macro application that receives at least one argument, + possibly empty. We cannot distinguish syntactically be= tween + zero argument and one empty argument. + *) + let (pos1, _), name =3D $1 in + let _, pos2 =3D $3 in + `Ident ((pos1, pos2), name, Some $2) } +| FUNIDENT error + { error (fst $1) "Invalid macro application" } + +| CURRENT_LINE { `Current_line $1 } +| CURRENT_FILE { `Current_file $1 } + +| DEF unode_list0 ENDEF + { let (pos1, _), name =3D $1 in + + (* Additional spacing is needed for cases like '+foo+' + expanding into '++' instead of '+ +'. *) + let safe_space =3D `Text ($3, true, " ") in + + let body =3D $2 @ [safe_space] in + let _, pos2 =3D $3 in + `Def ((pos1, pos2), name, body) } + +| DEFUN def_args1 CL_PAREN unode_list0 ENDEF + { let (pos1, _), name =3D $1 in + let args =3D $2 in + + (* Additional spacing is needed for cases like 'foo()bar' + where 'foo()' expands into 'abc', giving 'abcbar' + instead of 'abc bar'; + Also needed for '+foo()+' expanding into '++' instead + of '+ +'. *) + let safe_space =3D `Text ($5, true, " ") in + + let body =3D $4 @ [safe_space] in + let _, pos2 =3D $5 in + `Defun ((pos1, pos2), name, args, body) } + +| DEFUN CL_PAREN + { error (fst (fst $1), snd $2) + "At least one argument is required" } + +| UNDEF + { `Undef $1 } +| WARNING + { `Warning $1 } +| ERROR + { `Error $1 } + +| INCLUDE + { `Include $1 } + +| EXT + { `Ext $1 } + +| IF test unode_list0 elif_list ENDIF + { let pos1, _ =3D $1 in + let _, pos2 =3D $5 in + let loc =3D (pos1, pos2) in + let test =3D $2 in + let if_true =3D $3 in + let if_false =3D + List.fold_right ( + fun (loc, test, if_true) if_false -> + [`Cond (loc, test, if_true, if_false) ] + ) $4 [] + in + `Cond (loc, test, if_true, if_false) + } + +| IF test unode_list0 elif_list error + { (* BUG? ocamlyacc fails to reduce that rule but not menh= ir *) + error $1 "missing #endif" } + +| IFDEF unode_list0 elif_list ENDIF + { let (pos1, _), test =3D $1 in + let _, pos2 =3D $4 in + let loc =3D (pos1, pos2) in + let if_true =3D $2 in + let if_false =3D + List.fold_right ( + fun (loc, test, if_true) if_false -> + [`Cond (loc, test, if_true, if_false) ] + ) $3 [] + in + `Cond (loc, test, if_true, if_false) + } + +| IFDEF unode_list0 elif_list error + { error (fst $1) "missing #endif" } + +| LINE { `Line $1 } +; + + +elif_list: + ELIF test unode_list0 elif_list + { let pos1, _ =3D $1 in + let pos2 =3D Parsing.rhs_end_pos 4 in + ((pos1, pos2), $2, $3) :: $4 } +| ELSE unode_list0 + { let pos1, _ =3D $1 in + let pos2 =3D Parsing.rhs_end_pos 2 in + [ ((pos1, pos2), `True, $2) ] } +| { [] } +; + +args1: + pnode_list0 COMMA args1 { $1 :: $3 } +| pnode_list0 { [ $1 ] } +; + +pnode_or_comma_list0: +| pnode pnode_or_comma_list0 { $1 :: $2 } +| COMMA pnode_or_comma_list0 { `Text ($1, false, ",") :: $2 } +| { [] } +; + +def_args1: +| arg_blank IDENT COMMA def_args1 + { (snd $2) :: $4 } +| arg_blank IDENT { [ snd $2 ] } +; + +arg_blank: +| TEXT arg_blank { let loc, is_space, _s =3D $1 in + if not is_space then + error loc "Invalid argument list" + } +| { () } +; + +test: + bexpr ENDTEST { $1 } +; + +/* Boolean expressions after #if or #elif */ +bexpr: + | TRUE { `True } + | FALSE { `False } + | DEFINED IDENT { `Defined (snd $2) } + | OP_PAREN bexpr CL_PAREN { $2 } + | NOT bexpr { `Not $2 } + | bexpr AND bexpr { `And ($1, $3) } + | bexpr OR bexpr { `Or ($1, $3) } + | aexpr EQ aexpr { `Eq ($1, $3) } + | aexpr LT aexpr { `Lt ($1, $3) } + | aexpr GT aexpr { `Gt ($1, $3) } + | aexpr NE aexpr { `Not (`Eq ($1, $3)) } + | aexpr LE aexpr { `Not (`Gt ($1, $3)) } + | aexpr GE aexpr { `Not (`Lt ($1, $3)) } +; + +/* Arithmetic expressions within boolean expressions */ +aexpr: + | INT { `Int $1 } + | IDENT { `Ident $1 } + | OP_PAREN aexpr_list CL_PAREN + { match $2 with + | [x] -> x + | l -> + let pos1, _ =3D $1 in + let _, pos2 =3D $3 in + `Tuple ((pos1, pos2), l) + } + | aexpr PLUS aexpr { `Add ($1, $3) } + | aexpr MINUS aexpr { `Sub ($1, $3) } + | aexpr STAR aexpr { `Mul ($1, $3) } + | aexpr SLASH aexpr { `Div ($2, $1, $3) } + | aexpr MOD aexpr { `Mod ($2, $1, $3) } + | aexpr LSL aexpr { `Lsl ($1, $3) } + | aexpr LSR aexpr { `Lsr ($1, $3) } + | aexpr ASR aexpr { `Asr ($1, $3) } + | aexpr LAND aexpr { `Land ($1, $3) } + | aexpr LOR aexpr { `Lor ($1, $3) } + | aexpr LXOR aexpr { `Lxor ($1, $3) } + | LNOT aexpr { `Lnot $2 } + | MINUS aexpr %prec UMINUS { `Neg $2 } +; + +aexpr_list: + | aexpr COMMA aexpr_list { $1 :: $3 } + | aexpr { [$1] } +; diff --git a/tools/ocaml/duniverse/cppo/src/cppo_types.ml b/tools/ocaml/dun= iverse/cppo/src/cppo_types.ml new file mode 100644 index 0000000000..d6428d8101 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/cppo_types.ml @@ -0,0 +1,98 @@ +open Printf +open Lexing + +module String_set =3D Set.Make (String) +module String_map =3D Map.Make (String) + +type loc =3D position * position + +type bool_expr =3D + [ `True + | `False + | `Defined of string + | `Not of bool_expr (* not *) + | `And of (bool_expr * bool_expr) (* && *) + | `Or of (bool_expr * bool_expr) (* || *) + | `Eq of (arith_expr * arith_expr) (* =3D *) + | `Lt of (arith_expr * arith_expr) (* < *) + | `Gt of (arith_expr * arith_expr) (* > *) + (* syntax for additional operators: <>, <=3D, >=3D *) + ] + +and arith_expr =3D (* signed int64 *) + [ `Int of int64 + | `Ident of (loc * string) + (* must be bound to a valid int literal. + Expansion of macro functions is not supported. *) + + | `Tuple of (loc * arith_expr list) + (* tuple of 2 or more elements guaranteed by the syntax *) + + | `Neg of arith_expr (* - *) + | `Add of (arith_expr * arith_expr) (* + *) + | `Sub of (arith_expr * arith_expr) (* - *) + | `Mul of (arith_expr * arith_expr) (* * *) + | `Div of (loc * arith_expr * arith_expr) (* / *) + | `Mod of (loc * arith_expr * arith_expr) (* mod *) + + (* Bitwise operations on 64 bits *) + | `Lnot of arith_expr (* lnot *) + | `Lsl of (arith_expr * arith_expr) (* lsl *) + | `Lsr of (arith_expr * arith_expr) (* lsr *) + | `Asr of (arith_expr * arith_expr) (* asr *) + | `Land of (arith_expr * arith_expr) (* land *) + | `Lor of (arith_expr * arith_expr) (* lor *) + | `Lxor of (arith_expr * arith_expr) (* lxor *) + ] + +and node =3D + [ `Ident of (loc * string * node list list option) + | `Def of (loc * string * node list) + | `Defun of (loc * string * string list * node list) + | `Undef of (loc * string) + | `Include of (loc * string) + | `Ext of (loc * string * string) + | `Cond of (loc * bool_expr * node list * node list) + | `Error of (loc * string) + | `Warning of (loc * string) + | `Text of (loc * bool * string) (* bool is true for space tokens *) + | `Seq of node list + | `Stringify of node + | `Capitalize of node + | `Concat of (node * node) + | `Line of (loc * string option * int) + | `Current_line of loc + | `Current_file of loc ] + + + +let string_of_loc (pos1, pos2) =3D + let line1 =3D pos1.pos_lnum + and start1 =3D pos1.pos_bol in + Printf.sprintf "File %S, line %i, characters %i-%i" + pos1.pos_fname line1 + (pos1.pos_cnum - start1) + (pos2.pos_cnum - start1) + + +exception Cppo_error of string + +let error loc s =3D + let msg =3D + sprintf "%s\nError: %s" (string_of_loc loc) s in + raise (Cppo_error msg) + +let warning loc s =3D + let msg =3D + sprintf "%s\nWarning: %s" (string_of_loc loc) s in + eprintf "%s\n%!" msg + +let dummy_loc =3D (Lexing.dummy_pos, Lexing.dummy_pos) + +let rec flatten_nodes (l: node list): node list =3D + List.flatten (List.map flatten_node l) + +and flatten_node (node: node): node list =3D + match node with + | `Seq l -> flatten_nodes l + | x -> [x] diff --git a/tools/ocaml/duniverse/cppo/src/cppo_types.mli b/tools/ocaml/du= niverse/cppo/src/cppo_types.mli new file mode 100644 index 0000000000..f3b54235e9 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/cppo_types.mli @@ -0,0 +1,70 @@ +type loc =3D Lexing.position * Lexing.position + +exception Cppo_error of string + +type bool_expr =3D + [ `True + | `False + | `Defined of string + | `Not of bool_expr (* not *) + | `And of (bool_expr * bool_expr) (* && *) + | `Or of (bool_expr * bool_expr) (* || *) + | `Eq of (arith_expr * arith_expr) (* =3D *) + | `Lt of (arith_expr * arith_expr) (* < *) + | `Gt of (arith_expr * arith_expr) (* > *) + (* syntax for additional operators: <>, <=3D, >=3D *) + ] + +and arith_expr =3D (* signed int64 *) + [ `Int of int64 + | `Ident of (loc * string) + (* must be bound to a valid int literal. + Expansion of macro functions is not supported. *) + + | `Tuple of (loc * arith_expr list) + (* tuple of 2 or more elements guaranteed by the syntax *) + + | `Neg of arith_expr (* - *) + | `Add of (arith_expr * arith_expr) (* + *) + | `Sub of (arith_expr * arith_expr) (* - *) + | `Mul of (arith_expr * arith_expr) (* * *) + | `Div of (loc * arith_expr * arith_expr) (* / *) + | `Mod of (loc * arith_expr * arith_expr) (* mod *) + + (* Bitwise operations on 64 bits *) + | `Lnot of arith_expr (* lnot *) + | `Lsl of (arith_expr * arith_expr) (* lsl *) + | `Lsr of (arith_expr * arith_expr) (* lsr *) + | `Asr of (arith_expr * arith_expr) (* asr *) + | `Land of (arith_expr * arith_expr) (* land *) + | `Lor of (arith_expr * arith_expr) (* lor *) + | `Lxor of (arith_expr * arith_expr) (* lxor *) + ] + +and node =3D + [ `Ident of (loc * string * node list list option) + | `Def of (loc * string * node list) + | `Defun of (loc * string * string list * node list) + | `Undef of (loc * string) + | `Include of (loc * string) + | `Ext of (loc * string * string) + | `Cond of (loc * bool_expr * node list * node list) + | `Error of (loc * string) + | `Warning of (loc * string) + | `Text of (loc * bool * string) (* bool is true for space tokens *) + | `Seq of node list + | `Stringify of node + | `Capitalize of node + | `Concat of (node * node) + | `Line of (loc * string option * int) + | `Current_line of loc + | `Current_file of loc ] + +val dummy_loc : loc + +val error : loc -> string -> _ + +val warning : loc -> string -> unit + +val flatten_nodes : node list -> node list + diff --git a/tools/ocaml/duniverse/cppo/src/cppo_version.mli b/tools/ocaml/= duniverse/cppo/src/cppo_version.mli new file mode 100644 index 0000000000..7d20f68da6 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/cppo_version.mli @@ -0,0 +1 @@ +val cppo_version : string diff --git a/tools/ocaml/duniverse/cppo/src/dune b/tools/ocaml/duniverse/cp= po/src/dune new file mode 100644 index 0000000000..8cf871b460 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/src/dune @@ -0,0 +1,21 @@ +(ocamllex cppo_lexer) + +(ocamlyacc cppo_parser) + +(rule + (targets cppo_version.ml) + (action + (with-stdout-to + %{targets} + (echo "let cppo_version =3D \"%{version:cppo}\"")))) + +(executable + (name cppo_main) + (package cppo) + (public_name cppo) + (modules :standard \ compat) + (preprocess (per_module + ((action (progn + (run ocaml %{dep:compat.ml} %{input-file}) + (cat %{input-file}))) cppo_eval))) + (libraries unix str)) diff --git a/tools/ocaml/duniverse/cppo/test/capital.cppo b/tools/ocaml/dun= iverse/cppo/test/capital.cppo new file mode 100644 index 0000000000..fa85caae4e --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/capital.cppo @@ -0,0 +1,6 @@ + + +#define EVENT(n,ty) external CONCAT(on,CAPITALIZE(n)) : ty =3D STRINGIFY(n= ) [@@bs.val]=20 + + +EVENT(exit, unit -> unit) \ No newline at end of file diff --git a/tools/ocaml/duniverse/cppo/test/capital.ref b/tools/ocaml/duni= verse/cppo/test/capital.ref new file mode 100644 index 0000000000..adcc26e251 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/capital.ref @@ -0,0 +1,6 @@ + + + + +# 6 "capital.cppo" + external onExit : unit -> unit =3D "exit" [@@bs.val] =20 \ No newline at end of file diff --git a/tools/ocaml/duniverse/cppo/test/comments.cppo b/tools/ocaml/du= niverse/cppo/test/comments.cppo new file mode 100644 index 0000000000..5e335f1c3b --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/comments.cppo @@ -0,0 +1,7 @@ +(* '"' *) + +#define BE_GONE + +(* "*)" +#define DONT_TOUCH_THIS +*) diff --git a/tools/ocaml/duniverse/cppo/test/comments.ref b/tools/ocaml/dun= iverse/cppo/test/comments.ref new file mode 100644 index 0000000000..1d0dd1db64 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/comments.ref @@ -0,0 +1,8 @@ +# 1 "comments.cppo" +(* '"' *) + + +# 5 "comments.cppo" +(* "*)" +#define DONT_TOUCH_THIS +*) diff --git a/tools/ocaml/duniverse/cppo/test/cond.cppo b/tools/ocaml/dunive= rse/cppo/test/cond.cppo new file mode 100644 index 0000000000..b5f0c49ac4 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/cond.cppo @@ -0,0 +1,47 @@ +#if 1 =3D 1 +#else +#error "ignored #else (?)" +#endif + +#if true + banana +#elif false + apple + #error "ignored #elif (?)" +#endif + +#if false + earthworm + #error "" +#elif true + apricot +#endif + +#if false + cuckoo + #error "" +#else + #if false + egg + #error "" + #else + nest + #endif +#endif + +#define X 3 + +#if false + helicopter + #error "" +#elif false + ocean + #error "" +#else + #if X =3D 12 + sand + #error "" + #elif 4 * X =3D 12 + sea urchin + #endif +#endif diff --git a/tools/ocaml/duniverse/cppo/test/cond.ref b/tools/ocaml/duniver= se/cppo/test/cond.ref new file mode 100644 index 0000000000..a21ea217bf --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/cond.ref @@ -0,0 +1,17 @@ + + =20 +# 7 "cond.cppo" + banana + + =20 +# 17 "cond.cppo" + apricot + + =20 +# 28 "cond.cppo" + nest + + + =20 +# 45 "cond.cppo" + sea urchin diff --git a/tools/ocaml/duniverse/cppo/test/dune b/tools/ocaml/duniverse/c= ppo/test/dune new file mode 100644 index 0000000000..a7fab7bbfb --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/dune @@ -0,0 +1,130 @@ +(rule + (targets ext.out) + (deps + (:< ext.cppo) + source.sh) + (action + (with-stdout-to + %{targets} + (run %{bin:cppo} -x "rot13:tr '[a-z]' '[n-za-m]'" -x + "source:sh source.sh '%F' %B %E" %{<})))) + +(rule + (targets comments.out) + (deps + (:< comments.cppo)) + (action + (with-stdout-to + %{targets} + (run %{bin:cppo} %{<})))) + +(rule + (targets cond.out) + (deps + (:< cond.cppo)) + (action + (with-stdout-to + %{targets} + (run %{bin:cppo} %{<})))) + +(rule + (targets tuple.out) + (deps + (:< tuple.cppo)) + (action + (with-stdout-to + %{targets} + (run %{bin:cppo} %{<})))) + +(rule + (targets loc.out) + (deps + (:< loc.cppo)) + (action + (with-stdout-to + %{targets} + (run %{bin:cppo} %{<})))) + +(rule + (targets paren_arg.out) + (deps + (:< paren_arg.cppo)) + (action + (with-stdout-to + %{targets} + (run %{bin:cppo} %{<})))) + +(rule + (targets unmatched.out) + (deps + (:< unmatched.cppo)) + (action + (with-stdout-to + %{targets} + (run %{bin:cppo} %{<})))) + +(rule + (targets version.out) + (deps + (:< version.cppo)) + (action + (with-stdout-to + %{targets} + (run %{bin:cppo} -V X:123.05.2-alpha.1+foo-2.1 %{<})))) + +(alias + (name runtest) + (package cppo) + (action + (diff ext.ref ext.out))) + +(alias + (name runtest) + (package cppo) + (action + (diff comments.ref comments.out))) + +(alias + (name runtest) + (package cppo) + (action + (diff cond.ref cond.out))) + +(alias + (name runtest) + (package cppo) + (action + (diff tuple.ref tuple.out))) + +(alias + (name runtest) + (package cppo) + (action + (diff loc.ref loc.out))) + +(alias + (name runtest) + (package cppo) + (action + (diff paren_arg.ref paren_arg.out))) + +(alias + (name runtest) + (package cppo) + (deps version.out)) + +(alias + (name runtest) + (package cppo) + (action + (diff unmatched.ref unmatched.out))) + +(alias + (name runtest) + (package cppo) + (deps + (:< test.cppo) + incl.cppo + incl2.cppo) + (action + (ignore-stdout (run %{bin:cppo} %{<})))) diff --git a/tools/ocaml/duniverse/cppo/test/ext.cppo b/tools/ocaml/duniver= se/cppo/test/ext.cppo new file mode 100644 index 0000000000..cb32573f67 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/ext.cppo @@ -0,0 +1,10 @@ +hello +#ext rot13 +abc +\#endext +def +#endext +goodbye + +#ext source +#endext diff --git a/tools/ocaml/duniverse/cppo/test/ext.ref b/tools/ocaml/dunivers= e/cppo/test/ext.ref new file mode 100644 index 0000000000..4626b21481 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/ext.ref @@ -0,0 +1,28 @@ +# 1 "ext.cppo" +hello +nop +#raqrkg +qrs +# 7 "ext.cppo" +goodbye + +# 9 +(* +hello +#ext rot13 +abc +\#endext +def +#endext +goodbye + +#ext source +#endext +*) +(* + Environment variables: + CPPO_FILE=3Dext.cppo + CPPO_FIRST_LINE=3D9 + CPPO_LAST_LINE=3D11 +*) +# 11 diff --git a/tools/ocaml/duniverse/cppo/test/incl.cppo b/tools/ocaml/dunive= rse/cppo/test/incl.cppo new file mode 100644 index 0000000000..a2ce8dbb36 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/incl.cppo @@ -0,0 +1,3 @@ +included + +#include "incl2.cppo" diff --git a/tools/ocaml/duniverse/cppo/test/incl2.cppo b/tools/ocaml/duniv= erse/cppo/test/incl2.cppo new file mode 100644 index 0000000000..9766475a41 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/incl2.cppo @@ -0,0 +1 @@ +ok diff --git a/tools/ocaml/duniverse/cppo/test/loc.cppo b/tools/ocaml/duniver= se/cppo/test/loc.cppo new file mode 100644 index 0000000000..d7c2c521f3 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/loc.cppo @@ -0,0 +1,8 @@ +#define loc __FILE__ __LINE__ +loc +X(loc) +X(loc) +X(Y(loc)) + +#define F(x) loc +F() diff --git a/tools/ocaml/duniverse/cppo/test/loc.ref b/tools/ocaml/dunivers= e/cppo/test/loc.ref new file mode 100644 index 0000000000..78bbfb72bd --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/loc.ref @@ -0,0 +1,21 @@ +# 2 "loc.cppo" + "loc.cppo" 2 =20 +# 3 "loc.cppo" +X( +# 3 "loc.cppo" + "loc.cppo" 3 =20 +# 3 "loc.cppo" +) +X( +# 4 "loc.cppo" + "loc.cppo" 4 =20 +# 4 "loc.cppo" +) +X(Y( +# 5 "loc.cppo" + "loc.cppo" 5 =20 +# 5 "loc.cppo" + )) + +# 8 "loc.cppo" + "loc.cppo" 8 =20 diff --git a/tools/ocaml/duniverse/cppo/test/paren_arg.cppo b/tools/ocaml/d= universe/cppo/test/paren_arg.cppo new file mode 100644 index 0000000000..f4c4803eb4 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/paren_arg.cppo @@ -0,0 +1,3 @@ +#define F(x, y) +F((1, (2)), 34) +F((1\,\(2\)), 34) diff --git a/tools/ocaml/duniverse/cppo/test/paren_arg.ref b/tools/ocaml/du= niverse/cppo/test/paren_arg.ref new file mode 100644 index 0000000000..6555ca0569 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/paren_arg.ref @@ -0,0 +1,4 @@ +# 2 "paren_arg.cppo" + <(1, (2))> < 34>=20 +# 3 "paren_arg.cppo" + <(1 , (2 ))> < 34>=20 diff --git a/tools/ocaml/duniverse/cppo/test/source.sh b/tools/ocaml/dunive= rse/cppo/test/source.sh new file mode 100755 index 0000000000..660d161ab2 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/source.sh @@ -0,0 +1,13 @@ +#! /bin/sh -e + +echo "# $2" +echo "(*" +cat "$1" +echo "*)" +echo "(*" +echo " Environment variables:" +echo " CPPO_FILE=3D$CPPO_FILE" +echo " CPPO_FIRST_LINE=3D$CPPO_FIRST_LINE" +echo " CPPO_LAST_LINE=3D$CPPO_LAST_LINE" +echo "*)" +echo "# $3" diff --git a/tools/ocaml/duniverse/cppo/test/test.cppo b/tools/ocaml/dunive= rse/cppo/test/test.cppo new file mode 100644 index 0000000000..89756f7ca0 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/test.cppo @@ -0,0 +1,144 @@ +(* comment *) + +#define pi 3.14 +f(1) +#define f(x) x+pi +f(2) +#undef pi +f(3) + +#ifdef g +"g" is defined +#else +"g" is not defined +#endif + +#define a(x) b() +#define b(x) a() +a() + +debug("a") +debug("b") + +#define z 123 +#define y z +#define x y + +#if x lsl 1 =3D 2*123 + +#if 1 =3D 2 +#error "test" +#endif + +success +#else +failure +#endif + +#define test_multiline \ +"abc\ + def" \ +(* 123 \ + 456 *) +test_multiline + +#define test_args(x, y) x y +test_args("a","b") + +#define test_argc(x) x y +test_argc(aa\,bb) + +#define test_esc(x) x +test_esc(\,\)\() + +blah #define xyz +#ifdef xyz +#error "xyz should not have been defined" +#endif + +#define sticky1(x) _ +#define sticky2(x) sticky1()_ (* the 2 underscores should be space-separat= ed *) +sticky2() + +#define empty1 +#define empty2 +empty1+ (* there should be some space between the pluses *) +empty2 + +(* (* nested comment with single single quote: ' *) "*)" *) + +#define arg +obj + \# define arg + +' (* lone single quote *) + +#define one 1 +one is not 1 + +#undef x +#define x # +x is # + +#undef one +#define one 1 +#if (one+one =3D 100 + \ + 64 lsr 3 / 4 - lnot lnot 100) && \ + 1 + 3 * 5 =3D 16 && \ + 22 mod 7 =3D 1 && \ + lnot 0 =3D 0xffffffffffffffff && \ + -1 asr 100 =3D -1 && \ + -1 land (1 lsl 1 lsr 1) =3D 1 && \ + -1 lor 1 =3D -1 && \ + -2 lxor 1 =3D -1 && \ + lnot -1 =3D 0 && \ + true && not false && defined one && \ + (true || true && false) +good maths +#else +#error "math error" +#endif + + +#undef f +#undef g +#undef x +#undef y + +#define trace(f) \ +let f x =3D \ + printf "call %s\n%!" STRINGIFY(f); \ + let y =3D f x in \ + printf "return %s\n%!" STRINGIFY(f); \ + y \ +;; + +trace(g) + +#define field(name,type) \ + val mutable name : type option \ + method CONCAT(get_, name) =3D name \ + method CONCAT(set_, name) x =3D name <- Some x + +class foo () =3D +object + field(field_1, int) + field(field_2, string) +end + +#define DEBUG(x) \ + (if !debug then \ + eprintf "[debug] %s %i: " __FILE__ __LINE__; \ + eprintf x; \ + eprintf "\n") +DEBUG("test1 %i %i" x y) +DEBUG("test2 %i" x) + +#include "incl.cppo" +# 123456 + +#789 "test" +#include "incl.cppo" + +#define debug(s) Printf.eprintf "%S %i: %s\n%!" __FILE__ __LINE__ s + +end diff --git a/tools/ocaml/duniverse/cppo/test/tuple.cppo b/tools/ocaml/duniv= erse/cppo/test/tuple.cppo new file mode 100644 index 0000000000..57423b89a9 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/tuple.cppo @@ -0,0 +1,38 @@ +#if (2 + 2, 5) < (4, 5) + mountain + #error "" +#else + pistachios +#endif + +#if (3 * 3) =3D 10 - 1 + trees +#else + rocks + #error "" +#endif + +#if (1) =3D (1) + waves +#else + sharks + #error "" +#endif + + +#define x 11 +#if (x, 2) <> (x, 4/2) + honey + #error "" +#else + bees +#endif + +#define tuple (0, -5, 3) +#define tuple2 tuple +#if (0, -5, x) > tuple2 + steamboat +#else + koalas + #error "" +#endif diff --git a/tools/ocaml/duniverse/cppo/test/tuple.ref b/tools/ocaml/dunive= rse/cppo/test/tuple.ref new file mode 100644 index 0000000000..58df976ef5 --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/tuple.ref @@ -0,0 +1,20 @@ + =20 +# 5 "tuple.cppo" + pistachios + + =20 +# 9 "tuple.cppo" + trees + + =20 +# 16 "tuple.cppo" + waves + + + =20 +# 28 "tuple.cppo" + bees + + =20 +# 34 "tuple.cppo" + steamboat diff --git a/tools/ocaml/duniverse/cppo/test/unmatched.cppo b/tools/ocaml/d= universe/cppo/test/unmatched.cppo new file mode 100644 index 0000000000..470cbd44be --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/unmatched.cppo @@ -0,0 +1,14 @@ +#ifdef whatever + ( +#else + let a =3D 1 in + let b =3D 2 in + (a || +#endif + + b) + +#define F(x, y) (x + y) +F(1,(2+3)) +) +( diff --git a/tools/ocaml/duniverse/cppo/test/unmatched.ref b/tools/ocaml/du= niverse/cppo/test/unmatched.ref new file mode 100644 index 0000000000..ff2356a57d --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/unmatched.ref @@ -0,0 +1,15 @@ + =20 +# 4 "unmatched.cppo" + let a =3D 1 in + let b =3D 2 in + (a || + + =20 +# 9 "unmatched.cppo" + b) + +# 12 "unmatched.cppo" + (1 + (2+3))=20 +# 13 "unmatched.cppo" +) +( diff --git a/tools/ocaml/duniverse/cppo/test/version.cppo b/tools/ocaml/dun= iverse/cppo/test/version.cppo new file mode 100644 index 0000000000..ee4e429b6a --- /dev/null +++ b/tools/ocaml/duniverse/cppo/test/version.cppo @@ -0,0 +1,30 @@ +#if X_VERSION < (123, 0, 0) + alligators + #error "" +#else + Cape buffalos +#endif + +#define v X_VERSION +#if v =3D (X_MAJOR, X_MINOR, X_PATCH) + onion rings +#else + gazpacho + #error "" +#endif + +major: X_MAJOR +minor: X_MINOR +patch: X_PATCH + +#ifdef X_PRERELEASE + prerelease: X_PRERELEASE +#else + #error "" +#endif + +#ifdef X_BUILD + build: X_BUILD +#else + #error "" +#endif diff --git a/tools/ocaml/duniverse/crowbar/.gitignore b/tools/ocaml/duniver= se/crowbar/.gitignore new file mode 100644 index 0000000000..ffee22e516 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/.gitignore @@ -0,0 +1,5 @@ +_build +crowbar.install +*.byte +*.native +.merlin diff --git a/tools/ocaml/duniverse/crowbar/CHANGES.md b/tools/ocaml/duniver= se/crowbar/CHANGES.md new file mode 100644 index 0000000000..df24660c5e --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/CHANGES.md @@ -0,0 +1,9 @@ +v0.2 (04 May 2020) +--------------------- + +New generators, printers and port to dune. + +v0.1 (01 February 2018) +--------------------- + +Initial release diff --git a/tools/ocaml/duniverse/crowbar/LICENSE.md b/tools/ocaml/duniver= se/crowbar/LICENSE.md new file mode 100644 index 0000000000..848fd3e059 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/LICENSE.md @@ -0,0 +1,8 @@ +Copyright (c) 2017 Stephen Dolan + +Permission is hereby granted, free of charge, to any person obtaining a co= py of this software and associated documentation files (the "Software"), to= deal in the Software without restriction, including without limitation the= rights to use, copy, modify, merge, publish, distribute, sublicense, and/o= r sell copies of the Software, and to permit persons to whom the Software i= s furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in= all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR= IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, F= ITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE = AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIAB= ILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, O= UT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN TH= E SOFTWARE. + diff --git a/tools/ocaml/duniverse/crowbar/README.md b/tools/ocaml/dunivers= e/crowbar/README.md new file mode 100644 index 0000000000..6938adaf6a --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/README.md @@ -0,0 +1,82 @@ +# Crowbar + +**Crowbar** is a library for testing code, combining QuickCheck-style + property-based testing and the magical bug-finding powers of + [afl-fuzz](http://lcamtuf.coredump.cx/afl/). + +## TL;DR + +There are [some examples](./examples). + +Some brief hints: + +1. Use an opam switch with AFL instrumentation enabled (e.g. `opam sw 4.04= .0+afl`). +2. Run in AFL mode with `afl-fuzz -i in -o out -- ./_build/myprog.exe @@`. +3. If you run your executable without arguments, crowbar will perform some= simple (non-AFL) testing instead. +4. Test binaries have a small amount of documentation, available with `--h= elp`. + +## writing tests + +To test your software, come up with a property you'd like to test, then de= cide on the input you'd like for Crowbar to vary. A Crowbar test is some i= nvocation of `Crowbar.check_eq` or `Crowbar.check`: + +```ocaml +let identity x =3D + Crowbar.check_eq x x +``` + +and instructions for running the test with generated items with `Crowbar.a= dd_test`: + +```ocaml +let () =3D + Crowbar.(add_test ~name:"identity function" [int] (fun i -> identity i)) +``` + +There are [more examples available](./examples), with varying levels compl= exity. + +## building tests + +Include `crowbar` in your list of dependencies via your favorite build sys= tem. The resulting executable is a Crowbar test. (Be sure to build a nati= ve-code executable, not bytecode.) + +To build tests that run under AFL, you'll need to build your tests with a = compiler that has AFL instrumentation enabled. (You can also enable it spe= cifically for your build, although this is not recommended if your code has= any dependencies, including the OCaml standard library). OCaml compiler v= ariants with AFL enabled by default are available in `opam` with the `+afl`= tag. All versions published starting with 4.05.0 are available, along wit= h a backported 4.04.0. + +```shell +$ opam switch 4.06.0+afl +$ eval `opam config env` +$ ./build_my_rad_test.sh # or your relevant build runes +``` + +## running Tests + +Crowbar tests have two modes: + +* a simple quickcheck-like mode for testing propositions against totally r= andom input +* a mode using [afl-persistent](https://github.com/stedolan/ocaml-afl-pers= istent) to get good performance from `afl-fuzz` with OCaml's instrumentatio= n enabled + +Crowbar tests can be directly invoked with `--help` for more documentation= at runtime. + +### fully random test mode + +If you wish to use the quickcheck-like, fully random mode to run all tests= distributed here, build the tests as above and then run the binary with no= arguments. + +``` +$ ./my_rad_test.exe | head -5 +the first test: PASS + +the second test: PASS +``` + +### AFL mode requirements + +To run the tests in AFL mode, you'll need to install American Fuzzy Lop ([= latest source tarball](http://lcamtuf.coredump.cx/afl/releases/afl-latest.t= gz), although your distribution may also have a package available). + +Once `afl-fuzz` is available on your system, create an `input` directory w= ith a non-empty file in it (or use `test/input`, conveniently provided in t= his repository), and an `output` directory for `afl-fuzz` to store its find= ings. Then, invoke your test binary: + +``` +afl-fuzz -i test/input -o output ./my_rad_test.exe @@ +``` + +This will launch AFL, which will generate new test cases and track the exp= loration of the state space. When inputs are discovered which cause a prop= erty not to hold, they will be reported as crashes (along with actual crash= es, although in the OCaml standard library these are rare). See the [afl-f= uzz documentation](https://lcamtuf.coredump.cx/afl/status_screen.txt) for m= ore on AFL's excellent interface. + +# What bugs have you found? + +[An open issue](https://github.com/stedolan/crowbar/issues/2) has a list o= f issues discovered by testing with Crowbar. If you use Crowbar to improve= your software, please let us know! diff --git a/tools/ocaml/duniverse/crowbar/crowbar.opam b/tools/ocaml/duniv= erse/crowbar/crowbar.opam new file mode 100644 index 0000000000..bff15f564a --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/crowbar.opam @@ -0,0 +1,33 @@ +opam-version: "2.0" +maintainer: "stephen.dolan@cl.cam.ac.uk" +authors: ["Stephen Dolan"] +homepage: "https://github.com/stedolan/crowbar" +bug-reports: "https://github.com/stedolan/crowbar/issues" +dev-repo: "git+https://github.com/stedolan/crowbar.git" +license: "MIT" +build: [ + [ "dune" "build" "-p" name "-j" jobs ] +] +run-test: [ + [ "dune" "runtest" "-p" name "-j" jobs ] +] +depends: [ + "dune" {build & >=3D "1.1"} + "ocaml" {>=3D "4.02.0"} + "ocplib-endian" + "cmdliner" + "afl-persistent" {>=3D "1.1"} + "calendar" {with-test} + "xmldiff" {with-test} + "fpath" {with-test} + "pprint" {with-test & < "20180528"} + "uucp" {with-test} + "uunf" {with-test} + "uutf" {with-test} +] +synopsis: "Write tests, let a fuzzer find failing cases" +description: """ +Crowbar is a library for testing code, combining QuickCheck-style +property-based testing and the magical bug-finding powers of +[afl-fuzz](http://lcamtuf.coredump.cx/afl/). +""" diff --git a/tools/ocaml/duniverse/crowbar/dune b/tools/ocaml/duniverse/cro= wbar/dune new file mode 100644 index 0000000000..8daec202b7 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/dune @@ -0,0 +1 @@ +(env (dev (flags (:standard -warn-error -A)))) diff --git a/tools/ocaml/duniverse/crowbar/dune-project b/tools/ocaml/duniv= erse/crowbar/dune-project new file mode 100644 index 0000000000..12d75f30c8 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.1) +(name crowbar) diff --git a/tools/ocaml/duniverse/crowbar/examples/.gitignore b/tools/ocam= l/duniverse/crowbar/examples/.gitignore new file mode 100644 index 0000000000..53752db253 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/.gitignore @@ -0,0 +1 @@ +output diff --git a/tools/ocaml/duniverse/crowbar/examples/calendar/dune b/tools/o= caml/duniverse/crowbar/examples/calendar/dune new file mode 100644 index 0000000000..e5fdd8f1df --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/calendar/dune @@ -0,0 +1,3 @@ +(test + (name test_calendar) + (libraries crowbar calendar)) diff --git a/tools/ocaml/duniverse/crowbar/examples/calendar/test_calendar.= ml b/tools/ocaml/duniverse/crowbar/examples/calendar/test_calendar.ml new file mode 100644 index 0000000000..788e96a7dc --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/calendar/test_calendar.ml @@ -0,0 +1,29 @@ +open Crowbar + +module C =3D CalendarLib.Calendar.Precise + +let time =3D + map [int64] (fun a -> + try + C.from_mjd (Int64.to_float a /. 100_000_000_000_000.) + with + CalendarLib.Date.Out_of_bounds -> bad_test ()) + +let pp_time ppf t =3D + pp ppf "%04d-%02d-%02d %02d:%02d:%02d" + (C.year t) + (C.month t |> C.Date.int_of_month) + (C.day_of_month t) + (C.hour t) + (C.minute t) + (C.second t) +let time =3D with_printer pp_time time + +let period =3D + map [const 0;const 0;int8;int8;int8;int8] C.Period.make + + +let () =3D + add_test ~name:"calendar" [time; time] @@ fun t1 t2 -> + guard (C.compare t1 t2 < 0); + check_eq ~pp:pp_time ~eq:C.equal (C.add t1 (C.precise_sub t2 t1)) t2 diff --git a/tools/ocaml/duniverse/crowbar/examples/fpath/dune b/tools/ocam= l/duniverse/crowbar/examples/fpath/dune new file mode 100644 index 0000000000..b6050be6f7 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/fpath/dune @@ -0,0 +1,4 @@ +(test + (name test_fpath) + (modules test_fpath) + (libraries crowbar fpath)) diff --git a/tools/ocaml/duniverse/crowbar/examples/fpath/test_fpath.ml b/t= ools/ocaml/duniverse/crowbar/examples/fpath/test_fpath.ml new file mode 100644 index 0000000000..242ffc399d --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/fpath/test_fpath.ml @@ -0,0 +1,18 @@ +open Crowbar +open Astring +open Fpath +let fpath =3D + map [bytes] (fun s -> + try + v s + with + Invalid_argument _ -> bad_test ()) + + +let () =3D + add_test ~name:"segs" [fpath] @@ fun p -> + let np =3D normalize p in + assert (is_dir_path p =3D is_dir_path np); + assert (is_file_path p =3D is_file_path np); + assert (filename p =3D filename np); + check_eq ~eq:equal p (v @@ (fst @@ split_volume p) ^ (String.concat ~s= ep:dir_sep (segs p))) diff --git a/tools/ocaml/duniverse/crowbar/examples/input/testcase b/tools/= ocaml/duniverse/crowbar/examples/input/testcase new file mode 100644 index 0000000000..8bd6648ed1 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/input/testcase @@ -0,0 +1 @@ +asdf diff --git a/tools/ocaml/duniverse/crowbar/examples/map/dune b/tools/ocaml/= duniverse/crowbar/examples/map/dune new file mode 100644 index 0000000000..04fa46113b --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/map/dune @@ -0,0 +1,3 @@ +(test + (name test_map) + (libraries crowbar)) diff --git a/tools/ocaml/duniverse/crowbar/examples/map/test_map.ml b/tools= /ocaml/duniverse/crowbar/examples/map/test_map.ml new file mode 100644 index 0000000000..b60603614a --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/map/test_map.ml @@ -0,0 +1,47 @@ +open Crowbar + +module Map =3D Map.Make (struct + type t =3D int + let compare (i : int) (j : int) =3D compare i j +end) + +type t =3D ((int * int) list * int Map.t) + +let check_map ((list, map) : t) =3D + let rec dedup k =3D function + | [] -> [] + | (k', v') :: rest when k =3D k' -> dedup k rest + | (k', v') :: rest -> + (k', v') :: dedup k' rest in + let list =3D match List.stable_sort (fun a b -> compare (fst a) (fst b))= list with + | [] -> [] + | (k, v) :: rest -> (k, v) :: dedup k rest in + List.for_all (fun (k, v) -> Map.find k map =3D v) list && + list =3D Map.bindings map + +let map_gen : t gen =3D fix (fun map_gen -> choose [ + const ([], Map.empty); + map [uint8; uint8; map_gen] (fun k v (l, m) -> + (k, v) :: l, Map.add k v m); + map [uint8; uint8] (fun k v -> + [k, v], Map.singleton k v); + map [uint8; map_gen] (fun k (l, m) -> + let rec rem_all k l =3D + let l' =3D List.remove_assoc k l in + if l =3D l' then l else rem_all k l' in + rem_all k l, Map.remove k m); + (* merge? *) + map [map_gen; map_gen] (fun (l, m) (l', m') -> + l @ l', Map.union (fun k a b -> Some a) m m'); + map [uint8; map_gen] (fun k (list, map) -> + let (l, v, r) =3D Map.split k map in + let (l', vr') =3D List.partition (fun (kx,vx) -> kx < k) list in + let r' =3D List.filter (fun (kx, vx) -> kx <> k) vr' in + let v' =3D match List.assoc k vr' with n -> Some n | exception Not_fou= nd -> None in + assert (v =3D v'); + (l' @ List.map (fun (k,v) -> k,v+42) r', + Map.union (fun k a b -> assert false) l (Map.map (fun v -> v + 42) r)= ))]) + +let () =3D + add_test ~name:"map" [map_gen] @@ fun m -> + check (check_map m) diff --git a/tools/ocaml/duniverse/crowbar/examples/pprint/dune b/tools/oca= ml/duniverse/crowbar/examples/pprint/dune new file mode 100644 index 0000000000..7c4d9127c0 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/pprint/dune @@ -0,0 +1,3 @@ +(test + (name test_pprint) + (libraries crowbar pprint)) diff --git a/tools/ocaml/duniverse/crowbar/examples/pprint/test_pprint.ml b= /tools/ocaml/duniverse/crowbar/examples/pprint/test_pprint.ml new file mode 100644 index 0000000000..77789ef00f --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/pprint/test_pprint.ml @@ -0,0 +1,39 @@ +open Crowbar +open PPrint +type t =3D (string * PPrint.document) +let doc =3D fix (fun doc -> choose [ + const ("", empty); + const ("a", char 'a'); + const ("123", string "123"); + const ("Hello", string "Hello"); + const ("awordwhichisalittlebittoolong", + string "awordwhichisalittlebittoolong"); + const ("", hardline); + map [range 10] (fun n -> ("", break n)); + map [range 10] (fun n -> ("", break n)); + map [doc; doc] + (fun (sa,da) (sb,db) -> (sa ^ sb, da ^^ db)); + map [range 10; doc] (fun n (s,d) -> (s, nest n d)); + map [doc] (fun (s, d) -> (s, group d)); + map [doc] (fun (s, d) -> (s, align d)) +]) + +let check_doc (s, d) =3D + let b =3D Buffer.create 100 in + let w =3D 40 in + ToBuffer.pretty 1.0 w b d; + let text =3D Bytes.to_string (Buffer.to_bytes b) in + let ws =3D Str.regexp "[ \t\n\r]*" in + (* Printf.printf "doc2{\n%s\n}%!" text; *) + let del_ws =3D Str.global_replace ws "" in + (* Printf.printf "[%s] =3D [%s]\n%!" (del_ws s) (del_ws text);*) + Str.split (Str.regexp "\n") text |> List.iter (fun s -> + let mspace =3D Str.regexp "[^ ] " in + if String.length s > w then + match Str.search_forward mspace s w with + | _ -> assert false + | exception Not_found -> ()); + check_eq (del_ws s) (del_ws text) + +let () =3D + add_test ~name:"pprint" [doc] check_doc diff --git a/tools/ocaml/duniverse/crowbar/examples/serializer/dune b/tools= /ocaml/duniverse/crowbar/examples/serializer/dune new file mode 100644 index 0000000000..f1f0c6b64b --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/serializer/dune @@ -0,0 +1,3 @@ +(test + (name test_serializer) + (libraries crowbar)) diff --git a/tools/ocaml/duniverse/crowbar/examples/serializer/serializer.m= l b/tools/ocaml/duniverse/crowbar/examples/serializer/serializer.ml new file mode 100644 index 0000000000..bb1ee2b4c2 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/serializer/serializer.ml @@ -0,0 +1,34 @@ +type data =3D + | Datum of string + | Block of header * data list +and header =3D string + +type _ ty =3D + | Int : int ty + | Bool : bool ty + | Prod : 'a ty * 'b ty -> ('a * 'b) ty + | List : 'a ty -> 'a list ty + +let rec pp_ty : type a . _ -> a ty -> unit =3D fun ppf -> + let printf fmt =3D Format.fprintf ppf fmt in + function + | Int -> printf "Int" + | Bool -> printf "Bool" + | Prod(ta, tb) -> printf "Prod(%a,%a)" pp_ty ta pp_ty tb + | List t -> printf "List(%a)" pp_ty t + +let rec serialize : type a . a ty -> a -> data =3D function + | Int -> fun n -> Datum (string_of_int n) + | Bool -> fun b -> Datum (string_of_bool b) + | Prod (ta, tb) -> fun (va, vb) -> + Block("pair", [serialize ta va; serialize tb vb]) + | List t -> fun vs -> + Block("list", List.map (serialize t) vs) + +let rec deserialize : type a . a ty -> data -> a =3D function[@warning "-8= "] + | Int -> fun (Datum s) -> int_of_string s + | Bool -> fun (Datum s) -> bool_of_string s + | Prod (ta, tb) -> fun (Block("pair", [sa; sb])) -> + (deserialize ta sa, deserialize tb sb) + | List t -> fun (Block("list", ss)) -> + List.map (deserialize t) ss diff --git a/tools/ocaml/duniverse/crowbar/examples/serializer/test_seriali= zer.ml b/tools/ocaml/duniverse/crowbar/examples/serializer/test_serializer.= ml new file mode 100644 index 0000000000..f650484a88 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/serializer/test_serializer.ml @@ -0,0 +1,47 @@ +open Crowbar + +module S =3D Serializer + +type any_ty =3D Any : 'a S.ty -> any_ty + +let ty_gen =3D + with_printer (fun ppf (Any t)-> S.pp_ty ppf t) @@ + fix (fun ty_gen -> choose [ + const (Any S.Int); + const (Any S.Bool); + map [ty_gen; ty_gen] (fun (Any ta) (Any tb) -> + Any (S.Prod (ta, tb))); + map [ty_gen] (fun (Any t) -> Any (List t)); + ]) + +let prod_gen ga gb =3D map [ga; gb] (fun va vb -> (va, vb)) + +let rec gen_of_ty : type a . a S.ty -> a gen =3D function + | S.Int -> int + | S.Bool -> bool + | S.Prod (ta, tb) -> prod_gen (gen_of_ty ta) (gen_of_ty tb) + | S.List t -> list (gen_of_ty t) + +type pair =3D Pair : 'a S.ty * 'a -> pair + +(* The generator for the final value, [gen_of_ty t], depends on the + generated type representation, [t]. This dynamic dependency cannot + be expressed with [map], it requires [dynamic_bind]. *) +let pair_gen : pair gen =3D + dynamic_bind ty_gen @@ fun (Any t) -> + map [gen_of_ty t] (fun v -> Pair (t, v)) + +let rec printer_of_ty : type a . a S.ty -> a printer =3D function + | S.Int -> pp_int + | S.Bool -> pp_bool + | S.Prod (ta, tb) -> (fun ppf (a, b) -> + pp ppf "(%a, %a)" (printer_of_ty ta) a (printer_of_ty tb) b) + | S.List t -> pp_list (printer_of_ty t) + +let check_pair (Pair (t, v)) =3D + let data =3D S.serialize t v in + match S.deserialize t data with + | exception _ -> fail "incorrect deserialization" + | v' -> check_eq ~pp:(printer_of_ty t) v v' + +let () =3D add_test ~name:"pairs" [pair_gen] check_pair diff --git a/tools/ocaml/duniverse/crowbar/examples/uunf/dune b/tools/ocaml= /duniverse/crowbar/examples/uunf/dune new file mode 100644 index 0000000000..35850fa034 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/uunf/dune @@ -0,0 +1,3 @@ +(test + (name test_uunf) + (libraries uunf uutf uucp crowbar)) diff --git a/tools/ocaml/duniverse/crowbar/examples/uunf/test_uunf.ml b/too= ls/ocaml/duniverse/crowbar/examples/uunf/test_uunf.ml new file mode 100644 index 0000000000..a43cd8bc13 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/uunf/test_uunf.ml @@ -0,0 +1,75 @@ +open Crowbar + +let uchar =3D + map [int32] (fun n -> + let n =3D (Int32.to_int n land 0xFFFFFFF) mod 0x10FFFF in + try Uchar.of_int n + with Invalid_argument _ -> bad_test ()) + +let unicode =3D list1 uchar + +let norm form str =3D + let n =3D Uunf.create form in + let rec add acc v =3D match Uunf.add n v with + | `Uchar u -> add (u :: acc) `Await + | `Await | `End -> acc in + let rec go acc =3D function + | [] -> List.rev (add acc `End) + | (v :: vs) -> go (add acc (`Uchar v)) vs in + go [] str + +let unicode_to_string s =3D + let b =3D Buffer.create 10 in + List.iter (Uutf.Buffer.add_utf_8 b) s; + Buffer.contents b + + +let pp_unicode ppf s =3D + Format.fprintf ppf "@["; + Format.fprintf ppf "@[\"%s\"@]@ " (unicode_to_string s); + s |> List.iter (fun u -> + Format.fprintf ppf "@[U+%04x %s (%a)@]@ " (Uchar.to_int u) (Uucp.Name.= name u) Uucp.Block.pp (Uucp.Block.block u)); + Format.fprintf ppf "@]\n" + + +let unicode =3D with_printer pp_unicode unicode + +let () =3D + add_test ~name:"uunf" [unicode] @@ fun s -> + let nfc =3D norm `NFC s in + let nfd =3D norm `NFD s in + let nfkc =3D norm `NFKC s in + let nfkd =3D norm `NFKD s in +(* [s; nfc; nfd; nfkc; nfkd] |> List.iter (fun s -> + Printf.printf "[%s]\n" (unicode_to_string s)); + Printf.printf "\n%!";*) + + let tests =3D + [ + nfc, [ + norm `NFC nfc; + norm `NFC nfd]; + =20 + nfd, [ + norm `NFD nfc; + norm `NFD nfd]; + =20 + nfkc, [ + norm `NFC nfkc; + norm `NFC nfkd; + norm `NFKC nfc; + norm `NFKC nfd; + norm `NFKC nfkc; + norm `NFKC nfkd]; + =20 + nfkd, [ + norm `NFD nfkc; + norm `NFD nfkd; + norm `NFKD nfc; + norm `NFKD nfd; + norm `NFKD nfkc; + norm `NFKD nfkd] + ] in + tests |> List.iter (fun (s, eqs) -> + List.iter (fun s' -> check_eq ~pp:pp_unicode s s') eqs) + diff --git a/tools/ocaml/duniverse/crowbar/examples/xmldiff/dune b/tools/oc= aml/duniverse/crowbar/examples/xmldiff/dune new file mode 100644 index 0000000000..46d7ceef19 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/xmldiff/dune @@ -0,0 +1,3 @@ +(test + (name test_xmldiff) + (libraries xmldiff crowbar)) diff --git a/tools/ocaml/duniverse/crowbar/examples/xmldiff/test_xmldiff.ml= b/tools/ocaml/duniverse/crowbar/examples/xmldiff/test_xmldiff.ml new file mode 100644 index 0000000000..8fdbd9aa88 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/examples/xmldiff/test_xmldiff.ml @@ -0,0 +1,42 @@ +open Crowbar + +let ident =3D choose [const "a"; const "b"; const "c"] +let elem_name =3D map [ident] (fun s -> ("", s)) + + +let attrs =3D + choose [ + const Xmldiff.Nmap.empty; + map [elem_name; ident] Xmldiff.Nmap.singleton + ] + +let rec xml =3D lazy ( + choose [ + const (`D "a"); + map [ident] (fun s -> `D s); + map [elem_name; attrs; list (unlazy xml)] (fun s attrs elems -> + let rec normalise =3D function + | ([] | [_]) as x -> x + | `E _ as el :: xs -> + el :: normalise xs + | `D s :: xs -> + match normalise xs with + | `D s' :: xs' -> + `D (s ^ s') :: xs' + | xs' -> `D s :: xs' in + `E (s, attrs, normalise elems)) + ]) + +let lazy xml =3D xml + +let xml =3D map [xml] (fun d -> `E (("", "a"), Xmldiff.Nmap.empty, [d])) + +let pp_xml ppf xml =3D + pp ppf "%s" (Xmldiff.string_of_xml xml) +let xml =3D with_printer pp_xml xml + + +let () =3D + add_test ~name:"xmldiff" [xml; xml] @@ fun xml1 xml2 -> + let (patch, xml3) =3D Xmldiff.diff_with_final_tree xml1 xml2 in + check_eq ~pp:pp_xml xml2 xml3 diff --git a/tools/ocaml/duniverse/crowbar/src/crowbar.ml b/tools/ocaml/dun= iverse/crowbar/src/crowbar.ml new file mode 100644 index 0000000000..579a1a8715 --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/src/crowbar.ml @@ -0,0 +1,582 @@ +type src =3D Random of Random.State.t | Fd of Unix.file_descr +type state =3D + { + chan : src; + buf : Bytes.t; + mutable offset : int; + mutable len : int + } + +type 'a printer =3D Format.formatter -> 'a -> unit + +type 'a gen =3D + | Choose of 'a gen list + | Map : ('f, 'a) gens * 'f -> 'a gen + | Bind : 'a gen * ('a -> 'b gen) -> 'b gen + | Option : 'a gen -> 'a option gen + | List : 'a gen -> 'a list gen + | List1 : 'a gen -> 'a list gen + | Unlazy of 'a gen Lazy.t + | Primitive of (state -> 'a) + | Print of 'a printer * 'a gen +and ('k, 'res) gens =3D + | [] : ('res, 'res) gens + | (::) : 'a gen * ('k, 'res) gens -> ('a -> 'k, 'res) gens + +type nonrec +'a list =3D 'a list =3D [] | (::) of 'a * 'a list + +let unlazy f =3D Unlazy f + +let fix f =3D + let rec lazygen =3D lazy (f (unlazy lazygen)) in + unlazy lazygen + +let map gens f =3D Map (gens, f) + +let dynamic_bind m f =3D Bind(m, f) + +let const x =3D map [] x +let choose gens =3D Choose gens +let option gen =3D Option gen +let list gen =3D List gen +let list1 gen =3D List1 gen + +let pair gena genb =3D + map (gena :: genb :: []) (fun a b -> (a, b)) + +let concat_gen_list sep l =3D + match l with + | h::t -> List.fold_left (fun acc e -> + map [acc; sep; e] (fun acc sep e -> acc ^ sep ^ e) + ) h t + | [] -> const "" + +let with_printer pp gen =3D Print (pp, gen) + +let result gena genb =3D + Choose [ + Map([gena], fun va -> Ok va); + Map([genb], fun vb -> Error vb); + ] + + +let pp =3D Format.fprintf +let pp_int ppf n =3D pp ppf "%d" n +let pp_int32 ppf n =3D pp ppf "%s" (Int32.to_string n) +let pp_int64 ppf n =3D pp ppf "%s" (Int64.to_string n) +let pp_float ppf f =3D pp ppf "%f" f +let pp_bool ppf b =3D pp ppf "%b" b +let pp_char ppf c =3D pp ppf "%c" c +let pp_uchar ppf c =3D pp ppf "U+%04x" (Uchar.to_int c) +let pp_string ppf s =3D pp ppf "\"%s\"" (String.escaped s) +let pp_list pv ppf l =3D + pp ppf "@[[%a]@]" + (Format.pp_print_list ~pp_sep:(fun ppf () -> pp ppf ";@ ") pv) l +let pp_option pv ppf =3D function + | None -> + Format.fprintf ppf "None" + | Some x -> + Format.fprintf ppf "(Some %a)" pv x + +exception BadTest of string +exception FailedTest of unit printer +let guard =3D function + | true -> () + | false -> raise (BadTest "guard failed") +let bad_test () =3D raise (BadTest "bad test") +let nonetheless =3D function + | None -> bad_test () + | Some a -> a + +let get_data chan buf off len =3D + match chan with + | Random rand -> + for i =3D off to off + len - 1 do + Bytes.set buf i (Char.chr (Random.State.bits rand land 0xff)) + done; + len - off + | Fd ch -> + Unix.read ch buf off len + +let refill src =3D + assert (src.offset <=3D src.len); + let remaining =3D src.len - src.offset in + (* move remaining data to start of buffer *) + Bytes.blit src.buf src.offset src.buf 0 remaining; + src.len <- remaining; + src.offset <- 0; + let read =3D get_data src.chan src.buf remaining (Bytes.length src.buf -= remaining) in + if read =3D 0 then + raise (BadTest "premature end of file") + else + src.len <- remaining + read + +let rec getbytes src n =3D + assert (src.offset <=3D src.len); + if n > Bytes.length src.buf then failwith "request too big"; + if src.len - src.offset >=3D n then + let off =3D src.offset in + (src.offset <- src.offset + n; off) + else + (refill src; getbytes src n) + +let read_char src =3D + let off =3D getbytes src 1 in + Bytes.get src.buf off + +let read_byte src =3D + Char.code (read_char src) + +let read_bool src =3D + let n =3D read_byte src in + n land 1 =3D 1 + +let bool =3D Print(pp_bool, Primitive read_bool) + +let uint8 =3D Print(pp_int, Primitive read_byte) +let int8 =3D Print(pp_int, Map ([uint8], fun n -> n - 128)) + +let read_uint16 src =3D + let off =3D getbytes src 2 in + EndianBytes.LittleEndian.get_uint16 src.buf off + +let read_int16 src =3D + let off =3D getbytes src 2 in + EndianBytes.LittleEndian.get_int16 src.buf off + +let uint16 =3D Print(pp_int, Primitive read_uint16) +let int16 =3D Print(pp_int, Primitive read_int16) + +let read_int32 src =3D + let off =3D getbytes src 4 in + EndianBytes.LittleEndian.get_int32 src.buf off + +let read_int64 src =3D + let off =3D getbytes src 8 in + EndianBytes.LittleEndian.get_int64 src.buf off + +let int32 =3D Print (pp_int32, Primitive read_int32) +let int64 =3D Print (pp_int64, Primitive read_int64) + +let int =3D + Print (pp_int, + if Sys.word_size <=3D 32 then + Map([int32], Int32.to_int) + else + Map([int64], Int64.to_int)) + +let float =3D Print (pp_float, Primitive (fun src -> + let off =3D getbytes src 8 in + EndianBytes.LittleEndian.get_double src.buf off)) + +let char =3D Print (pp_char, Primitive read_char) + +(* maybe print as a hexdump? *) +let bytes =3D Print (pp_string, Primitive (fun src -> + (* null-terminated, with '\001' as an escape code *) + let buf =3D Bytes.make 64 '\255' in + let rec read_bytes p =3D + if p >=3D Bytes.length buf then p else + match read_char src with + | '\000' -> p + | '\001' -> + Bytes.set buf p (read_char src); + read_bytes (p + 1) + | c -> + Bytes.set buf p c; + read_bytes (p + 1) in + let count =3D read_bytes 0 in + Bytes.sub_string buf 0 count)) + +let bytes_fixed n =3D Print (pp_string, Primitive (fun src -> + let off =3D getbytes src n in + Bytes.sub_string src.buf off n)) + +let choose_int n state =3D + assert (n > 0); + if n =3D 1 then + 0 + else if (n <=3D 0x100) then + read_byte state mod n + else if (n < 0x1000000) then + Int32.(to_int (abs (rem (read_int32 state) (of_int n)))) + else + Int64.(to_int (abs (rem (read_int64 state) (of_int n)))) + +let range ?(min=3D0) n =3D + if n <=3D 0 then + raise (Invalid_argument "Crowbar.range: argument n must be positive"); + if min < 0 then + raise (Invalid_argument "Crowbar.range: argument min must be positive = or null"); + Print (pp_int, Primitive (fun s -> min + choose_int n s)) + +let uchar : Uchar.t gen =3D + map [range 0x110000] (fun x -> + guard (Uchar.is_valid x); Uchar.of_int x) +let uchar =3D Print(pp_uchar, uchar) + +let rec sequence =3D function + g::gs -> map [g; sequence gs] (fun x xs -> x::xs) +| [] -> const [] + +let shuffle_arr arr =3D + let n =3D Array.length arr in + let gs =3D List.init n (fun i -> range ~min:i (n - i)) in + map [sequence gs] @@ fun js -> + js |> List.iteri (fun i j -> + let t =3D arr.(i) in arr.(i) <- arr.(j); arr.(j) <- t); + arr + +let shuffle l =3D map [shuffle_arr (Array.of_list l)] Array.to_list + +exception GenFailed of exn * Printexc.raw_backtrace * unit printer + +let minimize_depth : type a . a gen list -> a gen list =3D fun gens -> + let only p =3D List.filter p gens in + let without p =3D List.filter (fun v -> not (p v)) gens in + let branchless =3D function | _ -> false in + let branchy =3D function | Map _ | Bind _ | Choose _ -> true | _ -> fals= e in + let complex =3D function | Map _ | Bind _ -> true | _ -> false in + match only branchless, without branchy, without complex with + | x::xs, _ , _ -> x :: xs + | [], x::xs, _ -> x :: xs + | [], [], x::xs -> x :: xs + | [], [], [] -> gens + +let rec generate : type a . int -> state -> a gen -> a * unit printer =3D + fun size input gen -> match gen with + | Choose xs -> + (* FIXME: better distribution? *) + (* FIXME: choices of size > 255? *) + let gens =3D if size <=3D 1 then minimize_depth xs else xs in + let n =3D choose_int (List.length gens) input in + let v, pv =3D generate size input (List.nth gens n) in + v, fun ppf () -> pp ppf "#%d %a" n pv () + | Map ([], k) -> + k, fun ppf () -> pp ppf "?" + | Map (gens, f) -> + let rec len : type k res . int -> (k, res) gens -> int =3D + fun acc xs -> match xs with + | [] -> acc + | _ :: xs -> len (1 + acc) xs in + let n =3D len 0 gens in + (* the size parameter is (apparently?) meant to ensure that generation + eventually terminates, by limiting the set of options from which t= he + generator might choose once we've gotten deep into a tree. make s= ure we + always mark our passing, even when we've mapped one value into ano= ther, + so we don't blow the stack. *) + let size =3D (size - 1) / n in + let v, pvs =3D gen_apply size input gens f in + begin match v with + | Ok v -> v, pvs + | Error (e, bt) -> raise (GenFailed (e, bt, pvs)) + end + | Bind (m, f) -> + let index, pv_index =3D generate (size - 1) input m in + let a, pv =3D generate (size - 1) input (f index) in + a, (fun ppf () -> pp ppf "(%a) =3D> %a" pv_index () pv ()) + | Option gen -> + if size < 1 then + None, fun ppf () -> pp ppf "None" + else if read_bool input then + let v, pv =3D generate size input gen in + Some v, fun ppf () -> pp ppf "Some (%a)" pv () + else + None, fun ppf () -> pp ppf "None" + | List gen -> + let elems =3D generate_list size input gen in + List.map fst elems, + fun ppf () -> pp_list (fun ppf (_, pv) -> pv ppf ()) ppf elems + | List1 gen -> + let elems =3D generate_list1 size input gen in + List.map fst elems, + fun ppf () -> pp_list (fun ppf (_, pv) -> pv ppf ()) ppf elems + | Primitive gen -> + gen input, fun ppf () -> pp ppf "?" + | Unlazy gen -> + generate size input (Lazy.force gen) + | Print (ppv, gen) -> + let v, _ =3D generate size input gen in + v, fun ppf () -> ppv ppf v + +and generate_list : type a . int -> state -> a gen -> (a * unit printer) l= ist =3D + fun size input gen -> + if size <=3D 1 then [] + else if read_bool input then + generate_list1 size input gen + else + [] + +and generate_list1 : type a . int -> state -> a gen -> (a * unit printer) = list =3D + fun size input gen -> + let ans =3D generate (size/2) input gen in + ans :: generate_list (size/2) input gen + +and gen_apply : + type k res . int -> state -> + (k, res) gens -> k -> + (res, exn * Printexc.raw_backtrace) result * unit printer =3D + fun size state gens f -> + let rec go : + type k res . int -> state -> + (k, res) gens -> k -> + (res, exn * Printexc.raw_backtrace) result * unit printer list =3D + fun size input gens -> match gens with + | [] -> fun x -> Ok x, [] + | g :: gs -> fun f -> + let v, pv =3D generate size input g in + let res, pvs =3D + match f v with + | exception (BadTest _ as e) -> raise e + | exception e -> + Error (e, Printexc.get_raw_backtrace ()) , [] + | fv -> go size input gs fv in + res, pv :: pvs in + let v, pvs =3D go size state gens f in + let pvs =3D fun ppf () -> + match pvs with + | [pv] -> + pv ppf () + | pvs -> + pp_list (fun ppf pv -> pv ppf ()) ppf pvs in + v, pvs + + +let fail s =3D raise (FailedTest (fun ppf () -> pp ppf "%s" s)) + +let failf format =3D + Format.kasprintf fail format + +let check =3D function + | true -> () + | false -> raise (FailedTest (fun ppf () -> pp ppf "check false")) + +let check_eq ?pp:pv ?cmp ?eq a b =3D + let pass =3D match eq, cmp with + | Some eq, _ -> eq a b + | None, Some cmp -> cmp a b =3D 0 + | None, None -> + Stdlib.compare a b =3D 0 in + if pass then + () + else + raise (FailedTest (fun ppf () -> + match pv with + | None -> pp ppf "different" + | Some pv -> pp ppf "@[%a@ !=3D@ %a@]" pv a pv b)) + +let () =3D Printexc.record_backtrace true + +type test =3D Test : string * ('f, unit) gens * 'f -> test + +type test_status =3D + | TestPass of unit printer + | BadInput of string + | GenFail of exn * Printexc.raw_backtrace * unit printer + | TestExn of exn * Printexc.raw_backtrace * unit printer + | TestFail of unit printer * unit printer + +let run_once (gens : (_, unit) gens) f state =3D + match gen_apply 100 state gens f with + | Ok (), pvs -> TestPass pvs + | Error (FailedTest p, _), pvs -> TestFail (p, pvs) + | Error (e, bt), pvs -> TestExn (e, bt, pvs) + | exception (BadTest s) -> BadInput s + | exception (GenFailed (e, bt, pvs)) -> GenFail (e, bt, pvs) + +let classify_status =3D function + | TestPass _ -> `Pass + | BadInput _ -> `Bad + | GenFail _ -> `Fail (* slightly dubious... *) + | TestExn _ | TestFail _ -> `Fail + +let print_status ppf status =3D + let print_ex ppf (e, bt) =3D + pp ppf "%s" (Printexc.to_string e); + bt + |> Printexc.raw_backtrace_to_string + |> Str.split (Str.regexp "\n") + |> List.iter (pp ppf "@,%s") in + match status with + | TestPass pvs -> + pp ppf "When given the input:@.@[@,%a@,@]@.the test passed." + pvs () + | BadInput s -> + pp ppf "The testcase was invalid:@.%s" s + | GenFail (e, bt, pvs) -> + pp ppf "When given the input:@.@[<4>%a@]@.the testcase generator thre= w an exception:@.@[@,%a@,@]" + pvs () + print_ex (e, bt) + | TestExn (e, bt, pvs) -> + pp ppf "When given the input:@.@[@,%a@,@]@.the test threw an exc= eption:@.@[@,%a@,@]" + pvs () + print_ex (e, bt) + | TestFail (err, pvs) -> + pp ppf "When given the input:@.@[@,%a@,@]@.the test failed:@.@[<= v 4>@,%a@,@]" + pvs () + err () + +let src_of_seed seed =3D + (* try to make this independent of word size *) + let seed =3D Int64.( [| + to_int (logand (of_int 0xffff) seed); + to_int (logand (of_int 0xffff) (shift_right seed 16)); + to_int (logand (of_int 0xffff) (shift_right seed 32)); + to_int (logand (of_int 0xffff) (shift_right seed 48)) |]) in + Random (Random.State.make seed) + +let run_test ~mode ~silent ?(verbose=3Dfalse) (Test (name, gens, f)) =3D + let show_status_line ?(clear=3Dfalse) stat =3D + Printf.printf "%s: %s\n" name stat; + if clear then print_newline (); + flush stdout in + let ppf =3D Format.std_formatter in + if not silent && Unix.isatty Unix.stdout then + show_status_line ~clear:false "...."; + let status =3D match mode with + | `Once state -> + run_once gens f state + | `Repeat iters -> + let worst_status =3D ref (TestPass (fun _ () -> ())) in + let npass =3D ref 0 in + let nbad =3D ref 0 in + while !npass < iters && classify_status !worst_status =3D `Pass do + let seed =3D Random.int64 Int64.max_int in + let state =3D { chan =3D src_of_seed seed; + buf =3D Bytes.make 256 '0'; + offset =3D 0; len =3D 0 } in + let status =3D run_once gens f state in + begin match classify_status status with + | `Pass -> incr npass + | `Bad -> incr nbad + | `Fail -> + (* if not silent then pp ppf "failed with seed %016LX" seed; *) + worst_status :=3D status + end; + done; + let status =3D !worst_status in + status in + if silent && verbose && classify_status status =3D `Fail then begin + show_status_line + ~clear:true "FAIL"; + pp ppf "%a@." print_status status; + end; + if not silent then begin + match classify_status status with + | `Pass -> + show_status_line + ~clear:true "PASS"; + if verbose then pp ppf "%a@." print_status status + | `Fail -> + show_status_line + ~clear:true "FAIL"; + pp ppf "%a@." print_status status; + | `Bad -> + show_status_line + ~clear:true "BAD"; + pp ppf "%a@." print_status status; + end; + status + +exception TestFailure +let run_all_tests file verbosity infinity tests =3D + match file, infinity with + | None, false -> + (* limited-run QuickCheck mode *) + let failures =3D ref 0 in + let () =3D tests |> List.iter (fun t -> + match (run_test ~mode:(`Repeat 5000) ~silent:false t |> classify_s= tatus) with + | `Fail -> failures :=3D !failures + 1 + | _ -> () + ) + in + !failures + | None, true -> + (* infinite QuickCheck mode *) + let rec go ntests alltests tests =3D match tests with + | [] -> + go ntests alltests alltests + | t :: rest -> + if ntests mod 10000 =3D 0 then Printf.eprintf "\r%d%!" ntests; + match classify_status (run_test ~mode:(`Once { chan =3D src_of_s= eed (Random.int64 (Int64.max_int)); + buf =3D Bytes.make 256 '0'; + offset =3D 0; len =3D 0 }) ~silent:true ~verbose:tru= e t) with + | `Fail -> Printf.printf "%d tests passed before first failure\n= %!" ntests + | _ -> go (ntests + 1) alltests rest in + let () =3D go 0 tests tests in + 1 + | Some file, _ -> + (* AFL mode *) + let verbose =3D List.length verbosity > 0 in + let () =3D AflPersistent.run (fun () -> + let fd =3D Unix.openfile file [Unix.O_RDONLY] 0o000 in + let state =3D { chan =3D Fd fd; buf =3D Bytes.make 256 '0'; + offset =3D 0; len =3D 0 } in + let status =3D + try run_test ~mode:(`Once state) ~silent:false ~verbose @@ + List.nth tests (choose_int (List.length tests) state) + with + BadTest s -> BadInput s + in + Unix.close fd; + match classify_status status with + | `Pass | `Bad -> () + | `Fail -> + Printexc.record_backtrace false; + raise TestFailure) + in + 0 (* failures come via the exception mechanism above *) + +let last_generated_name =3D ref 0 +let generate_name () =3D + incr last_generated_name; + "test" ^ string_of_int !last_generated_name + +let registered_tests =3D ref [] + +let add_test ?name gens f =3D + let name =3D match name with + | None -> generate_name () + | Some name -> name in + registered_tests :=3D Test (name, gens, f) :: !registered_tests + +(* cmdliner stuff *) + +let randomness_file =3D + let doc =3D "A file containing some bytes, consulted in constructing tes= t cases. \ + When `afl-fuzz` is calling the test binary, use `@@` to indicate that \ + `afl-fuzz` should put its test case here \ + (e.g. `afl-fuzz -i input -o output ./my_crowbar_test @@`). Re-run a t= est by \ + supplying the test file here \ + (e.g. `./my_crowbar_test output/crashes/id:000000`). If no file is \ + specified, the test will use OCaml's Random module as a source of \ + randomness for a predefined number of rounds." in + Cmdliner.Arg.(value & pos 0 (some file) None & info [] ~doc ~docv:"FILE") + +let verbosity =3D + let doc =3D "Print information on each test as it's conducted." in + Cmdliner.Arg.(value & flag_all & info ["v"; "verbose"] ~doc ~docv:"VERBO= SE") + +let infinity =3D + let doc =3D "In non-AFL (quickcheck) mode, continue running until a test= failure is \ + discovered. No attempt is made to track which tests have alr= eady been run, \ + so some tests may be repeated, and if there are no failures r= eachable, the \ + test will never terminate without outside intervention." in + Cmdliner.Arg.(value & flag & info ["i"] ~doc ~docv:"INFINITE") + +let crowbar_info =3D Cmdliner.Term.info @@ Filename.basename Sys.argv.(0) + +let () =3D + at_exit (fun () -> + let t =3D !registered_tests in + registered_tests :=3D []; + match t with + | [] -> () + | t -> + let cmd =3D Cmdliner.Term.(const run_all_tests $ randomness_file $= verbosity $ + infinity $ const (List.rev t)) in + match Cmdliner.Term.eval ~catch:false (cmd, crowbar_info) with + | `Ok 0 -> exit 0 + | `Ok _ -> exit 1 + | n -> Cmdliner.Term.exit n + ) diff --git a/tools/ocaml/duniverse/crowbar/src/crowbar.mli b/tools/ocaml/du= niverse/crowbar/src/crowbar.mli new file mode 100644 index 0000000000..9758dd626d --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/src/crowbar.mli @@ -0,0 +1,251 @@ +(** {1:top Types } *) + +type 'a gen +(** ['a gen] knows how to generate ['a] for use in Crowbar tests. *) + +type ('k, 'res) gens =3D + | [] : ('res, 'res) gens + | (::) : 'a gen * ('k, 'res) gens -> ('a -> 'k, 'res) gens +(** multiple generators are passed to functions using a listlike syntax. + for example, [map [int; int] (fun a b -> a + b)] *) + +type 'a printer =3D Format.formatter -> 'a -> unit +(** pretty-printers for items generated by Crowbar; useful for the user in + translating test failures into bugfixes. *) + +(**/**) +(* re-export stdlib's list + We only want to override [] syntax in the argument to Map *) +type nonrec +'a list =3D 'a list =3D [] | (::) of 'a * 'a list +(**/**) + +(** {1:generators Generators } *) + +(** {2:simple_generators Simple Generators } *) + +val int : int gen +(** [int] generates an integer ranging from min_int to max_int, inclusive. + If you need integers from a smaller domain, consider using {!range}. *) + +val uint8 : int gen +(** [uint8] generates an unsigned byte, ranging from 0 to 255 inclusive. *) + +val int8 : int gen +(** [int8] generates a signed byte, ranging from -128 to 127 inclusive. *) + +val uint16 : int gen +(** [uint16] generates an unsigned 16-bit integer, + ranging from 0 to 65535 inclusive. *) + +val int16 : int gen +(** [int16] generates a signed 16-bit integer, + ranging from -32768 to 32767 inclusive. *) + +val int32 : Int32.t gen +(** [int32] generates a 32-bit signed integer. *) + +val int64 : Int64.t gen +(** [int64] generates a 64-bit signed integer. *) + +val float : float gen +(** [float] generates a double-precision floating-point number. *) + +val char : char gen +(** [char] generates a char. *) + +val uchar : Uchar.t gen +(** [uchar] generates a Unicode scalar value *) + +val bytes : string gen +(** [bytes] generates a string of arbitrary length (including zero-length = strings). *) + +val bytes_fixed : int -> string gen +(** [bytes_fixed length] generates a string of the specified length. *) + +val bool : bool gen +(** [bool] generates a yes or no answer. *) + +val range : ?min:int -> int -> int gen +(** [range ?min n] is a generator for integers between [min] (inclusive) + and [min + n] (exclusive). Default [min] value is 0. + [range ?min n] will raise [Invalid_argument] for [n <=3D 0]. +*) + +(** {2:generator_functions Functions on Generators } *) + +val map : ('f, 'a) gens -> 'f -> 'a gen +(** [map gens map_fn] provides a means for creating generators using other + generators' output. For example, one might generate a Char.t from a + {!uint8}: + {[ + open Crowbar + let char_gen : Char.t gen =3D map [uint8] Char.chr + ]} +*) + +val unlazy : 'a gen Lazy.t -> 'a gen +(** [unlazy gen] forces the generator [gen]. It is useful when defining + generators for recursive data types: + + {[ + open Crowbar + type a =3D A of int | Self of a + let rec a_gen =3D lazy ( + choose [ + map [int] (fun i -> A i); + map [(unlazy a_gen)] (fun s -> Self s); + ]) + let lazy a_gen =3D a_gen + ]} +*) + +val fix : ('a gen -> 'a gen) -> 'a gen +(** [fix fn] applies the function [fn]. It is useful when defining genera= tors + for recursive data types: + + {[ + open Crowbar + type a =3D A of int | Self of a + let rec a_gen =3D fix (fun a_gen -> + choose [ + map [int] (fun i -> A i); + map [a_gen] (fun s -> Self s); + ]) + ]} + *) + +val const : 'a -> 'a gen +(** [const a] always generates [a]. *) + +val choose : 'a gen list -> 'a gen +(** [choose gens] chooses a generator arbitrarily from [gens]. *) + +val option : 'a gen -> 'a option gen +(** [option gen] generates either [None] or [Some x], where [x] is the item + generated by [gen]. *) + +val pair : 'a gen -> 'b gen -> ('a * 'b) gen +(** [pair gena gen] generates (a, b) + where [a] is generated by [gena] and [b] by [genb]. *) + +val result : 'a gen -> 'b gen -> ('a, 'b) result gen +(** [result gena genb] generates either [Ok va] or [Error vb], + where [va], [vb] are generated by [gena], [genb] respectively. *) + +val list : 'a gen -> 'a list gen +(** [list gen] makes a generator for lists using [gen]. Lists may be empt= y; for + non-empty lists, use {!list1}. *) + +val list1 : 'a gen -> 'a list gen +(** [list1 gen] makes non-empty list generators. For potentially empty lis= ts, + use {!list}.*) + +val shuffle : 'a list -> 'a list gen +(** [shuffle l] generates random permutations of [l]. *) + +val concat_gen_list : string gen -> string gen list -> string gen +(** [concat_gen_list sep l] concatenates a list of string gen [l] insertin= g the + separator [sep] between each *) + +val with_printer : 'a printer -> 'a gen -> 'a gen +(** [with_printer printer gen] generates the same values as [gen]. If [ge= n] + is used to create a failing test case and the test was reached by + calling [check_eq] without [pp] set, [printer] will be used to print t= he + failing test case. *) + +val dynamic_bind : 'a gen -> ('a -> 'b gen) -> 'b gen +(** [dynamic_bind gen f] is a monadic bind, it allows to express the + generation of a value whose generator itself depends on + a previously generated value. This is in contrast with [map gen f], + where no further generation happens in [f] after [gen] has + generated an element. + + An typical example where this sort of dependencies is required is + a serialization library exporting combinators letting you build + values of the form ['a serializer]. You may want to test this + library by first generating a pair of a serializer and generator + ['a serializer * 'a gen] for arbitrary ['a], and then generating + values of type ['a] depending on the (generated) generator to test + the serializer. There is such an example in the + [examples/serializer/] directory of the Crowbar implementation. + + Because the structure of a generator built with [dynamic_bind] is + opaque/dynamic (it depends on generated values), the Crowbar + library cannot analyze its statically + (without generating anything) -- the generator is opaque to the + library, hidden in a function. In particular, many optimizations or + or fuzzing techniques based on generator analysis are + impossible. As a client of the library, you should avoid + [dynamic_bind] whenever it is not strictly required to express + a given generator, so that you can take advantage of these features + (present or future ones). Use the least powerful/complex + combinators that suffice for your needs. +*) + +(** {1:printing Printing } *) + +(* Format.fprintf, renamed *) +val pp : Format.formatter -> ('a, Format.formatter, unit) format -> 'a +val pp_int : int printer +val pp_int32 : Int32.t printer +val pp_int64 : Int64.t printer +val pp_float : float printer +val pp_bool : bool printer +val pp_string : string printer +val pp_list : 'a printer -> 'a list printer +val pp_option : 'a printer -> 'a option printer + +(** {1:testing Testing} *) + +val add_test : + ?name:string -> ('f, unit) gens -> 'f -> unit +(** [add_test name generators test_fn] adds [test_fn] to the list of eligi= ble + tests to be run when the program is invoked. At runtime, random data = will + be sent to [generators] to create the input necessary to run [test_fn]= . Any + failures will be printed annotated with [name]. *) + +(** {2:aborting Aborting Tests} *) + +val guard : bool -> unit +(** [guard b] aborts a test if [b] is false. The test will not be recorded + or reported as a failure. *) + +val bad_test : unit -> 'a +(** [bad_test ()] aborts a test. The test will not be recorded or reported + as a failure. *) + +val nonetheless : 'a option -> 'a +(** [nonetheless o] aborts a test if [o] is None. The test will not be re= corded + or reported as a failure. *) + +(** {2:failing Failing} *) + +val fail : string -> 'a +(** [fail message] generates a test failure and prints [message]. *) + +val failf : ('a, Format.formatter, unit, _) format4 -> 'a +(** [failf format ...] generates a test failure and prints the message + specified by the format string [format] and the following arguments. + It is set up so that [%a] calls for an ['a printer] and an ['a] value.= *) + +(** {2:asserting Asserting Properties} *) + +val check : bool -> unit +(** [check b] generates a test failure if [b] is false. No useful informa= tion + will be printed in this case. *) + +val check_eq : ?pp:('a printer) -> ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a= -> bool) -> + 'a -> 'a -> unit +(** [check_eq pp cmp eq x y] evaluates whether x and y are equal, and if t= hey + are not, raises a failure and prints an error message. + Equality is evaluated as follows: + + {ol + {- use a provided [eq]} + {- if no [eq] is provided, use a provided [cmp]} + {- if neither [eq] nor [cmp] is provided, use Stdlib.compare}} + + If [pp] is provided, use this to print [x] and [y] if they are not equ= al. + If [pp] is not provided, a best-effort printer will be generated from = the + printers for primitive generators and any printers registered with + [with_printer] and used. *) diff --git a/tools/ocaml/duniverse/crowbar/src/dune b/tools/ocaml/duniverse= /crowbar/src/dune new file mode 100644 index 0000000000..ed5173287b --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/src/dune @@ -0,0 +1,3 @@ +(library + (public_name crowbar) + (libraries cmdliner ocplib-endian afl-persistent str)) diff --git a/tools/ocaml/duniverse/crowbar/src/todo b/tools/ocaml/duniverse= /crowbar/src/todo new file mode 100644 index 0000000000..087141682b --- /dev/null +++ b/tools/ocaml/duniverse/crowbar/src/todo @@ -0,0 +1,16 @@ +join/bind (v2?) + +command line interface: + - afl-fuzz mode + - quickcheck mode + - random fuzzing mode (for me testing, really) + - file / file list mode + - reproduction mode (seed / file) + - select which tests to run + +output: + - seeds for failed tests + - maybe use notty to figure out pretty-printing width + +api: + - manual testsuite interface? diff --git a/tools/ocaml/duniverse/csexp/CHANGES.md b/tools/ocaml/duniverse= /csexp/CHANGES.md new file mode 100644 index 0000000000..841826dcc7 --- /dev/null +++ b/tools/ocaml/duniverse/csexp/CHANGES.md @@ -0,0 +1,45 @@ +# 1.3.2 + +- The project now builds with dune 1.11.0 and onward (#12, @voodoos) + +# 1.3.1 + +- Fix compatibility with 4.02.3 + +# 1.3.0 + +- Add a "feed" API for parsing. This new API let the user feed + characters one by one to the parser. It gives more control to the + user and the handling of IO errors is simpler and more + explicit. Finally, it allocates less (#9, @jeremiedimino) + +- Fixes `input_opt`; it was could never return [None] (#9, fixes #7, + @jeremiedimino) + +- Fixes `parse_many`; it was returning s-expressions in the wrong + order (#10, @rgrinberg) + +# 1.2.3 + +- Fix `parse_string_many`; it used to fail on all inputs (#6, @rgrinberg) + +# 1.2.2 + +- Fix compatibility with 4.02.3 + +# 1.2.1 + +- Remove inclusion of the `Result` module, which was accidentally + added in a previous PR. (#3, @rgrinberg) + +# 1.2.0 + +- Expose low level, monad agnostic parser. (#2, @mefyl) + +# 1.1.0 + +- Add compatibility up-to OCaml 4.02.3 (with disabled tests). (#1, @voodoo= s) + +# 1.0.0 + +- Initial release diff --git a/tools/ocaml/duniverse/csexp/LICENSE.md b/tools/ocaml/duniverse= /csexp/LICENSE.md new file mode 100644 index 0000000000..06829595d1 --- /dev/null +++ b/tools/ocaml/duniverse/csexp/LICENSE.md @@ -0,0 +1,21 @@ +The MIT License + +Copyright (c) 2016 Jane Street Group, LLC + +Permission is hereby granted, free of charge, to any person obtaining a co= py +of this software and associated documentation files (the "Software"), to d= eal +in the Software without restriction, including without limitation the righ= ts +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in= all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FR= OM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN = THE +SOFTWARE. diff --git a/tools/ocaml/duniverse/csexp/Makefile b/tools/ocaml/duniverse/c= sexp/Makefile new file mode 100644 index 0000000000..a0d0ec8317 --- /dev/null +++ b/tools/ocaml/duniverse/csexp/Makefile @@ -0,0 +1,23 @@ +INSTALL_ARGS :=3D $(if $(PREFIX),--prefix $(PREFIX),) + +default: + dune runtest + +test: + dune runtest + +install: + dune install $(INSTALL_ARGS) + +uninstall: + dune uninstall $(INSTALL_ARGS) + +reinstall: uninstall install + +clean: + dune clean + +all-supported-ocaml-versions: + dune build @install @runtest --workspace dune-workspace.dev + +.PHONY: default install uninstall reinstall clean test diff --git a/tools/ocaml/duniverse/csexp/README.md b/tools/ocaml/duniverse/= csexp/README.md new file mode 100644 index 0000000000..b6c13631b7 --- /dev/null +++ b/tools/ocaml/duniverse/csexp/README.md @@ -0,0 +1,33 @@ +Csexp - Canonical S-expressions +=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D + +This project provides minimal support for parsing and printing +[S-expressions in canonical form][wikipedia], which is a very simple +and canonical binary encoding of S-expressions. + +[wikipedia]: https://en.wikipedia.org/wiki/Canonical_S-expressions + +Example +------- + +```ocaml +# #require "csexp";; +# module Sexp =3D struct type t =3D Atom of string | List of t list end;; +module Sexp : sig type t =3D Atom of string | List of t list end +# module Csexp =3D Csexp.Make(Sexp);; +module Csexp : + sig + val parse_string : string -> (Sexp.t, int * string) result + val parse_string_many : string -> (Sexp.t list, int * string) result + val input : in_channel -> (Sexp.t, string) result + val input_opt : in_channel -> (Sexp.t option, string) result + val input_many : in_channel -> (Sexp.t list, string) result + val serialised_length : Sexp.t -> int + val to_string : Sexp.t -> string + val to_buffer : Buffer.t -> Sexp.t -> unit + val to_channel : out_channel -> Sexp.t -> unit + end +# Csexp.to_string (List [ Atom "Hello"; Atom "world!" ]);; +- : string =3D "(5:Hello6:world!)" +``` + diff --git a/tools/ocaml/duniverse/csexp/bench/csexp_bench.ml b/tools/ocaml= /duniverse/csexp/bench/csexp_bench.ml new file mode 100644 index 0000000000..8f5c5b6ace --- /dev/null +++ b/tools/ocaml/duniverse/csexp/bench/csexp_bench.ml @@ -0,0 +1,22 @@ +open StdLabels + +module Sexp =3D struct + type t =3D + | Atom of string + | List of t list +end + +module Csexp =3D Csexp.Make (Sexp) + +let atom =3D Sexp.Atom (String.make 128 'x') + +let rec gen_sexp depth =3D + if depth =3D 0 then + atom + else + let x =3D gen_sexp (depth - 1) in + List [ x; x ] + +let s =3D Sys.opaque_identity (Csexp.to_string (gen_sexp 16)) + +let%bench "of_string" =3D ignore (Csexp.parse_string s : _ result) diff --git a/tools/ocaml/duniverse/csexp/bench/dune b/tools/ocaml/duniverse= /csexp/bench/dune new file mode 100644 index 0000000000..42b95aed93 --- /dev/null +++ b/tools/ocaml/duniverse/csexp/bench/dune @@ -0,0 +1,11 @@ +(library + (name csexp_bench) + (libraries csexp) + (library_flags -linkall) + (preprocess (pps ppx_bench)) + (modules csexp_bench)) + +(executable + (name main) + (modules main) + (libraries core_bench.inline_benchmarks csexp_bench)) diff --git a/tools/ocaml/duniverse/csexp/bench/main.ml b/tools/ocaml/dunive= rse/csexp/bench/main.ml new file mode 100644 index 0000000000..88e7fe25cd --- /dev/null +++ b/tools/ocaml/duniverse/csexp/bench/main.ml @@ -0,0 +1 @@ +let () =3D Inline_benchmarks_public.Runner.main ~libname:"csexp_bench" diff --git a/tools/ocaml/duniverse/csexp/bench/runner.sh b/tools/ocaml/duni= verse/csexp/bench/runner.sh new file mode 100755 index 0000000000..0089cf7f7a --- /dev/null +++ b/tools/ocaml/duniverse/csexp/bench/runner.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env sh +export BENCHMARKS_RUNNER=3DTRUE +export BENCH_LIB=3Dcsexp_bench +exec dune exec -- ./main.exe -fork -run-without-cross-library-inlining "$@" diff --git a/tools/ocaml/duniverse/csexp/csexp.opam b/tools/ocaml/duniverse= /csexp/csexp.opam new file mode 100644 index 0000000000..44e653919f --- /dev/null +++ b/tools/ocaml/duniverse/csexp/csexp.opam @@ -0,0 +1,51 @@ +version: "1.3.2" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Parsing and printing of S-expressions in Canonical form" +description: """ + +This library provides minimal support for Canonical S-expressions +[1]. Canonical S-expressions are a binary encoding of S-expressions +that is super simple and well suited for communication between +programs. + +This library only provides a few helpers for simple applications. If +you need more advanced support, such as parsing from more fancy input +sources, you should consider copying the code of this library given +how simple parsing S-expressions in canonical form is. + +To avoid a dependency on a particular S-expression library, the only +module of this library is parameterised by the type of S-expressions. + +[1] https://en.wikipedia.org/wiki/Canonical_S-expressions +""" +maintainer: ["Jeremie Dimino "] +authors: [ + "Quentin Hocquet " + "Jane Street Group, LLC " + "Jeremie Dimino " +] +license: "MIT" +homepage: "https://github.com/ocaml-dune/csexp" +doc: "https://ocaml-dune.github.io/csexp/" +bug-reports: "https://github.com/ocaml-dune/csexp/issues" +depends: [ + "dune" {>=3D "1.11"} + "ocaml" {>=3D "4.02.3"} + "result" {>=3D "1.5"} +] +dev-repo: "git+https://github.com/ocaml-dune/csexp.git" +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" +# "@runtest" {with-test & ocaml:version >=3D "4.04"} + "@doc" {with-doc} + ] +] \ No newline at end of file diff --git a/tools/ocaml/duniverse/csexp/csexp.opam.template b/tools/ocaml/= duniverse/csexp/csexp.opam.template new file mode 100644 index 0000000000..d7691b5d65 --- /dev/null +++ b/tools/ocaml/duniverse/csexp/csexp.opam.template @@ -0,0 +1,14 @@ +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" +# "@runtest" {with-test & ocaml:version >=3D "4.04"} + "@doc" {with-doc} + ] +] diff --git a/tools/ocaml/duniverse/csexp/dune-project b/tools/ocaml/duniver= se/csexp/dune-project new file mode 100644 index 0000000000..fb7bad4454 --- /dev/null +++ b/tools/ocaml/duniverse/csexp/dune-project @@ -0,0 +1,42 @@ +(lang dune 1.11) +(name csexp) +(version 1.3.2) + +(allow_approximate_merlin) + +(license MIT) +(maintainers "Jeremie Dimino ") +(authors + "Quentin Hocquet " + "Jane Street Group, LLC " + "Jeremie Dimino ") +(source (github ocaml-dune/csexp)) +(documentation "https://ocaml-dune.github.io/csexp/") + +(generate_opam_files true) + +(package + (name csexp) + (depends + (ocaml (>=3D 4.02.3)) +; (ppx_expect :with-test) +; Disabled because of a dependency cycle=20 +; (see https://github.com/ocaml-opam/opam-depext/issues/121) + (result (>=3D 1.5))) + (synopsis "Parsing and printing of S-expressions in Canonical form") + (description " +This library provides minimal support for Canonical S-expressions +[1]. Canonical S-expressions are a binary encoding of S-expressions +that is super simple and well suited for communication between +programs. + +This library only provides a few helpers for simple applications. If +you need more advanced support, such as parsing from more fancy input +sources, you should consider copying the code of this library given +how simple parsing S-expressions in canonical form is. + +To avoid a dependency on a particular S-expression library, the only +module of this library is parameterised by the type of S-expressions. + +[1] https://en.wikipedia.org/wiki/Canonical_S-expressions +")) diff --git a/tools/ocaml/duniverse/csexp/dune-workspace.dev b/tools/ocaml/d= universe/csexp/dune-workspace.dev new file mode 100644 index 0000000000..b8b97992ba --- /dev/null +++ b/tools/ocaml/duniverse/csexp/dune-workspace.dev @@ -0,0 +1,6 @@ +(lang dune 1.0) + +;; This file is used by `make all-supported-ocaml-versions` +(context (opam (switch 4.02.3))) +(context (opam (switch 4.04.2))) +(context (opam (switch 4.08.1))) diff --git a/tools/ocaml/duniverse/csexp/src/csexp.ml b/tools/ocaml/duniver= se/csexp/src/csexp.ml new file mode 100644 index 0000000000..178658a86f --- /dev/null +++ b/tools/ocaml/duniverse/csexp/src/csexp.ml @@ -0,0 +1,333 @@ +module type Sexp =3D sig + type t =3D + | Atom of string + | List of t list +end + +module type Monad =3D sig + type 'a t + + val return : 'a -> 'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t +end + +module Make (Sexp : Sexp) =3D struct + open Sexp + + (* This is to keep compatibility with 4.02 without writing [Result.] + everywhere *) + type ('a, 'b) result =3D ('a, 'b) Result.result =3D + | Ok of 'a + | Error of 'b + + module Parser =3D struct + exception Parse_error of string + + let parse_error msg =3D raise (Parse_error msg) + + let parse_errorf f =3D Format.ksprintf parse_error f + + let premature_end_of_input =3D "premature end of input" + + module Lexer =3D struct + type state =3D + | Init + | Parsing_length + + type t =3D + { mutable state : state + ; mutable n : int + } + + let create () =3D { state =3D Init; n =3D 0 } + + let int_of_digit c =3D Char.code c - Char.code '0' + + type _ token =3D + | Await : [> `other ] token + | Lparen : [> `other ] token + | Rparen : [> `other ] token + | Atom : int -> [> `atom ] token + + let feed t c =3D + match (t.state, c) with + | Init, '(' -> Lparen + | Init, ')' -> Rparen + | Init, '0' .. '9' -> + t.state <- Parsing_length; + t.n <- int_of_digit c; + Await + | Init, _ -> + parse_errorf "invalid character %C, expected '(', ')' or '0'..'9= '" c + | Parsing_length, '0' .. '9' -> + let len =3D (t.n * 10) + int_of_digit c in + if len > Sys.max_string_length then + parse_error "atom too big to represent" + else ( + t.n <- len; + Await + ) + | Parsing_length, ':' -> + t.state <- Init; + Atom t.n + | Parsing_length, _ -> + parse_errorf + "invalid character %C while parsing atom length, expected '0'.= .'9' \ + or ':'" + c + + let feed_eoi t =3D + match t.state with + | Init -> () + | Parsing_length -> parse_error premature_end_of_input + end + + module L =3D Lexer + + module Stack =3D struct + type t =3D + | Empty + | Open of t + | Sexp of Sexp.t * t + + let open_paren stack =3D Open stack + + let close_paren =3D + let rec loop acc =3D function + | Empty -> + parse_error "right parenthesis without matching left parenthes= is" + | Sexp (sexp, t) -> loop (sexp :: acc) t + | Open t -> Sexp (List acc, t) + in + fun t -> loop [] t + + let to_list =3D + let rec loop acc =3D function + | Empty -> acc + | Sexp (sexp, t) -> loop (sexp :: acc) t + | Open _ -> parse_error premature_end_of_input + in + fun t -> loop [] t + + let add_atom s stack =3D Sexp (Atom s, stack) + + let add_token (x : [ `other ] Lexer.token) stack =3D + match x with + | L.Await -> stack + | L.Lparen -> open_paren stack + | L.Rparen -> close_paren stack + end + end + + open Parser + + let feed_eoi_single lexer stack =3D + match + Lexer.feed_eoi lexer; + Stack.to_list stack + with + | exception Parse_error msg -> Error msg + | [ x ] -> Ok x + | [] -> Error premature_end_of_input + | _ :: _ :: _ -> assert false + + let feed_eoi_many lexer stack =3D + match + Lexer.feed_eoi lexer; + Stack.to_list stack + with + | exception Parse_error msg -> Error msg + | l -> Ok l + + let one_token s pos len lexer stack k =3D + match Lexer.feed lexer (String.unsafe_get s pos) with + | exception Parse_error msg -> Error (pos, msg) + | L.Atom atom_len -> ( + match String.sub s (pos + 1) atom_len with + | exception _ -> Error (len, premature_end_of_input) + | atom -> + let pos =3D pos + 1 + atom_len in + k s pos len lexer (Stack.add_atom atom stack) ) + | (L.Await | L.Lparen | L.Rparen) as x -> ( + match Stack.add_token x stack with + | exception Parse_error msg -> Error (pos, msg) + | stack -> k s (pos + 1) len lexer stack ) + [@@inlined always] + + let parse_string =3D + let rec loop s pos len lexer stack =3D + if pos =3D len then + match feed_eoi_single lexer stack with + | Error msg -> Error (pos, msg) + | Ok _ as ok -> ok + else + one_token s pos len lexer stack cont + and cont s pos len lexer stack =3D + match stack with + | Stack.Sexp (sexp, Empty) -> + if pos =3D len then + Ok sexp + else + Error (pos, "data after canonical S-expression") + | stack -> loop s pos len lexer stack + in + fun s -> loop s 0 (String.length s) (Lexer.create ()) Empty + + let parse_string_many =3D + let rec loop s pos len lexer stack =3D + if pos =3D len then + match feed_eoi_many lexer stack with + | Error msg -> Error (pos, msg) + | Ok _ as ok -> ok + else + one_token s pos len lexer stack loop + in + fun s -> loop s 0 (String.length s) (Lexer.create ()) Empty + + let one_token ic c lexer stack =3D + match Lexer.feed lexer c with + | L.Atom n -> ( + match really_input_string ic n with + | exception End_of_file -> raise (Parse_error premature_end_of_input) + | s -> Stack.add_atom s stack ) + | (L.Await | L.Lparen | L.Rparen) as x -> Stack.add_token x stack + + let input_opt =3D + let rec loop ic lexer stack =3D + let c =3D input_char ic in + match one_token ic c lexer stack with + | Sexp (sexp, Empty) -> Ok (Some sexp) + | stack -> loop ic lexer stack + in + fun ic -> + let lexer =3D Lexer.create () in + match input_char ic with + | exception End_of_file -> Ok None + | c -> ( + try + match Lexer.feed lexer c with + | L.Atom _ -> assert false + | (L.Await | L.Lparen | L.Rparen) as x -> + loop ic lexer (Stack.add_token x Empty) + with + | Parse_error msg -> Error msg + | End_of_file -> Error premature_end_of_input ) + + let input ic =3D + match input_opt ic with + | Ok None -> Error premature_end_of_input + | Ok (Some x) -> Ok x + | Error msg -> Error msg + + let input_many =3D + let rec loop ic lexer stack =3D + match input_char ic with + | exception End_of_file -> + Lexer.feed_eoi lexer; + Ok (Stack.to_list stack) + | c -> loop ic lexer (one_token ic c lexer stack) + in + fun ic -> + try loop ic (Lexer.create ()) Empty with Parse_error msg -> Error msg + + let serialised_length =3D + let rec loop acc t =3D + match t with + | Atom s -> + let len =3D String.length s in + let x =3D ref len in + let len_len =3D ref 1 in + while !x > 9 do + x :=3D !x / 10; + incr len_len + done; + acc + !len_len + 1 + len + | List l -> List.fold_left loop acc l + in + fun t -> loop 0 t + + let to_buffer buf sexp =3D + let rec loop =3D function + | Atom str -> + Buffer.add_string buf (string_of_int (String.length str)); + Buffer.add_string buf ":"; + Buffer.add_string buf str + | List e -> + Buffer.add_char buf '('; + List.iter loop e; + Buffer.add_char buf ')' + in + loop sexp + + let to_string sexp =3D + let buf =3D Buffer.create (serialised_length sexp) in + to_buffer buf sexp; + Buffer.contents buf + + let to_channel oc sexp =3D + let rec loop =3D function + | Atom str -> + output_string oc (string_of_int (String.length str)); + output_char oc ':'; + output_string oc str + | List l -> + output_char oc '('; + List.iter loop l; + output_char oc ')' + in + loop sexp + + module type Input =3D sig + type t + + module Monad : Monad + + val read_string : t -> int -> (string, string) Result.t Monad.t + + val read_char : t -> (char, string) Result.t Monad.t + end + + module Make_parser (Input : Input) =3D struct + open Input.Monad + + let ( >>=3D ) =3D bind + + let ( >>=3D* ) m f =3D + m >>=3D function + | Error _ as err -> return err + | Ok x -> f x + + let one_token input c lexer stack =3D + match Lexer.feed lexer c with + | exception Parse_error msg -> return (Error msg) + | L.Atom n -> + Input.read_string input n >>=3D* fun s -> + return (Ok (Stack.add_atom s stack)) + | (L.Await | L.Lparen | L.Rparen) as x -> + return + ( match Stack.add_token x stack with + | exception Parse_error msg -> Error msg + | stack -> Ok stack ) + + let parse =3D + let rec loop input lexer stack =3D + Input.read_char input >>=3D function + | Error _ -> return (feed_eoi_single lexer stack) + | Ok c -> ( + one_token input c lexer stack >>=3D* function + | Sexp (sexp, Empty) -> return (Ok sexp) + | stack -> loop input lexer stack ) + in + fun input -> loop input (Lexer.create ()) Empty + + let parse_many =3D + let rec loop input lexer stack =3D + Input.read_char input >>=3D function + | Error _ -> return (feed_eoi_many lexer stack) + | Ok c -> + one_token input c lexer stack >>=3D* fun stack -> loop input lex= er stack + in + fun input -> loop input (Lexer.create ()) Empty + end +end diff --git a/tools/ocaml/duniverse/csexp/src/csexp.mli b/tools/ocaml/dunive= rse/csexp/src/csexp.mli new file mode 100644 index 0000000000..f1e8683f63 --- /dev/null +++ b/tools/ocaml/duniverse/csexp/src/csexp.mli @@ -0,0 +1,369 @@ +(** Canonical S-expressions *) + +(** This module provides minimal support for reading and writing S-express= ions + in canonical form. + + https://en.wikipedia.org/wiki/Canonical_S-expressions + + Note that because the canonical representation of S-expressions is so + simple, this module doesn't go out of his way to provide a fully gener= ic + parser and printer and instead just provides a few simple functions. I= f you + are using fancy input sources, simply copy the parser and adapt it. The + format is so simple that it's pretty difficult to get it wrong by acci= dent. + + To avoid a dependency on a particular S-expression library, the only m= odule + of this library is parameterised by the type of S-expressions. + + {[ + let rec print =3D function + | Atom str -> Printf.printf "%d:%s" (String.length s) + | List l -> List.iter print l + ]} *) + +module type Sexp =3D sig + type t =3D + | Atom of string + | List of t list +end + +module Make (Sexp : Sexp) : sig + (** {2 Parsing} *) + + (** [parse_string s] parses a single S-expression encoded in canonical f= orm in + [s]. It is an error for [s] to contain a S-expression followed by mo= re + data. In case of error, the offset of the error as well as an error + message is returned. *) + val parse_string : string -> (Sexp.t, int * string) Result.t + + (** [parse_string s] parses a sequence of S-expressions encoded in canon= ical + form in [s] *) + val parse_string_many : string -> (Sexp.t list, int * string) Result.t + + (** Read exactly one canonical S-expressions from the given channel. Not= e that + this function never raises [End_of_file]. Instead, it returns [Error= ]. *) + val input : in_channel -> (Sexp.t, string) Result.t + + (** Same as [input] but returns [Ok None] if the end of file has already= been + reached. If some more characters are available but the end of file is + reached before reading a complete S-expression, this function returns + [Error]. *) + val input_opt : in_channel -> (Sexp.t option, string) Result.t + + (** Read many S-expressions until the end of input is reached. *) + val input_many : in_channel -> (Sexp.t list, string) Result.t + + (** {2 Serialising} *) + + (** The length of the serialised representation of a S-expression *) + val serialised_length : Sexp.t -> int + + (** [to_string sexp] converts S-expression [sexp] to a string in canonic= al + form. *) + val to_string : Sexp.t -> string + + (** [to_buffer buf sexp] outputs the S-expression [sexp] converted to its + canonical form to buffer [buf]. *) + val to_buffer : Buffer.t -> Sexp.t -> unit + + (** [output oc sexp] outputs the S-expression [sexp] converted to its + canonical form to channel [oc]. *) + val to_channel : out_channel -> Sexp.t -> unit + + (** {3 Low level parser} + + For efficiently parsing from sources other than strings or input cha= nnel. + For instance in Lwt or Async programs. *) + + module Parser : sig + (** The [Parser] module offers an API that is a balance between sharin= g the + common logic of parsing canonical S-expressions while allowing to = write + parsers that are as efficient as possible, both in terms of speed = and + allocations. A carefully written parser using this API will be: + + - fast + - perform minimal allocations + - perform zero [caml_modify] (a slow function of the OCaml runtime= that + is emitted when mutating a constructed value) + + {2 Lexers} + + To parse using this API, you must first create a lexer via + {!Lexer.create}. The lexer is responsible for scanning the input a= nd + forming tokens. The user must feed characters read from the input = one by + one to the lexer until it yields a token. For instance: + + {[ + # let lexer =3D Lexer.create ();; + val lexer : Lexer.t =3D + # Lexer.feed lexer '(';; + - : [ `atom | `other ] Lexer.token =3D Lparen + # Lexer.feed lexer ')';; + - : [ `atom | `other ] Lexer.token =3D Rparen + ]} + + When the lexer doesn't have enough to return a token, it simply re= turns + the special token {!Lexer.Await}: + + {[ + # Lexer.feed lexer '1';; + - : [ `atom | `other ] Lexer.token =3D Await + ]} + + Note that since atoms of canonical S-expressions do not need quoti= ng, + they are always represented as a contiguous sequence of characters= that + don't need further processing. To achieve maximum efficiency, the = lexer + only returns the length of the atom and it is the responsibility o= f the + caller to extract the atom from the input source: + + {[ + # Lexer.feed lexer '2';; + - : [ `atom | `other ] Lexer.token =3D Await + # Lexer.feed lexer ':';; + - : [ `atom | `other ] Lexer.token =3D Atom 2 + ]} + + When getting [Atom n], the caller should then proceed to read the = next + [n] characters of the input as a string. For instance, if the inpu= t is + an [in_channel] the caller should proceed with + [really_input_string ic n]. + + Finally, when the end of input is reached the user should call + {!Lexer.feed_eoi} to make sure the lexer is not awaiting more inpu= t. If + that is the case, {!Lexer.feed_eoi} will raise: + + {[ + # Lexer.feed lexer '1';; + - : [ `atom | `other ] Lexer.token =3D Await + # Lexer.feed_eoi lexer;; + Exception: Parse_error "premature end of input". + ]} + + {2 Parsing stacks} + + The lexer doesn't keep track of the structure of the S-expressions= . In + order to construct a whole structured S-expressions, the caller mu= st + maintain a parsing stack via the {!Stack} module. A {!Stack.t} val= ue + simply represent a parsed prefix in reverse order. + + For instance, the prefix "1:x((1:y1:z)" will be represented as: + + {[ Sexp (List [ Atom "y"; Atom "z" ], Open (Sexp (Atom "x", Empty)= )) ]} + + The {!Stack} module offers various primitives to open or close + parentheses or insert an atom. And for convenience it provides a + function {!Stack.add_token} that takes the output of {!Lexer.feed} + directly: + + {[ + # Stack.add_token Rparen Empty;; + - : Stack.t =3D Open Empty + # Stack.add_token Lparen (Open Empty);; + - : Stack.t =3D Sexp (List [], Empty) + ]} + + Note that {!Stack.add_token} doesn't accept [Atom _]. This is enfo= rced + at the type level by a GADT. The reason for this is that in order = to + insert an atom, the user must have fetched the contents of the atom + themselves. In order to insert an atom into a stack, you can use t= he + function {!Stack.add_atom}: + + {[ + # Stack.add_atom "foo" (Open Empty);; + - : Stack.t =3D Sexp (Atom "foo", Open Empty) + ]} + + When parsing is finished, one may call the function {!Stack.to_lis= t} in + order to extract all the toplevel S-expressions from the stack: + + {[ + # Stack.to_list (Sexp (Atom "x", Sexp (List [Atom "y"], Empty)))= ;; + - : Sexp.t list =3D [List [Atom "y"; Atom "x"]] + ]} + + If instead you want to stop parsing as soon a single full S-expres= sion + has been discovered, you can match on the structure of the stack. = If the + stack is of the form [Sexp (_, Empty)], then you know that exactly= one + S-expression has been parsed and you can stop there. + + {2 Parsing errors} + + In order to reduce allocations to a minumim, parsing errors are re= ported + via the exception {!Parse_error}. It is the responsibility of the = caller + to catch this exception and return it as an [Error _] value. Funct= ions + that may raise [Parse_error] are documented as such. + + When extracting an atom and the input doesn't have enough characte= rs + left, the user may raise [Parse_error premature_end_of_input]. Thi= s will + produce an error message similar to what the various high-level + functions of this library produce. + + {2 Building a parsing function} + + Parsing functions should always follow the following pattern: + + + create a lexer and start with an empty parsing stack + + iterate over the input, feeding the lexer characters one by one.= When + the lexer returns [Atom n], fetch the next [n] characters from t= he + input to form an atom + + update the stack via [Stack.add_atom] or [Stack.add_token] + + if parsing the whole input, call [Lexer.feed_eoi] when the end of + input is reached, otherwise stop as soon as the stack is of the = form + [Sexp (_, Empty)] - + + For instance, to parse a string as a list of S-expressions: + + {[ + module Sexp =3D struct + type t =3D + | Atom of string + | List of t list + end + + module Csexp =3D Csexp.Make (Sexp) + + let extract_atom s pos len =3D + match String.sub s pos len with + | exception _ -> + (* Turn out-of-bounds errors into [Parse_error] *) + raise (Parse_error premature_end_of_input) + | s -> s + + let parse_string =3D + let open Csexp.Parser in + let rec loop s pos len lexer stack =3D + if pos =3D len then ( + Lexer.feed_eoi lexer; + Stack.to_list stack + ) else + match Lexer.feed lexer (String.unsafe_get s pos) with + | Atom atom_len -> + let atom =3D extract_atom s (pos + 1) atom_len in + loop s (pos + 1 + atom) len lexer (Stack.add_atom atom s= tack) + | (Await | Lparen | Rparen) as x -> + loop s (pos + 1) len lexer (Stack.add_token x stack) + in + fun s -> + match loop s 0 (String.length s) (Lexer.create ()) Empty with + | v -> Ok v + | exception Parse_error msg -> Error msg + ]} *) + + exception Parse_error of string + + (** Error message signaling the end of input was reached prematurely. = You + can use this when extracting an atom from the input and the input + doesn't have enough characters. *) + val premature_end_of_input : string + + module Lexer : sig + (** Lexical analyser *) + + type t + + val create : unit -> t + + type _ token =3D + | Await : [> `other ] token + | Lparen : [> `other ] token + | Rparen : [> `other ] token + | Atom : int -> [> `atom ] token + + (** Feed a character to the parser. + + @raise Parse_error *) + val feed : t -> char -> [ `other | `atom ] token + + (** Feed the end of input to the parser. + + You should call this function when the end of input has been rea= ched + in order to ensure that the lexer is not awaiting more input, wh= ich + would be an error. + + @raise Parse_error if the lexer is awaiting more input *) + val feed_eoi : t -> unit + end + + module Stack : sig + (** Parsing stack *) + + type t =3D + | Empty + | Open of t + | Sexp of Sexp.t * t + + (** Extract the list of full S-expressions contained in a stack. + + For instance: + + {[ + # to_list (Sexp (Atom "y", Sexp (Atom "x", Empty)));; + - : Stack.t list =3D [Atom "x"; Atom "y"] + ]} + @raise Parse_error if the stack contains open parentheses that h= as not + been closed. *) + val to_list : t -> Sexp.t list + + (** Add a left parenthesis. *) + val open_paren : t -> t + + (** Add a right parenthesis. Raise [Parse_error] if the stack contai= ns no + opened parentheses. + + For instance: + + {[ + # close_paren (Sexp (Atom "y", Sexp (Atom "x", Open Empty)));; + - : Stack.t =3D Sexp (List [Atom "x"; Atom "y"], Empty) + ]} + @raise Parse_error if the stack contains no open open parenthesi= s. *) + val close_paren : t -> t + + (** Insert an atom in the parsing stack: + + {[ + # add_atom "foo" Empty;; + - : Stack.t =3D Sexp (Atom "foo", Empty) + ]} *) + val add_atom : string -> t -> t + + (** Add a token as returned by the lexer. + + @raise Parse_error *) + val add_token : [ `other ] Lexer.token -> t -> t + end + end + + (** {3 Deprecated low-level parser} *) + + (** The above are deprecated as the {!Input} signature does not allow to + distinguish between IO errors and end of input conditions. Additiona= lly, + the use of monads tend to produce parsers that allocates a lot. + + It is recommended to use the {!Parser} module instead. *) + + module type Input =3D sig + type t + + module Monad : sig + type 'a t + + val return : 'a -> 'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + end + + val read_string : t -> int -> (string, string) Result.t Monad.t + + val read_char : t -> (char, string) Result.t Monad.t + end + [@@deprecated "Use Parser module instead"] + + [@@@warning "-3"] + + module Make_parser (Input : Input) : sig + val parse : Input.t -> (Sexp.t, string) Result.t Input.Monad.t + + val parse_many : Input.t -> (Sexp.t list, string) Result.t Input.Monad= .t + end + [@@deprecated "Use Parser module instead"] +end diff --git a/tools/ocaml/duniverse/csexp/src/dune b/tools/ocaml/duniverse/c= sexp/src/dune new file mode 100644 index 0000000000..bd4b3b7ea6 --- /dev/null +++ b/tools/ocaml/duniverse/csexp/src/dune @@ -0,0 +1,3 @@ +(library + (public_name csexp) + (libraries result)) diff --git a/tools/ocaml/duniverse/csexp/test/dune b/tools/ocaml/duniverse/= csexp/test/dune new file mode 100644 index 0000000000..3284f4b3ca --- /dev/null +++ b/tools/ocaml/duniverse/csexp/test/dune @@ -0,0 +1,6 @@ +(library + (name csexp_tests) + (libraries csexp) + (inline_tests) + (preprocess + (pps ppx_expect))) diff --git a/tools/ocaml/duniverse/csexp/test/test.ml b/tools/ocaml/duniver= se/csexp/test/test.ml new file mode 100644 index 0000000000..9ea426f8bc --- /dev/null +++ b/tools/ocaml/duniverse/csexp/test/test.ml @@ -0,0 +1,142 @@ +module Sexp =3D struct + type t =3D + | Atom of string + | List of t list +end + +module Csexp =3D Csexp.Make (Sexp) +open Csexp + +let roundtrip x =3D + let str =3D to_string x in + match parse_string str with + | Result.Error (_, msg) -> failwith msg + | Result.Ok exp -> + assert (exp =3D x); + print_string str + +let%expect_test _ =3D + roundtrip (Sexp.Atom "foo"); + [%expect {|3:foo|}] + +let%expect_test _ =3D + roundtrip (Sexp.List []); + [%expect {|()|}] + +let%expect_test _ =3D + roundtrip (Sexp.List [ Sexp.Atom "Hello"; Sexp.Atom "World!" ]); + [%expect {|(5:Hello6:World!)|}] + +let%expect_test _ =3D + roundtrip + (Sexp.List + [ Sexp.List + [ Sexp.Atom "metadata" + ; Sexp.List [ Sexp.Atom "foo"; Sexp.Atom "bar" ] + ] + ; Sexp.List + [ Sexp.Atom "produced-files" + ; Sexp.List + [ Sexp.List + [ Sexp.Atom "/tmp/coin" + ; Sexp.Atom + "/tmp/dune-memory/v2/files/b2/b295e63b0b8e8fae971d9= c493be0d261.1" + ] + ] + ] + ]); + [%expect + {|((8:metadata(3:foo3:bar))(14:produced-files((9:/tmp/coin63:/tmp/dune= -memory/v2/files/b2/b295e63b0b8e8fae971d9c493be0d261.1))))|}] + +let print_parsed r =3D + match r with + | Error msg -> Printf.printf "Error %S" msg + | Ok sexp -> Printf.printf "Ok %S" (Csexp.to_string sexp) + +let parse s =3D + match parse_string s with + | Ok x -> print_parsed (Ok x) + | Error (_, msg) -> print_parsed (Error msg) + +let%expect_test _ =3D + parse "(3:foo)"; + [%expect {| + Ok "(3:foo)" |}] + +let%expect_test _ =3D + parse ""; + [%expect {| Error "premature end of input" |}] + +let%expect_test _ =3D + parse "("; + [%expect {| Error "premature end of input" |}] + +let%expect_test _ =3D + parse "(a)"; + [%expect {| Error "invalid character 'a', expected '(', ')' or '0'..'9'"= |}] + +let%expect_test _ =3D + parse "(:)"; + [%expect {| Error "invalid character ':', expected '(', ')' or '0'..'9'"= |}] + +let%expect_test _ =3D + parse "(4:foo)"; + [%expect {| Error "premature end of input" |}] + +let%expect_test _ =3D + parse "(5:foo)"; + [%expect {| Error "premature end of input" |}] + +let%expect_test _ =3D + parse "(3:foo)"; + [%expect {| Ok "(3:foo)" |}] + +let sexp_then_stuff s =3D + let fn, oc =3D Filename.open_temp_file "csexp-test" "" ~mode:[ Open_bina= ry ] in + let delete =3D lazy (Sys.remove fn) in + at_exit (fun () -> Lazy.force delete); + output_string oc s; + close_out oc; + let ic =3D open_in_bin fn in + Csexp.input ic |> print_parsed; + print_newline (); + print_char (input_char ic); + close_in ic; + Lazy.force delete + +let%expect_test _ =3D + sexp_then_stuff "(3:foo)(3:foo)"; + [%expect {| + Ok "(3:foo)" + ( |}] + +let%expect_test _ =3D + sexp_then_stuff "(3:foo)Additional_stuff"; + [%expect {| + Ok "(3:foo)" + A |}] + +let%expect_test _ =3D + parse "(3:foo)(3:foo)"; + [%expect {| Error "data after canonical S-expression" |}] + +let%expect_test _ =3D + parse "(3:foo)additional_stuff"; + [%expect {| Error "data after canonical S-expression" |}] + +let parse_many s =3D + match parse_string_many s with + | Error (_, msg) -> print_parsed (Error msg) + | Ok xs -> xs |> List.iter (fun x -> print_parsed (Ok x)) + +let%expect_test "parse_string_many - parse empty string" =3D + parse_many ""; + [%expect {| |}] + +let%expect_test "parse_string_many - parse a single csexp" =3D + parse_many "(3:foo)"; + [%expect {| Ok "(3:foo)" |}] + +let%expect_test "parse_string_many - parse many csexp" =3D + parse_many "(3:foo)(3:bar)"; + [%expect {| Ok "(3:foo)"Ok "(3:bar)" |}] diff --git a/tools/ocaml/duniverse/dune b/tools/ocaml/duniverse/dune new file mode 100644 index 0000000000..ad2ec9467e --- /dev/null +++ b/tools/ocaml/duniverse/dune @@ -0,0 +1,4 @@ +; This file is generated by duniverse. +; Be aware that it is likely to be overwritten by your next duniverse pull= invocation. + +(vendored_dirs *) diff --git a/tools/ocaml/duniverse/fmt/.gitignore b/tools/ocaml/duniverse/f= mt/.gitignore new file mode 100644 index 0000000000..10916e3a45 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/.gitignore @@ -0,0 +1,8 @@ +BRZO +_b0 +_build +tmp +*~ +\.\#* +\#*# +*.install \ No newline at end of file diff --git a/tools/ocaml/duniverse/fmt/.ocp-indent b/tools/ocaml/duniverse/= fmt/.ocp-indent new file mode 100644 index 0000000000..ad2fbcbfa5 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/.ocp-indent @@ -0,0 +1 @@ +strict_with=3Dalways,match_clause=3D4,strict_else=3Dnever \ No newline at end of file diff --git a/tools/ocaml/duniverse/fmt/CHANGES.md b/tools/ocaml/duniverse/f= mt/CHANGES.md new file mode 100644 index 0000000000..6ddddbcc26 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/CHANGES.md @@ -0,0 +1,98 @@ +v0.8.8 2019-08-01 Zagreb +------------------------ + +Fix build on 32-bit platforms. + +v0.8.7 2019-07-21 Zagreb +------------------------ + +* Require OCaml 4.05. +* Add `Fmt.hex` and friends. Support for hex dumping. + Thanks to David Kaloper Mer=C5=A1injak for the design and implementation= .. +* Add `Fmt.si_size` to format integer magnitudes using SI prefixes. +* Add `Fmt.uint64_ns_span` to format time spans. +* Add `Fmt.truncated` to truncate your long strings. +* Add `Fmt.flush`, has the effect of `Format.pp_print_flush`. +* Add `Fmt.[Dump.]{field,record}` for records (#9). +* Add `Fmt.concat` to apply a list of formatters to a value. +* Add `Fmt.{semi,sps}`, separators. +* Add `Fmt.{error,error_msg}` to format `result` values. +* Add `Fmt.failwith_notrace`. +* Add `Fmt.( ++ )`, alias for `Fmt.append`. +* Add `Fmt.Dump.string`. +* Add more ANSI tty formatting styles and make them composable. +* Change `Fmt.{const,comma,cut,sp}`, generalize signature. +* Change `Fmt.append`, incompatible signature. Use `Fmt.(pair ~sep:nop)` i= f=20 + you were using it (backward compatible with earlier versions of `Fmt`). +* Deprecate `Fmt.{strf,kstrf,strf_like}` in favor of `Fmt.{str,kstr,str_li= ke}`. +* Deprecate `Fmt.{always,unit}` in favor of `Fmt.any`. +* Deprecate `Fmt.{prefix,suffix}` (specializes Fmt.( ++ )). +* Deprecate `Fmt.styled_unit`. +* No longer subvert the `Format` tag system to do dirty things. + Thanks to David Kaloper Mer=C5=A1injak for the work. + +v0.8.6 2019-04-01 La Forclaz (VS) +--------------------------------- + +* Add `Fmt.{seq,Dump.seq}` to format `'a Seq.t` values. Thanks to + Hezekiah M. Carty for the patch. +* Handle `Pervasives`'s deprecation via dependency on `stdlib-shims`. +* `Fmt.Dump.signal` format signals added in 4.03. +* Fix toplevel initialization for omod (#33). +* Require at least OCaml 4.03 (drops dependency on `result` and `uchar` + compatibility packages). + +v0.8.5 2017-12-27 La Forclaz (VS) +--------------------------------- + +* Fix `Fmt.{kstrf,strf_like}` when they are partially applied + and repeatedly called. Thanks to Thomas Gazagnaire for the report. +* Add `Fmt.comma`. +* Relax the `Fmt.(invalid_arg, failwith)` type signature. Thanks to + Hezekiah M. Carty for the patch. + +v0.8.4 2017-07-08 Zagreb +------------------------ + +* Add `Fmt.{invalid_arg,failwith}`. Thanks to Hezekiah M. Carty for the pa= tch. + +v0.8.3 2017-04-13 La Forclaz (VS) +--------------------------------- + +* Fix `Fmt.exn_backtrace`. Thanks to Thomas Leonard for the report. + +v0.8.2 2017-03-20 La Forclaz (VS) +--------------------------------- + +* Fix `META` file. + +v0.8.1 2017-03-15 La Forclaz (VS) +--------------------------------- + +* `Fmt_tty.setup`, treat empty `TERM` env var as dumb. +* Add `Fmt.Dump.uchar` formatter for inspecting `Uchar.t` values. + +v0.8.0 2016-05-23 La Forclaz (VS) +--------------------------------- + +* Build depend on topkg. +* Relicense from BSD3 to ISC. +* Tweak `Fmt.Dump.option` to indent like in sources. +* Add `Fmt.Dump.signal` formatter for `Sys` signal numbers. +* Add `Fmt[.Dump].result`, formatter for `result` values. +* Add `Fmt.{words,paragraphs}` formatters on US-ASCII strings. +* Add `Fmt.exn[_backtrace]`. Thanks to Edwin T=C3=B6r=C3=B6k for suggestin= g. +* Add `Fmt.quote`. +* Rename `Fmt.text_range` to `Fmt.text_loc` and simplify output + when range is a position. + +v0.7.1 2015-12-03 Cambridge (UK) +-------------------------------- + +* Add optional cmdliner support. See the `Fmt_cli` module provided + by the package `fmt.cli`. + +v0.7.0 2015-09-17 Cambridge (UK) +-------------------------------- + +First Release. diff --git a/tools/ocaml/duniverse/fmt/LICENSE.md b/tools/ocaml/duniverse/f= mt/LICENSE.md new file mode 100644 index 0000000000..52fe16df4b --- /dev/null +++ b/tools/ocaml/duniverse/fmt/LICENSE.md @@ -0,0 +1,13 @@ +Copyright (c) 2016 The fmt programmers + +Permission to use, copy, modify, and/or 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. diff --git a/tools/ocaml/duniverse/fmt/README.md b/tools/ocaml/duniverse/fm= t/README.md new file mode 100644 index 0000000000..4809210590 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/README.md @@ -0,0 +1,35 @@ +Fmt =E2=80=94 OCaml Format pretty-printer combinators +--------------------------------------------------------------------------= ----- +%%VERSION%% + +Fmt exposes combinators to devise `Format` pretty-printing functions. + +Fmt depends only on the OCaml standard library. The optional `Fmt_tty` +library that allows to setup formatters for terminal color output +depends on the Unix library. The optional `Fmt_cli` library that +provides command line support for Fmt depends on [`Cmdliner`][cmdliner]. + +Fmt is distributed under the ISC license. + +[cmdliner]: http://erratique.ch/software/cmdliner + +Home page: http://erratique.ch/software/fmt =20 + +## Installation + +Fmt can be installed with `opam`: + + opam install fmt + opam install base-unix cmdliner fmt # Install all optional libraries + +If you don't use `opam` consult the [`opam`](opam) file for build +instructions. + +## Documentation + +The documentation and API reference is automatically generated by +`ocamldoc` from the interfaces. It can be consulted [online][doc] +and there is a generated version in the `doc` directory of the +distribution. + +[doc]: http://erratique.ch/software/fmt/doc/ diff --git a/tools/ocaml/duniverse/fmt/_tags b/tools/ocaml/duniverse/fmt/_t= ags new file mode 100644 index 0000000000..729441abb9 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/_tags @@ -0,0 +1,7 @@ +true : bin_annot, safe_string, package(seq), package(stdlib-shims) +<_b0> : -traverse + : include + : package(unix) + : package(cmdliner) + : package(compiler-libs.toplevel) + : include diff --git a/tools/ocaml/duniverse/fmt/doc/api.odocl b/tools/ocaml/dunivers= e/fmt/doc/api.odocl new file mode 100644 index 0000000000..f6608c354b --- /dev/null +++ b/tools/ocaml/duniverse/fmt/doc/api.odocl @@ -0,0 +1,3 @@ +Fmt +Fmt_tty +Fmt_cli diff --git a/tools/ocaml/duniverse/fmt/doc/index.mld b/tools/ocaml/dunivers= e/fmt/doc/index.mld new file mode 100644 index 0000000000..eb2c91cbbd --- /dev/null +++ b/tools/ocaml/duniverse/fmt/doc/index.mld @@ -0,0 +1,11 @@ +{0 Fmt {%html: %%VERSION%%%}} + +Fmt exposes combinators to devise {!Format} pretty-printing functions. + +{1:api API} + +{!modules: +Fmt +Fmt_tty +Fmt_cli +} diff --git a/tools/ocaml/duniverse/fmt/dune-project b/tools/ocaml/duniverse= /fmt/dune-project new file mode 100644 index 0000000000..c9c5bebf07 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.0) +(name fmt) diff --git a/tools/ocaml/duniverse/fmt/fmt.opam b/tools/ocaml/duniverse/fmt= /fmt.opam new file mode 100644 index 0000000000..2cce5b7136 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/fmt.opam @@ -0,0 +1,35 @@ +opam-version: "2.0" +maintainer: "Daniel B=C3=BCnzli " +authors: [ "The fmt programmers" ] +homepage: "https://erratique.ch/software/fmt" +doc: "https://erratique.ch/software/fmt" +dev-repo: "git+https://github.com/dune-universe/fmt.git" +bug-reports: "https://github.com/dbuenzli/fmt/issues" +tags: [ "string" "format" "pretty-print" "org:erratique" ] +license: "ISC" +build: [ + [ "dune" "build" "-p" name "-j" jobs ] +] +run-test: [ + [ "dune" "runtest" "-p" name "-j" jobs ] +] +depends: [ + "dune" + "ocaml" {>=3D "4.07.0"} + "stdlib-shims" +] +depopts: [ "base-unix" "cmdliner" ] +conflicts: [ "cmdliner" {< "0.9.8"} ] +synopsis: "OCaml Format pretty-printer combinators" +description: """ +Fmt exposes combinators to devise `Format` pretty-printing functions. +Fmt depends only on the OCaml standard library. The optional `Fmt_tty` +library that allows to setup formatters for terminal color output +depends on the Unix library. The optional `Fmt_cli` library that +provides command line support for Fmt depends on [`Cmdliner`][cmdliner]. +Fmt is distributed under the ISC license. +[cmdliner]: http://erratique.ch/software/cmdliner +""" +url { + src: "git+https://github.com/dune-universe/fmt#duniverse-v0.8.8" +} diff --git a/tools/ocaml/duniverse/fmt/pkg/META b/tools/ocaml/duniverse/fmt= /pkg/META new file mode 100644 index 0000000000..e379f4ed88 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/pkg/META @@ -0,0 +1,40 @@ +description =3D "OCaml Format pretty-printer combinators" +version =3D "%%VERSION_NUM%%" +requires =3D "seq stdlib-shims" +archive(byte) =3D "fmt.cma" +archive(native) =3D "fmt.cmxa" +plugin(byte) =3D "fmt.cma" +plugin(native) =3D "fmt.cmxs" + +package "tty" ( + description =3D "Fmt TTY setup" + version =3D "%%VERSION_NUM%%" + requires =3D "unix fmt" + archive(byte) =3D "fmt_tty.cma" + archive(native) =3D "fmt_tty.cmxa" + plugin(byte) =3D "fmt_tty.cma" + plugin(native) =3D "fmt_tty.cmxs" + exists_if =3D "fmt_tty.cma" +) + +package "cli" ( + description =3D "Cmdliner support for Fmt" + version =3D "%%VERSION_NUM%%" + requires =3D "cmdliner fmt" + archive(byte) =3D "fmt_cli.cma" + archive(native) =3D "fmt_cli.cmxa" + plugin(byte) =3D "fmt_cli.cma" + plugin(native) =3D "fmt_cli.cmxs" + exists_if =3D "fmt_cli.cma" +) + +package "top" ( + description =3D "Fmt toplevel support" + version =3D "%%VERSION_NUM%%" + requires =3D "fmt fmt.tty" + archive(byte) =3D "fmt_top.cma" + archive(native) =3D "fmt_top.cmxa" + plugin(byte) =3D "fmt_top.cma" + plugin(native) =3D "fmt_top.cmxs" + exists_if =3D "fmt_top.cma" +) diff --git a/tools/ocaml/duniverse/fmt/pkg/pkg.ml b/tools/ocaml/duniverse/f= mt/pkg/pkg.ml new file mode 100755 index 0000000000..959b02242c --- /dev/null +++ b/tools/ocaml/duniverse/fmt/pkg/pkg.ml @@ -0,0 +1,18 @@ +#!/usr/bin/env ocaml +#use "topfind" +#require "topkg" +open Topkg + +let unix =3D Conf.with_pkg "base-unix" +let cmdliner =3D Conf.with_pkg "cmdliner" + +let () =3D + Pkg.describe "fmt" @@ fun c -> + let unix =3D Conf.value c unix in + let cmdliner =3D Conf.value c cmdliner in + Ok [ Pkg.mllib "src/fmt.mllib"; + Pkg.mllib ~cond:unix "src/fmt_tty.mllib"; + Pkg.mllib ~cond:cmdliner "src/fmt_cli.mllib"; + Pkg.mllib ~api:[] "src/fmt_top.mllib"; + Pkg.lib "src/fmt_tty_top_init.ml"; + Pkg.test "test/test"; ] diff --git a/tools/ocaml/duniverse/fmt/src/dune b/tools/ocaml/duniverse/fmt= /src/dune new file mode 100644 index 0000000000..ece3f9958b --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/dune @@ -0,0 +1,30 @@ +(library + (name fmt) + (public_name fmt) + (libraries result) + (modules fmt) + (flags :standard -w -3-6-27-34-50) + (wrapped false)) + +(library + (name fmt_tty) + (public_name fmt.tty) + (libraries unix fmt) + (modules fmt_tty) + (flags :standard -w -3-6-27) + (wrapped false)) + +(library + (name fmt_cli) + (public_name fmt.cli) + (libraries fmt cmdliner) + (modules fmt_cli) + (flags :standard -w -3-6-27) + (wrapped false)) + +(library + (name fmt_top) + (public_name fmt.top) + (libraries compiler-libs.toplevel fmt) + (modules fmt_top) + (wrapped false)) diff --git a/tools/ocaml/duniverse/fmt/src/fmt.ml b/tools/ocaml/duniverse/f= mt/src/fmt.ml new file mode 100644 index 0000000000..29f42d6bf2 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt.ml @@ -0,0 +1,787 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2014 The fmt programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +let invalid_arg' =3D invalid_arg + +(* Errors *) + +let err_str_formatter =3D "Format.str_formatter can't be set." + +(* Standard outputs *) + +let stdout =3D Format.std_formatter +let stderr =3D Format.err_formatter + +(* Formatting *) + +let pf =3D Format.fprintf +let pr =3D Format.printf +let epr =3D Format.eprintf +let str =3D Format.asprintf +let kpf =3D Format.kfprintf +let kstr =3D Format.kasprintf +let failwith fmt =3D kstr failwith fmt +let failwith_notrace fmt =3D kstr (fun s -> raise_notrace (Failure s)) fmt +let invalid_arg fmt =3D kstr invalid_arg fmt +let error fmt =3D kstr (fun s -> Error s) fmt +let error_msg fmt =3D kstr (fun s -> Error (`Msg s)) fmt + +(* Formatters *) + +type 'a t =3D Format.formatter -> 'a -> unit + +let flush ppf _ =3D Format.pp_print_flush ppf () +let nop fmt ppf =3D () +let any fmt ppf _ =3D pf ppf fmt +let using f pp ppf v =3D pp ppf (f v) +let const pp_v v ppf _ =3D pp_v ppf v +let fmt fmt ppf =3D pf ppf fmt + +(* Separators *) + +let cut ppf _ =3D Format.pp_print_cut ppf () +let sp ppf _ =3D Format.pp_print_space ppf () +let sps n ppf _ =3D Format.pp_print_break ppf n 0 +let comma ppf _ =3D Format.pp_print_string ppf ","; sp ppf () +let semi ppf _ =3D Format.pp_print_string ppf ";"; sp ppf () + +(* Sequencing *) + +let iter ?sep:(pp_sep =3D cut) iter pp_elt ppf v =3D + let is_first =3D ref true in + let pp_elt v =3D + if !is_first then (is_first :=3D false) else pp_sep ppf (); + pp_elt ppf v + in + iter pp_elt v + +let iter_bindings ?sep:(pp_sep =3D cut) iter pp_binding ppf v =3D + let is_first =3D ref true in + let pp_binding k v =3D + if !is_first then (is_first :=3D false) else pp_sep ppf (); + pp_binding ppf (k, v) + in + iter pp_binding v + +let append pp_v0 pp_v1 ppf v =3D pp_v0 ppf v; pp_v1 ppf v +let ( ++ ) =3D append +let concat ?sep pps ppf v =3D iter ?sep List.iter (fun ppf pp -> pp ppf v)= ppf pps + +(* Boxes *) + +let box ?(indent =3D 0) pp_v ppf v =3D + Format.(pp_open_box ppf indent; pp_v ppf v; pp_close_box ppf ()) + +let hbox pp_v ppf v =3D + Format.(pp_open_hbox ppf (); pp_v ppf v; pp_close_box ppf ()) + +let vbox ?(indent =3D 0) pp_v ppf v =3D + Format.(pp_open_vbox ppf indent; pp_v ppf v; pp_close_box ppf ()) + +let hvbox ?(indent =3D 0) pp_v ppf v =3D + Format.(pp_open_hvbox ppf indent; pp_v ppf v; pp_close_box ppf ()) + +let hovbox ?(indent =3D 0) pp_v ppf v =3D + Format.(pp_open_hovbox ppf indent; pp_v ppf v; pp_close_box ppf ()) + +(* Brackets *) + +let surround s1 s2 pp_v ppf v =3D + Format.(pp_print_string ppf s1; pp_v ppf v; pp_print_string ppf s2) + +let parens pp_v =3D box ~indent:1 (surround "(" ")" pp_v) +let brackets pp_v =3D box ~indent:1 (surround "[" "]" pp_v) +let oxford_brackets pp_v =3D box ~indent:2 (surround "[|" "|]" pp_v) +let braces pp_v =3D box ~indent:1 (surround "{" "}" pp_v) +let quote ?(mark =3D "\"") pp_v =3D + let pp_mark ppf _ =3D Format.pp_print_as ppf 1 mark in + box ~indent:1 (pp_mark ++ pp_v ++ pp_mark) + +(* Stdlib types formatters *) + +let bool =3D Format.pp_print_bool +let int =3D Format.pp_print_int +let nativeint ppf v =3D pf ppf "%nd" v +let int32 ppf v =3D pf ppf "%ld" v +let int64 ppf v =3D pf ppf "%Ld" v +let uint ppf v =3D pf ppf "%u" v +let uint32 ppf v =3D pf ppf "%lu" v +let uint64 ppf v =3D pf ppf "%Lu" v +let unativeint ppf v =3D pf ppf "%nu" v +let char =3D Format.pp_print_char +let string =3D Format.pp_print_string +let buffer ppf b =3D string ppf (Buffer.contents b) +let exn ppf e =3D string ppf (Printexc.to_string e) +let exn_backtrace ppf (e, bt) =3D + let pp_backtrace_str ppf s =3D + let stop =3D String.length s - 1 (* there's a newline at the end *) in + let rec loop left right =3D + if right =3D stop then string ppf (String.sub s left (right - left))= else + if s.[right] <> '\n' then loop left (right + 1) else + begin + string ppf (String.sub s left (right - left)); + cut ppf (); + loop (right + 1) (right + 1) + end + in + if s =3D "" then (string ppf "No backtrace available.") else + loop 0 0 + in + pf ppf "@[Exception: %a@,%a@]" + exn e pp_backtrace_str (Printexc.raw_backtrace_to_string bt) + +let float ppf v =3D pf ppf "%g" v +let round x =3D floor (x +. 0.5) +let round_dfrac d x =3D + if x -. (round x) =3D 0. then x else (* x is an intege= r. *) + let m =3D 10. ** (float_of_int d) in (* m moves 10^-d to = 1. *) + (floor ((x *. m) +. 0.5)) /. m + +let round_dsig d x =3D + if x =3D 0. then 0. else + let m =3D 10. ** (floor (log10 (abs_float x))) in (* to normalize = x. *) + (round_dfrac d (x /. m)) *. m + +let float_dfrac d ppf f =3D pf ppf "%g" (round_dfrac d f) +let float_dsig d ppf f =3D pf ppf "%g" (round_dsig d f) + +let pair ?sep:(pp_sep =3D cut) pp_fst pp_snd ppf (fst, snd) =3D + pp_fst ppf fst; pp_sep ppf (); pp_snd ppf snd + +let option ?none:(pp_none =3D nop) pp_v ppf =3D function +| None -> pp_none ppf () +| Some v -> pp_v ppf v + +let result ~ok ~error ppf =3D function +| Ok v -> ok ppf v +| Error e -> error ppf e + +let list ?sep pp_elt =3D iter ?sep List.iter pp_elt +let array ?sep pp_elt =3D iter ?sep Array.iter pp_elt +let seq ?sep pp_elt =3D iter ?sep Seq.iter pp_elt +let hashtbl ?sep pp_binding =3D iter_bindings ?sep Hashtbl.iter pp_binding +let queue ?sep pp_elt =3D iter Queue.iter pp_elt +let stack ?sep pp_elt =3D iter Stack.iter pp_elt + +(* Stdlib type dumpers *) + +module Dump =3D struct + + (* Sequencing *) + + let iter iter_f pp_name pp_elt =3D + let pp_v =3D iter ~sep:sp iter_f (box pp_elt) in + parens (pp_name ++ sp ++ pp_v) + + let iter_bindings iter_f pp_name pp_k pp_v =3D + let pp_v =3D iter_bindings ~sep:sp iter_f (pair pp_k pp_v) in + parens (pp_name ++ sp ++ pp_v) + + (* Stlib types *) + + let sig_names =3D + Sys.[ sigabrt, "SIGABRT"; sigalrm, "SIGALRM"; sigfpe, "SIGFPE"; + sighup, "SIGHUP"; sigill, "SIGILL"; sigint, "SIGINT"; + sigkill, "SIGKILL"; sigpipe, "SIGPIPE"; sigquit, "SIGQUIT"; + sigsegv, "SIGSEGV"; sigterm, "SIGTERM"; sigusr1, "SIGUSR1"; + sigusr2, "SIGUSR2"; sigchld, "SIGCHLD"; sigcont, "SIGCONT"; + sigstop, "SIGSTOP"; sigtstp, "SIGTSTP"; sigttin, "SIGTTIN"; + sigttou, "SIGTTOU"; sigvtalrm, "SIGVTALRM"; sigprof, "SIGPROF"; + sigbus, "SIGBUS"; sigpoll, "SIGPOLL"; sigsys, "SIGSYS"; + sigtrap, "SIGTRAP"; sigurg, "SIGURG"; sigxcpu, "SIGXCPU"; + sigxfsz, "SIGXFSZ"; ] + + let signal ppf s =3D match List.assq_opt s sig_names with + | Some name -> string ppf name + | None -> pf ppf "SIG(%d)" s + + let uchar ppf u =3D pf ppf "U+%04X" (Uchar.to_int u) + let string ppf s =3D pf ppf "%S" s + let pair pp_fst pp_snd =3D + parens (using fst (box pp_fst) ++ comma ++ using snd (box pp_snd)) + + let option pp_v ppf =3D function + | None -> pf ppf "None" + | Some v -> pf ppf "@[<2>Some@ @[%a@]@]" pp_v v + + let result ~ok ~error ppf =3D function + | Ok v -> pf ppf "@[<2>Ok@ @[%a@]@]" ok v + | Error e -> pf ppf "@[<2>Error@ @[%a@]@]" error e + + let list pp_elt =3D brackets (list ~sep:semi (box pp_elt)) + let array pp_elt =3D oxford_brackets (array ~sep:semi (box pp_elt)) + let seq pp_elt =3D brackets (seq ~sep:semi (box pp_elt)) + + let hashtbl pp_k pp_v =3D + iter_bindings Hashtbl.iter (any "hashtbl") pp_k pp_v + + let stack pp_elt =3D iter Stack.iter (any "stack") pp_elt + let queue pp_elt =3D iter Queue.iter (any "queue") pp_elt + + (* Records *) + + let field ?(label =3D string) l prj pp_v ppf v =3D + pf ppf "@[<1>%a =3D@ %a@]" label l pp_v (prj v) + + let record pps =3D + box ~indent:2 (surround "{ " " }" @@ vbox (concat ~sep:(any ";@,") pps= )) +end + +(* Magnitudes *) + +let ilog10 x =3D + let rec loop p x =3D if x =3D 0 then p else loop (p + 1) (x / 10) in + loop (-1) x + +let ipow10 n =3D + let rec loop acc n =3D if n =3D 0 then acc else loop (acc * 10) (n - 1) = in + loop 1 n + +let si_symb_max =3D 16 +let si_symb =3D + [| "y"; "z"; "a"; "f"; "p"; "n"; "u"; "m"; ""; "k"; "M"; "G"; "T"; "P"; + "E"; "Z"; "Y"|] + +let rec pp_at_factor ~scale u symb factor ppf s =3D + let m =3D s / factor in + let n =3D s mod factor in + match m with + | m when m >=3D 100 -> (* No fractional digit *) + let m_up =3D if n > 0 then m + 1 else m in + if m_up >=3D 1000 then si_size ~scale u ppf (m_up * factor) else + pf ppf "%d%s%s" m_up symb u + | m when m >=3D 10 -> (* One fractional digit w.o. trailing 0 *) + let f_factor =3D factor / 10 in + let f_m =3D n / f_factor in + let f_n =3D n mod f_factor in + let f_m_up =3D if f_n > 0 then f_m + 1 else f_m in + begin match f_m_up with + | 0 -> pf ppf "%d%s%s" m symb u + | f when f >=3D 10 -> si_size ~scale u ppf (m * factor + f * f_facto= r) + | f -> pf ppf "%d.%d%s%s" m f symb u + end + | m -> (* Two or zero fractional digits w.o. trailing 0 *) + let f_factor =3D factor / 100 in + let f_m =3D n / f_factor in + let f_n =3D n mod f_factor in + let f_m_up =3D if f_n > 0 then f_m + 1 else f_m in + match f_m_up with + | 0 -> pf ppf "%d%s%s" m symb u + | f when f >=3D 100 -> si_size ~scale u ppf (m * factor + f * f_fact= or) + | f when f mod 10 =3D 0 -> pf ppf "%d.%d%s%s" m (f / 10) symb u + | f -> pf ppf "%d.%02d%s%s" m f symb u + +and si_size ~scale u ppf s =3D match scale < -8 || scale > 8 with +| true -> invalid_arg "~scale is %d, must be in [-8;8]" scale +| false -> + let pow_div_3 =3D if s =3D 0 then 0 else (ilog10 s / 3) in + let symb =3D (scale + 8) + pow_div_3 in + let symb, factor =3D match symb > si_symb_max with + | true -> si_symb_max, ipow10 ((8 - scale) * 3) + | false -> symb, ipow10 (pow_div_3 * 3) + in + if factor =3D 1 + then pf ppf "%d%s%s" s si_symb.(symb) u + else pp_at_factor ~scale u si_symb.(symb) factor ppf s + +let byte_size ppf s =3D si_size ~scale:0 "B" ppf s + +let bi_byte_size ppf s =3D + (* XXX we should get rid of this. *) + let _pp_byte_size k i ppf s =3D + let pp_frac =3D float_dfrac 1 in + let div_round_up m n =3D (m + n - 1) / n in + let float =3D float_of_int in + if s < k then pf ppf "%dB" s else + let m =3D k * k in + if s < m then begin + let kstr =3D if i =3D "" then "k" (* SI *) else "K" (* IEC *) in + let sk =3D s / k in + if sk < 10 + then pf ppf "%a%s%sB" pp_frac (float s /. float k) kstr i + else pf ppf "%d%s%sB" (div_round_up s k) kstr i + end else + let g =3D k * m in + if s < g then begin + let sm =3D s / m in + if sm < 10 + then pf ppf "%aM%sB" pp_frac (float s /. float m) i + else pf ppf "%dM%sB" (div_round_up s m) i + end else + let t =3D k * g in + if s < t then begin + let sg =3D s / g in + if sg < 10 + then pf ppf "%aG%sB" pp_frac (float s /. float g) i + else pf ppf "%dG%sB" (div_round_up s g) i + end else + let p =3D k * t in + if s < p then begin + let st =3D s / t in + if st < 10 + then pf ppf "%aT%sB" pp_frac (float s /. float t) i + else pf ppf "%dT%sB" (div_round_up s t) i + end else begin + let sp =3D s / p in + if sp < 10 + then pf ppf "%aP%sB" pp_frac (float s /. float p) i + else pf ppf "%dP%sB" (div_round_up s p) i + end + in + _pp_byte_size 1024 "i" ppf s + +(* XXX From 4.08 on use Int64.unsigned_* + + See Hacker's Delight for the implementation of these unsigned_* funs *) + +let unsigned_compare x0 x1 =3D Int64.(compare (sub x0 min_int) (sub x1 min= _int)) +let unsigned_div n d =3D match d < Int64.zero with +| true -> if unsigned_compare n d < 0 then Int64.zero else Int64.one +| false -> + let q =3D Int64.(shift_left (div (shift_right_logical n 1) d) 1) in + let r =3D Int64.(sub n (mul q d)) in + if unsigned_compare r d >=3D 0 then Int64.succ q else q + +let unsigned_rem n d =3D Int64.(sub n (mul (unsigned_div n d) d)) + +let us_span =3D 1_000L +let ms_span =3D 1_000_000L +let sec_span =3D 1_000_000_000L +let min_span =3D 60_000_000_000L +let hour_span =3D 3600_000_000_000L +let day_span =3D 86_400_000_000_000L +let year_span =3D 31_557_600_000_000_000L + +let rec pp_si_span unit_str si_unit si_higher_unit ppf span =3D + let geq x y =3D unsigned_compare x y >=3D 0 in + let m =3D unsigned_div span si_unit in + let n =3D unsigned_rem span si_unit in + match m with + | m when geq m 100L -> (* No fractional digit *) + let m_up =3D if Int64.equal n 0L then m else Int64.succ m in + let span' =3D Int64.mul m_up si_unit in + if geq span' si_higher_unit then uint64_ns_span ppf span' else + pf ppf "%Ld%s" m_up unit_str + | m when geq m 10L -> (* One fractional digit w.o. trailing zero *) + let f_factor =3D unsigned_div si_unit 10L in + let f_m =3D unsigned_div n f_factor in + let f_n =3D unsigned_rem n f_factor in + let f_m_up =3D if Int64.equal f_n 0L then f_m else Int64.succ f_m in + begin match f_m_up with + | 0L -> pf ppf "%Ld%s" m unit_str + | f when geq f 10L -> + uint64_ns_span ppf Int64.(add (mul m si_unit) (mul f f_factor)) + | f -> pf ppf "%Ld.%Ld%s" m f unit_str + end + | m -> (* Two or zero fractional digits w.o. trailing zero *) + let f_factor =3D unsigned_div si_unit 100L in + let f_m =3D unsigned_div n f_factor in + let f_n =3D unsigned_rem n f_factor in + let f_m_up =3D if Int64.equal f_n 0L then f_m else Int64.succ f_m in + match f_m_up with + | 0L -> pf ppf "%Ld%s" m unit_str + | f when geq f 100L -> + uint64_ns_span ppf Int64.(add (mul m si_unit) (mul f f_factor)) + | f when Int64.equal (Int64.rem f 10L) 0L -> + pf ppf "%Ld.%Ld%s" m (Int64.div f 10L) unit_str + | f -> + pf ppf "%Ld.%02Ld%s" m f unit_str + +and pp_non_si unit_str unit unit_lo_str unit_lo unit_lo_size ppf span =3D + let geq x y =3D unsigned_compare x y >=3D 0 in + let m =3D unsigned_div span unit in + let n =3D unsigned_rem span unit in + if Int64.equal n 0L then pf ppf "%Ld%s" m unit_str else + let f_m =3D unsigned_div n unit_lo in + let f_n =3D unsigned_rem n unit_lo in + let f_m_up =3D if Int64.equal f_n 0L then f_m else Int64.succ f_m in + match f_m_up with + | f when geq f unit_lo_size -> + uint64_ns_span ppf Int64.(add (mul m unit) (mul f unit_lo)) + | f -> + pf ppf "%Ld%s%Ld%s" m unit_str f unit_lo_str + +and uint64_ns_span ppf span =3D + let geq x y =3D unsigned_compare x y >=3D 0 in + let lt x y =3D unsigned_compare x y =3D -1 in + match span with + | s when lt s us_span -> pf ppf "%Ldns" s + | s when lt s ms_span -> pp_si_span "us" us_span ms_span ppf s + | s when lt s sec_span -> pp_si_span "ms" ms_span sec_span ppf s + | s when lt s min_span -> pp_si_span "s" sec_span min_span ppf s + | s when lt s hour_span -> pp_non_si "min" min_span "s" sec_span 60L ppf= s + | s when lt s day_span -> pp_non_si "h" hour_span "min" min_span 60L ppf= s + | s when lt s year_span -> pp_non_si "d" day_span "h" hour_span 24L ppf s + | s -> + let m =3D unsigned_div s year_span in + let n =3D unsigned_rem s year_span in + if Int64.equal n 0L then pf ppf "%Lda" m else + let f_m =3D unsigned_div n day_span in + let f_n =3D unsigned_rem n day_span in + let f_m_up =3D if Int64.equal f_n 0L then f_m else Int64.succ f_m in + match f_m_up with + | f when geq f 366L -> pf ppf "%Lda" (Int64.succ m) + | f -> pf ppf "%Lda%Ldd" m f + +(* Binary formatting *) + +type 'a vec =3D int * (int -> 'a) + +let iter_vec f (n, get) =3D for i =3D 0 to n - 1 do f i (get i) done +let vec ?sep =3D iter_bindings ?sep iter_vec + +let on_string =3D using String.(fun s -> length s, get s) +let on_bytes =3D using Bytes.(fun b -> length b, get b) + +let sub_vecs w (n, get) =3D + (n - 1) / w + 1, + fun j -> + let off =3D w * j in + min w (n - off), fun i -> get (i + off) + +let prefix0x =3D [ + 0xf , fmt "%01x"; + 0xff , fmt "%02x"; + 0xfff , fmt "%03x"; + 0xffff , fmt "%04x"; + 0xfffff , fmt "%05x"; + 0xffffff , fmt "%06x"; + 0xfffffff , fmt "%07x"; ] + +let padded0x ~max =3D match List.find_opt (fun (x, _) -> max <=3D x) prefi= x0x with +| Some (_, pp) -> pp +| None -> fmt "%08x" + +let ascii ?(w =3D 0) ?(subst =3D const char '.') () ppf (n, _ as v) =3D + let pp_char ppf (_, c) =3D + if '\x20' <=3D c && c < '\x7f' then char ppf c else subst ppf () + in + vec pp_char ppf v; + if n < w then sps (w - n) ppf () + +let octets ?(w =3D 0) ?(sep =3D sp) () ppf (n, _ as v) =3D + let pp_sep ppf i =3D if i > 0 && i mod 2 =3D 0 then sep ppf () in + let pp_char ppf (i, c) =3D pp_sep ppf i; pf ppf "%02x" (Char.code c) in + vec ~sep:nop pp_char ppf v; + for i =3D n to w - 1 do pp_sep ppf i; sps 2 ppf () done + +let addresses ?addr ?(w =3D 16) pp_vec ppf (n, _ as v) =3D + let addr =3D match addr with + | Some pp -> pp + | _ -> padded0x ~max:(((n - 1) / w) * w) ++ const string ": " + in + let pp_sub ppf (i, sub) =3D addr ppf (i * w); box pp_vec ppf sub in + vbox (vec pp_sub) ppf (sub_vecs w v) + +let hex ?(w =3D 16) () =3D + addresses ~w ((octets ~w () |> box) ++ sps 2 ++ (ascii ~w () |> box)) + +(* Text and lines *) + +let is_nl c =3D c =3D '\n' +let is_nl_or_sp c =3D is_nl c || c =3D ' ' +let is_white =3D function ' ' | '\t' .. '\r' -> true | _ -> false +let not_white c =3D not (is_white c) +let not_white_or_nl c =3D is_nl c || not_white c + +let rec stop_at sat ~start ~max s =3D + if start > max then start else + if sat s.[start] then start else + stop_at sat ~start:(start + 1) ~max s + +let sub s start stop ~max =3D + if start =3D stop then "" else + if start =3D 0 && stop > max then s else + String.sub s start (stop - start) + +let words ppf s =3D + let max =3D String.length s - 1 in + let rec loop start s =3D match stop_at is_white ~start ~max s with + | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~= max) + | stop -> + Format.pp_print_string ppf (sub s start stop ~max); + match stop_at not_white ~start:stop ~max s with + | stop when stop > max -> () + | stop -> Format.pp_print_space ppf (); loop stop s + in + let start =3D stop_at not_white ~start:0 ~max s in + if start > max then () else loop start s + +let paragraphs ppf s =3D + let max =3D String.length s - 1 in + let rec loop start s =3D match stop_at is_white ~start ~max s with + | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~= max) + | stop -> + Format.pp_print_string ppf (sub s start stop ~max); + match stop_at not_white_or_nl ~start:stop ~max s with + | stop when stop > max -> () + | stop -> + if s.[stop] <> '\n' + then (Format.pp_print_space ppf (); loop stop s) else + match stop_at not_white_or_nl ~start:(stop + 1) ~max s with + | stop when stop > max -> () + | stop -> + if s.[stop] <> '\n' + then (Format.pp_print_space ppf (); loop stop s) else + match stop_at not_white ~start:(stop + 1) ~max s with + | stop when stop > max -> () + | stop -> + Format.pp_force_newline ppf (); + Format.pp_force_newline ppf (); + loop stop s + in + let start =3D stop_at not_white ~start:0 ~max s in + if start > max then () else loop start s + +let text ppf s =3D + let max =3D String.length s - 1 in + let rec loop start s =3D match stop_at is_nl_or_sp ~start ~max s with + | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~= max) + | stop -> + Format.pp_print_string ppf (sub s start stop ~max); + begin match s.[stop] with + | ' ' -> Format.pp_print_space ppf () + | '\n' -> Format.pp_force_newline ppf () + | _ -> assert false + end; + loop (stop + 1) s + in + loop 0 s + +let lines ppf s =3D + let max =3D String.length s - 1 in + let rec loop start s =3D match stop_at is_nl ~start ~max s with + | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~= max) + | stop -> + Format.pp_print_string ppf (sub s start stop ~max); + Format.pp_force_newline ppf (); + loop (stop + 1) s + in + loop 0 s + +let truncated ~max ppf s =3D match String.length s <=3D max with +| true -> Format.pp_print_string ppf s +| false -> + for i =3D 0 to max - 4 do Format.pp_print_char ppf s.[i] done; + Format.pp_print_string ppf "..." + +let text_loc ppf ((l0, c0), (l1, c1)) =3D + if (l0 : int) =3D=3D (l1 : int) && (c0 : int) =3D=3D (c1 : int) + then pf ppf "%d.%d" l0 c0 + else pf ppf "%d.%d-%d.%d" l0 c0 l1 c1 + +(* HCI fragments *) + +let one_of ?(empty =3D nop) pp_v ppf =3D function +| [] -> empty ppf () +| [v] -> pp_v ppf v +| [v0; v1] -> pf ppf "@[either %a or@ %a@]" pp_v v0 pp_v v1 +| _ :: _ as vs -> + let rec loop ppf =3D function + | [v] -> pf ppf "or@ %a" pp_v v + | v :: vs -> pf ppf "%a,@ " pp_v v; loop ppf vs + | [] -> assert false + in + pf ppf "@[one@ of@ %a@]" loop vs + +let did_you_mean + ?(pre =3D any "Unknown") ?(post =3D nop) ~kind pp_v ppf (v, hints) + =3D + match hints with + | [] -> pf ppf "@[%a %s %a%a.@]" pre () kind pp_v v post () + | hints -> + pf ppf "@[%a %s %a%a.@ Did you mean %a ?@]" + pre () kind pp_v v post () (one_of pp_v) hints + +(* Conditional UTF-8 and styled formatting. *) + +type any =3D .. +type 'a attr =3D int * ('a -> any) * (any -> 'a) + +let id =3D ref 0 +let attr (type a) () =3D + incr id; + let module M =3D struct type any +=3D K of a end in + !id, (fun x -> M.K x), (function M.K x -> x | _ -> assert false) + +module Int =3D struct type t =3D int let compare a b =3D compare (a: int) = b end +module Imap =3D Map.Make (Int) + +let attrs =3D ref [] +let store ppf =3D + let open Ephemeron.K1 in + let rec go ppf top =3D function + | [] -> + let e =3D create () and v =3D ref Imap.empty in + attrs :=3D e :: List.rev top; set_key e ppf; set_data e v; v + | e::es -> + match get_key e with + | None -> go ppf top es + | Some k when not (k =3D=3D ppf) -> go ppf (e::top) es + | Some k -> + let v =3D match get_data e with Some v -> v | _ -> assert false = in + if not (top =3D=3D []) then attrs :=3D e :: List.rev_append top = es; + ignore (Sys.opaque_identity k); v + in + go ppf [] !attrs + +let get (k, _, prj) ppf =3D + match Imap.find_opt k !(store ppf) with Some x -> Some (prj x) | _ -> No= ne + +let set (k, inj, _) v ppf =3D + if ppf =3D=3D Format.str_formatter then invalid_arg' err_str_formatter e= lse + let s =3D store ppf in + s :=3D Imap.add k (inj v) !s + +let def x =3D function Some y -> y | _ -> x + +let utf_8_attr =3D attr () +let utf_8 ppf =3D get utf_8_attr ppf |> def true +let set_utf_8 ppf x =3D set utf_8_attr x ppf + +type style_renderer =3D [ `Ansi_tty | `None ] +let style_renderer_attr =3D attr () +let style_renderer ppf =3D get style_renderer_attr ppf |> def `None +let set_style_renderer ppf x =3D set style_renderer_attr x ppf + +let with_buffer ?like buf =3D + let ppf =3D Format.formatter_of_buffer buf in + (match like with Some like -> store ppf :=3D !(store like) | _ -> ()); + ppf + +let str_like ppf fmt =3D + let buf =3D Buffer.create 64 in + let bppf =3D with_buffer ~like:ppf buf in + let flush ppf =3D + Format.pp_print_flush ppf (); + let s =3D Buffer.contents buf in + Buffer.reset buf; s + in + Format.kfprintf flush bppf fmt + +(* Conditional UTF-8 formatting *) + +let if_utf_8 pp_u pp =3D fun ppf v -> (if utf_8 ppf then pp_u else pp) ppf= v + +(* Styled formatting *) + +type color =3D + [ `Black | `Blue | `Cyan | `Green | `Magenta | `Red | `White | `Yellow ] + +type style =3D + [ `None | `Bold | `Faint | `Italic | `Underline | `Reverse + | `Fg of [ color | `Hi of color ] + | `Bg of [ color | `Hi of color ] + | color (** deprecated *) ] + +let ansi_style_code =3D function +| `Bold -> "1" +| `Faint -> "2" +| `Italic -> "3" +| `Underline -> "4" +| `Reverse -> "7" +| `Fg `Black -> "30" +| `Fg `Red -> "31" +| `Fg `Green -> "32" +| `Fg `Yellow -> "33" +| `Fg `Blue -> "34" +| `Fg `Magenta -> "35" +| `Fg `Cyan -> "36" +| `Fg `White -> "37" +| `Bg `Black -> "40" +| `Bg `Red -> "41" +| `Bg `Green -> "42" +| `Bg `Yellow -> "43" +| `Bg `Blue -> "44" +| `Bg `Magenta -> "45" +| `Bg `Cyan -> "46" +| `Bg `White -> "47" +| `Fg (`Hi `Black) -> "90" +| `Fg (`Hi `Red) -> "91" +| `Fg (`Hi `Green) -> "92" +| `Fg (`Hi `Yellow) -> "93" +| `Fg (`Hi `Blue) -> "94" +| `Fg (`Hi `Magenta) -> "95" +| `Fg (`Hi `Cyan) -> "96" +| `Fg (`Hi `White) -> "97" +| `Bg (`Hi `Black) -> "100" +| `Bg (`Hi `Red) -> "101" +| `Bg (`Hi `Green) -> "102" +| `Bg (`Hi `Yellow) -> "103" +| `Bg (`Hi `Blue) -> "104" +| `Bg (`Hi `Magenta) -> "105" +| `Bg (`Hi `Cyan) -> "106" +| `Bg (`Hi `White) -> "107" +| `None -> "0" +(* deprecated *) +| `Black -> "30" +| `Red -> "31" +| `Green -> "32" +| `Yellow -> "33" +| `Blue -> "34" +| `Magenta -> "35" +| `Cyan -> "36" +| `White -> "37" + +let pp_sgr ppf style =3D + Format.pp_print_as ppf 0 "\027["; + Format.pp_print_as ppf 0 style; + Format.pp_print_as ppf 0 "m" + +let curr_style =3D attr () + +let styled style pp_v ppf v =3D match style_renderer ppf with +| `None -> pp_v ppf v +| `Ansi_tty -> + let curr =3D match get curr_style ppf with + | None -> let s =3D ref "0" in set curr_style s ppf; s + | Some s -> s + in + let prev =3D !curr and here =3D ansi_style_code style in + curr :=3D (match style with `None -> here | _ -> prev ^ ";" ^ here); + try pp_sgr ppf here; pp_v ppf v; pp_sgr ppf prev; curr :=3D prev with + | e -> curr :=3D prev; raise e + +(* Records *) + +external id : 'a -> 'a =3D "%identity" +let label =3D styled (`Fg `Yellow) string +let field ?(label =3D label) ?(sep =3D any ":@ ") l prj pp_v ppf v =3D + pf ppf "@[<1>%a%a%a@]" label l sep () pp_v (prj v) + +let record ?(sep =3D cut) pps =3D vbox (concat ~sep pps) + +(* Converting with string converters. *) + +let of_to_string f ppf v =3D string ppf (f v) +let to_to_string pp_v v =3D str "%a" pp_v v + +(* Deprecated *) + +let strf =3D str +let kstrf =3D kstr +let strf_like =3D str_like +let always =3D any +let unit =3D any +let prefix pp_p pp_v ppf v =3D pp_p ppf (); pp_v ppf v +let suffix pp_s pp_v ppf v =3D pp_v ppf v; pp_s ppf () +let styled_unit style fmt =3D styled style (any fmt) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2014 The fmt programmers + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/fmt/src/fmt.mli b/tools/ocaml/duniverse/= fmt/src/fmt.mli new file mode 100644 index 0000000000..6fe965b910 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt.mli @@ -0,0 +1,689 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2014 The fmt programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** {!Format} pretty-printer combinators. + + Consult {{!nameconv}naming conventions} for your pretty-printers. + + {b References} + {ul + {- The {!Format} module documentation.} + {- The required reading {!Format} module + {{:https://ocaml.org/learn/tutorials/format.html}tutorial}.}} *) + +(** {1:stdos Standard outputs} *) + +val stdout : Format.formatter +(** [stdout] is the standard output formatter. *) + +val stderr : Format.formatter +(** [stderr] is the standard error formatter. *) + +(** {1:formatting Formatting} *) + +val pf : Format.formatter -> ('a, Format.formatter, unit) Stdlib.format ->= 'a +(** [pf] is {!Format.fprintf}. *) + +val pr : ('a, Format.formatter, unit) format -> 'a +(** [pr] is [pf stdout]. *) + +val epr : ('a, Format.formatter, unit) format -> 'a +(** [epr] is [pf stderr]. *) + +val str : ('a, Format.formatter, unit, string) format4 -> 'a +(** [str] is {!Format.asprintf}. + + {b Note.} When using [strf] {!utf_8} and {!style_renderer} are + always respectively set to [true] and [`None]. See also + {!str_like}. *) + +val kpf : (Format.formatter -> 'a) -> Format.formatter -> + ('b, Format.formatter, unit, 'a) Stdlib.format4 -> 'b +(** [kpf] is {!Format.kfprintf}. *) + +val kstr : + (string -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> 'b +(** [kstr] is like {!str} but continuation based. *) + +val str_like : + Format.formatter -> ('a, Format.formatter, unit, string) format4 -> 'a +(** [str_like ppf] is like {!str} except its {!utf_8} and {!style_renderer} + settings are those of [ppf]. *) + +val with_buffer : ?like:Format.formatter -> Buffer.t -> Format.formatter +(** [with_buffer ~like b] is a formatter whose {!utf_8} and {!style_render= er} + settings are copied from those of {!like} (if provided). *) + +val failwith : ('a, Format.formatter, unit, 'b) format4 -> 'a +(** [failwith] is [kstr failwith], raises {!Stdlib.Failure} with + a pretty-printed string argument. *) + +val failwith_notrace : ('a, Format.formatter, unit, 'b) format4 -> 'a +(** [failwith_notrace] is like {!failwith} but raises with {!raise_notrace= }. *) + +val invalid_arg : ('a, Format.formatter, unit, 'b) format4 -> 'a +(** [invalid_arg] is [kstr invalid_arg], raises + {!Stdlib.Invalid_argument} with a pretty-printed string argument. *) + +val error : ('b, Format.formatter , unit, ('a, string) result) format4 -> = 'b +(** [error fmt ...] is [kstr (fun s -> Error s) fmt ...] *) + +val error_msg : + ('b, Format.formatter , unit, ('a, [`Msg of string]) result) format4 -> = 'b +(** [error_msg fmt ...] is [kstr (fun s -> Error (`Msg s)) fmt ...] *) + +(** {1 Formatters} *) + +type 'a t =3D Format.formatter -> 'a -> unit +(** The type for formatters of values of type ['a]. *) + +val flush : 'a t +(** [flush] has the effect of {!Format.pp_print_flush} *) + +val nop : 'a t +(** [nop] formats nothing. *) + +val any : (unit, Format.formatter, unit) Stdlib.format -> 'a t +(** [any fmt ppf v] formats any value with the constant format [fmt]. *) + +val using : ('a -> 'b) -> 'b t -> 'a t +(** [using f pp ppf v] ppf ppf [(f v)]. *) + +val const : 'a t -> 'a -> 'b t +(** [const pp_v v] always formats [v] using [pp_v]. *) + +val fmt : ('a, Format.formatter, unit) Stdlib.format -> Format.formatter -= > 'a +(** [fmt fmt ppf] is [pf ppf fmt]. If [fmt] is used with a single + non-constant formatting directive, generates a value of type + {!t}. *) + +(** {1:seps Separators} *) + +val cut : 'a t +(** [cut] has the effect of {!Format.pp_print_cut}. *) + +val sp : 'a t +(** [sp] has the effect of {!Format.pp_print_space}. *) + +val sps : int -> 'a t +(** [sps n] has the effect of {!Format.pp_print_break}[ n 0]. *) + +val comma : 'a t +(** [comma] is {!Fmt.any}[ ",@ "]. *) + +val semi : 'a t +(** [semi] is {!Fmt.any}[ ";@ "]. *) + +(** {1:seq Sequencing} *) + +val append : 'a t -> 'a t -> 'a t +(** [append pp_v0 pp_v1 ppf v] is [pp_v0 ppf v; pp_v1 ppf v]. *) + +val ( ++ ) : 'a t -> 'a t -> 'a t +(** [( ++ )] is {!append}. *) + +val concat : ?sep:unit t -> 'a t list -> 'a t +(** [concat ~sep pps] formats a value using the formaters [pps] + and separting each format with [sep] (defaults to {!cut}). *) + +val iter : ?sep:unit t -> (('a -> unit) -> 'b -> unit) -> 'a t -> 'b t +(** [iter ~sep iter pp_elt] formats the iterations of [iter] over a + value using [pp_elt]. Iterations are separated by [sep] (defaults to + {!cut}). *) + +val iter_bindings : ?sep:unit t -> (('a -> 'b -> unit) -> 'c -> unit) -> + ('a * 'b) t -> 'c t +(** [iter_bindings ~sep iter pp_binding] formats the iterations of + [iter] over a value using [pp_binding]. Iterations are separated + by [sep] (defaults to {!cut}). *) + +(** {1:boxes Boxes} *) + +val box : ?indent:int -> 'a t -> 'a t +(** [box ~indent pp ppf] wraps [pp] in a pretty-printing box. The box trie= s to + print as much as possible on every line, while emphasizing the box str= ucture + (see {!Format.pp_open_box}). Break hints that lead to a new line add + [indent] to the current indentation (defaults to [0]). *) + +val hbox : 'a t -> 'a t +(** [hbox] is like {!box} but is a horizontal box: the line is not split + in this box (but may be in sub-boxes). See {!Format.pp_open_hbox}. *) + +val vbox : ?indent:int -> 'a t -> 'a t +(** [vbox] is like {!box} but is a vertical box: every break hint leads + to a new line which adds [indent] to the current indentation + (defaults to [0]). See {!Format.pp_open_vbox}. *) + +val hvbox : ?indent:int -> 'a t -> 'a t +(** [hvbox] is like {!hbox} if it fits on a single line, or like {!vbox} + otherwise. See {!Format.pp_open_hvbox}. *) + +val hovbox : ?indent:int -> 'a t -> 'a t +(** [hovbox] is a condensed {!box}. See {!Format.pp_open_hovbox}. *) + +(** {1:bracks Brackets} *) + +val parens : 'a t -> 'a t +(** [parens pp_v ppf] is [pf "@[<1>(%a)@]" pp_v]. *) + +val brackets : 'a t -> 'a t +(** [brackets pp_v ppf] is [pf "@[<1>[%a]@]" pp_v]. *) + +val braces : 'a t -> 'a t +(** [braces pp_v ppf] is [pf "@[<1>{%a}@]" pp_v]. *) + +val quote : ?mark:string -> 'a t -> 'a t +(** [quote ~mark pp_v ppf] is [pf "@[<1>@<1>%s%a@<1>%s@]" mark pp_v mark], + [mark] defaults to ["\""], it is always counted as spanning as single + column (this allows for UTF-8 encoded marks). *) + +(** {1:records Records} *) + +val id : 'a -> 'a +(** [id] is {!Fun.id}. *) + +val field : + ?label:string t -> ?sep:unit t -> string -> ('b -> 'a) -> 'a t -> 'b t +(** [field ~label ~sep l prj pp_v] pretty prints a labelled field value as + [pf "@[<1>%a%a%a@]" label l sep () (using prj pp_v)]. [label] defaults + to [styled `Yellow string] and [sep] to [any ":@ "]. *) + +val record : ?sep:unit t -> 'a t list -> 'a t +(** [record ~sep fields] pretty-prints a value using the concatenation of + [fields], separated by [sep] (defaults to [cut]) and framed in a verti= cal + box. *) + +(** {1:stdlib Stdlib types} + + Formatters for structures give full control to the client over the + formatting process and do not wrap the formatted structures with + boxes. Use the {!Dump} module to quickly format values for + inspection. *) + +val bool : bool t +(** [bool] is {!Format.pp_print_bool}. *) + +val int : int t +(** [int] is [pf ppf "%d"]. *) + +val nativeint : nativeint t +(** [nativeint ppf] is [pf ppf "%nd"]. *) + +val int32 : int32 t +(** [int32 ppf] is [pf ppf "%ld"]. *) + +val int64 : int64 t +(** [int64 ppf] is [pf ppf "%Ld"]. *) + +val uint : int t +(** [uint ppf] is [pf ppf "%u"]. *) + +val unativeint : nativeint t +(** [unativeint ppf] is [pf ppf "%nu"]. *) + +val uint32 : int32 t +(** [uint32 ppf] is [pf ppf "%lu"]. *) + +val uint64 : int64 t +(** [uint64 ppf] is [pf ppf "%Lu"]. *) + +val float : float t +(** [float ppf] is [pf ppf "%g".] *) + +val float_dfrac : int -> float t +(** [float_dfrac d] rounds the float to the [d]th {e decimal} + fractional digit and formats the result with ["%g"]. Ties are + rounded towards positive infinity. The result is only defined + for [0 <=3D d <=3D 16]. *) + +val float_dsig : int -> float t +(** [float_dsig d] rounds the normalized {e decimal} significand + of the float to the [d]th decimal fractional digit and formats + the result with ["%g"]. Ties are rounded towards positive + infinity. The result is NaN on infinities and only defined for + [0 <=3D d <=3D 16]. + + {b Warning.} The current implementation overflows on large [d] + and floats. *) + +val char : char t +(** [char] is {!Format.pp_print_char}. *) + +val string : string t +(** [string] is {!Format.pp_print_string}. *) + +val buffer : Buffer.t t +(** [buffer] formats a {!Buffer.t} value's current contents. *) + +val exn : exn t +(** [exn] formats an exception. *) + +val exn_backtrace : (exn * Printexc.raw_backtrace) t +(** [exn_backtrace] formats an exception backtrace. *) + +val pair : ?sep:unit t -> 'a t -> 'b t -> ('a * 'b) t +(** [pair ~sep pp_fst pp_snd] formats a pair. The first and second + projection are formatted using [pp_fst] and [pp_snd] and are + separated by [sep] (defaults to {!cut}). *) + +val option : ?none:unit t -> 'a t -> 'a option t +(** [option ~none pp_v] formats an optional value. The [Some] case + uses [pp_v] and [None] uses [none] (defaults to {!nop}). *) + +val result : ok:'a t -> error:'b t -> ('a, 'b) result t +(** [result ~ok ~error] formats a result value using [ok] for the [Ok] + case and [error] for the [Error] case. *) + +val list : ?sep:unit t -> 'a t -> 'a list t +(** [list sep pp_v] formats list elements. Each element of the list is + formatted in order with [pp_v]. Elements are separated by [sep] + (defaults to {!cut}). If the list is empty, this is {!nop}. *) + +val array : ?sep:unit t -> 'a t -> 'a array t +(** [array sep pp_v] formats array elements. Each element of the array + is formatted in order with [pp_v]. Elements are separated by [sep] + (defaults to {!cut}). If the array is empty, this is {!nop}. *) + +val seq : ?sep:unit t -> 'a t -> 'a Seq.t t +(** [seq sep pp_v] formats sequence elements. Each element of the sequence + is formatted in order with [pp_v]. Elements are separated by [sep] + (defaults to {!cut}). If the sequence is empty, this is {!nop}. *) + +val hashtbl : ?sep:unit t -> ('a * 'b) t -> ('a, 'b) Hashtbl.t t +(** [hashtbl ~sep pp_binding] formats the bindings of a hash + table. Each binding is formatted with [pp_binding] and bindings + are separated by [sep] (defaults to {!cut}). If the hash table has + multiple bindings for a given key, all bindings are formatted, + with the most recent binding first. If the hash table is empty, + this is {!nop}. *) + +val queue : ?sep:unit t -> 'a t -> 'a Queue.t t +(** [queue ~sep pp_v] formats queue elements. Each element of the + queue is formatted in least recently added order with + [pp_v]. Elements are separated by [sep] (defaults to {!cut}). If + the queue is empty, this is {!nop}. *) + +val stack : ?sep:unit t -> 'a t -> 'a Stack.t t +(** [stack ~sep pp_v] formats stack elements. Each element of the + stack is formatted from top to bottom order with [pp_v]. Elements + are separated by [sep] (defaults to {!cut}). If the stack is + empty, this is {!nop}. *) + +(** Formatters for inspecting OCaml values. + + Formatters of this module dump OCaml value with little control + over the representation but with good default box structures and, + whenever possible, using OCaml syntax. *) +module Dump : sig + + (** {1:stdlib Stdlib types} *) + + val signal : int t + (** [signal] formats an OCaml {{!Sys.sigabrt}signal number} as a C + POSIX + {{:http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/signal.h= .html} + constant} or ["SIG(%d)"] the signal number is unknown. *) + + val uchar : Uchar.t t + (** [uchar] formats an OCaml {!Uchar.t} value using only US-ASCII + encoded characters according to the Unicode + {{:http://www.unicode.org/versions/latest/appA.pdf}notational + convention} for code points. *) + + val string : string t + (** [string] is [pf ppf "%S"]. *) + + val pair : 'a t -> 'b t -> ('a * 'b) t + (** [pair pp_fst pp_snd] formats an OCaml pair using [pp_fst] and [pp_sn= d] + for the first and second projection. *) + + val option : 'a t -> 'a option t + (** [option pp_v] formats an OCaml option using [pp_v] for the [Some] + case. No parentheses are added. *) + + val result : ok:'a t -> error:'b t -> ('a, 'b) result t + (** [result ~ok ~error] formats an OCaml result using [ok] for the [Ok] + case value and [error] for the [Error] case value. No parentheses + are added. *) + + val list : 'a t -> 'a list t + (** [list pp_v] formats an OCaml list using [pp_v] for the list + elements. *) + + val array : 'a t -> 'a array t + (** [array pp_v] formats an OCaml array using [pp_v] for the array + elements. *) + + val seq : 'a t -> 'a Seq.t t + (** [seq pp_v] formats an OCaml sequence using [pp_v] for the sequence + elements. *) + + val hashtbl : 'a t -> 'b t -> ('a, 'b) Hashtbl.t t + (** [hashtbl pp_k pp_v] formats an unspecified representation of the + bindings of a hash table using [pp_k] for the keys and [pp_v] + for the values. If the hash table has multiple bindings for a + given key, all bindings are formatted, with the most recent + binding first. *) + + val queue : 'a t -> 'a Queue.t t + (** [queue pp_v] formats an unspecified representation of an OCaml + queue using [pp_v] to format its elements, in least recently added + order. *) + + val stack : 'a t -> 'a Stack.t t + (** [stack pp_v] formats an unspecified representation of an OCaml + stack using [pp_v] to format its elements in top to bottom order. *) + + (** {1:record Records} *) + + val field : ?label:string t -> string -> ('b -> 'a) -> 'a t -> 'b t + (** [field ~label l prj pp_v] pretty prints a named field using [label] + (defaults to [styled `Yellow string]) for the label, and [using prj = pp_v] + for the field value. *) + + val record : 'a t list -> 'a t + (** [record fields] pretty-prints a value using the concatenation of + [fields], separated by [";@,"], framed in a vertical + box and surrounded by {!braces}. *) + + (** {1:seq Sequencing} + + These are akin to {!iter} and {!iter_bindings} but + delimit the sequences with {!parens}. *) + + val iter : (('a -> unit) -> 'b -> unit) -> 'b t -> 'a t -> 'b t + (** [iter iter pp_name pp_elt] formats an unspecified representation + of the iterations of [iter] over a value using [pp_elt]. The + iteration is named by [pp_name]. *) + + val iter_bindings : (('a -> 'b -> unit) -> 'c -> unit) -> 'c t -> 'a t + -> 'b t -> 'c t + (** [iter_bindings ~sep iter pp_name pp_k pp_v] formats an + unspecified representation of the iterations of [iter] over a + value using [pp_k] and [pp_v]. The iteration is named by + [pp_name]. *) +end + +(** {1:mgs Magnitudes} *) + +val si_size : scale:int -> string -> int t +(** [si_size ~scale unit] formats a non negative integer + representing unit [unit] at scale 10{^scale * 3}, depending on + its magnitude, using power of 3 + {{:https://www.bipm.org/en/publications/si-brochure/chapter3.html} + SI prefixes} (i.e. all of them except deca, hector, deci and + centi). Only US-ASCII characters are used, [=C2=B5] (10{^-6}) is + written using [u]. + + [scale] indicates the scale 10{^scale * 3} an integer + represents, for example [-1] for m[unit] (10{^-3}), [0] for + [unit] (10{^0}), [1] for [kunit] (10{^3}); it must be in the + range \[[-8];[8]\] or [Invalid_argument] is raised. + + Except at the maximal yotta scale always tries to show three + digits of data with trailing fractional zeros omited. Rounds + towards positive infinity (over approximates). *) + +val byte_size : int t +(** [byte_size] is [si_size ~scale:0 "B"]. *) + +val bi_byte_size : int t +(** [bi_byte_size] formats a byte size according to its magnitude + using {{:https://en.wikipedia.org/wiki/Binary_prefix}binary prefixes} + up to pebi bytes (2{^15}). *) + +val uint64_ns_span : int64 t +(** [uint64_ns_span] formats an {e unsigned} nanosecond time span + according to its magnitude using + {{:http://www.bipm.org/en/publications/si-brochure/chapter3.html}SI + prefixes} on seconds and + {{:http://www.bipm.org/en/publications/si-brochure/table6.html}accepted + non-SI units}. Years are counted in Julian years (365.25 SI-accepted d= ays) + as {{:http://www.iau.org/publications/proceedings_rules/units/}defined} + by the International Astronomical Union (IAU). Only US-ASCII characters + are used ([us] is used for [=C2=B5s]). *) + +(** {1:binary Binary data} *) + +type 'a vec =3D int * (int -> 'a) +(** The type for random addressable, sized sequences. Each [(n, f)] + represents the sequence [f 0, ..., f (n - 1)]. *) + +val on_bytes : char vec t -> bytes t +(** [on_bytes pp] is [pp] adapted to format (entire) [bytes]. *) + +val on_string : char vec t -> string t +(** [on_string pp] is [pp] adapted to format (entire) [string]s. *) + +val ascii : ?w:int -> ?subst:unit t -> unit -> char vec t +(** [ascii ~w ~subst ()] formats character sequences by printing + characters in the {e printable US-ASCII range} ([[0x20];[0x7E]]) + as is, and replacing the rest with [subst] (defaults to [fmt "."]). + [w] causes the output to be right padded to the size of formatting + at least [w] sequence elements (defaults to [0]). *) + +val octets : ?w:int -> ?sep:unit t -> unit -> char vec t +(** [octets ~w ~sep ()] formats character sequences as hexadecimal + digits. It prints groups of successive characters of unspecified + length together, separated by [sep] (defaults to {!sp}). [w] + causes the output to be right padded to the size of formatting at + least [w] sequence elements (defaults to [0]). *) + +val addresses : ?addr:int t -> ?w:int -> 'a vec t -> 'a vec t +(** [addresses pp] formats sequences by applying [pp] to consecutive + subsequences of length [w] (defaults to 16). [addr] formats + subsequence offsets (defaults to an unspecified hexadecimal + format). *) + +val hex : ?w:int -> unit -> char vec t +(** [hex ~w ()] formats character sequences as traditional hex dumps, + matching the output of {e xxd} and forcing line breaks after every + [w] characters (defaults to 16). *) + +(** {1:text Words, paragraphs, text and lines} + + {b Note.} These functions only work on US-ASCII strings and/or + with newlines (['\n']). If you are dealing with UTF-8 strings or + different kinds of line endings you should use the pretty-printers + from {!Uuseg_string}. + + {b White space.} White space is one of the following US-ASCII + characters: space [' '] ([0x20]), tab ['\t'] ([0x09]), newline + ['\n'] ([0x0A]), vertical tab ([0x0B]), form feed ([0x0C]), + carriage return ['\r'] ([0x0D]). *) + +val words : string t +(** [words] formats words by suppressing initial and trailing + white space and replacing consecutive white space with + a single {!Format.pp_print_space}. *) + +val paragraphs : string t +(** [paragraphs] formats paragraphs by suppressing initial and trailing + spaces and newlines, replacing blank lines (a line made only + of white space) by a two {!Format.pp_force_newline} and remaining + consecutive white space with a single {!Format.pp_print_space}. *) + +val text : string t +(** [text] formats text by respectively replacing spaces and newlines in + the string with {!Format.pp_print_space} and {!Format.pp_force_newline= }. *) + +val lines : string t +(** [lines] formats lines by replacing newlines (['\n']) in the string + with calls to {!Format.pp_force_newline}. *) + +val truncated : max:int -> string t +(** [truncated ~max] formats a string using at most [max] + characters. If the string doesn't fit, it is truncated and ended + with three consecutive dots which do count towards [max]. *) + +val text_loc : ((int * int) * (int * int)) t +(** [text_loc] formats a line-column text range according to + {{:http://www.gnu.org/prep/standards/standards.html#Errors} + GNU conventions}. *) + +(** {1:hci HCI fragments} *) + +val one_of : ?empty:unit t -> 'a t -> 'a list t +(** [one_of ~empty pp_v ppf l] formats according to the length of [l] + {ul + {- [0], formats {!empty} (defaults to {!nop}).} + {- [1], formats the element with [pp_v].} + {- [2], formats ["either %a or %a"] with the list elements} + {- [n], formats ["one of %a, ... or %a"] with the list elements}} *) + +val did_you_mean : + ?pre:unit t -> ?post:unit t -> kind:string -> 'a t -> ('a * 'a list) t +(** [did_you_mean ~pre kind ~post pp_v] formats a faulty value [v] of + kind [kind] and a list of [hints] that [v] could have been + mistaken for. + + [pre] defaults to [unit "Unknown"], [post] to {!nop} they surround + the faulty value before the "did you mean" part as follows ["%a %s + %a%a." pre () kind pp_v v post ()]. If [hints] is empty no "did + you mean" part is printed. *) + +(** {1:utf8_cond Conditional UTF-8 formatting} + + {b Note.} Since {!Format} is not UTF-8 aware using UTF-8 output + may derail the pretty printing process. Use the pretty-printers + from {!Uuseg_string} if you are serious about UTF-8 formatting. *) + +val if_utf_8 : 'a t -> 'a t -> 'a t +(** [if_utf_8 pp_u pp ppf v] is: + {ul + {- [pp_u ppf v] if [utf_8 ppf] is [true].} + {- [pp ppf v] otherwise.}} *) + +val utf_8 : Format.formatter -> bool +(** [utf_8 ppf] is [true] if UTF-8 output is enabled on [ppf]. If + {!set_utf_8} hasn't been called on [ppf] this is [true]. *) + +val set_utf_8 : Format.formatter -> bool -> unit +(** [set_utf_8 ppf b] enables or disables conditional UTF-8 formatting + on [ppf]. + + @raise Invalid_argument if [ppf] is {!Format.str_formatter}: it is + is always UTF-8 enabled. *) + +(** {1:styled Styled formatting} *) + +type color =3D + [ `Black | `Blue | `Cyan | `Green | `Magenta | `Red | `White | `Yellow ] +(** The type for colors. *) + +type style =3D + [ `None | `Bold | `Faint | `Italic | `Underline | `Reverse + | `Fg of [ color | `Hi of color ] + | `Bg of [ color | `Hi of color ] + | color (** deprecated *) ] +(** The type for styles: + {ul + {- [`None] resets the styling.} + {- [`Bold], [`Faint], [`Italic], [`Underline] and [`Reverse] are + display attributes.} + {- [`Fg _] is the foreground color or high-intensity color on [`Hi _].} + {- [`Bg _] is the foreground color or high-intensity color on [`Hi _].} + {- [#color] is the foreground colour, {b deprecated} use [`Fg + #color] instead.}} *) + +val styled : style -> 'a t -> 'a t +(** [styled s pp] formats like [pp] but styled with [s]. *) + +(** {2 Style rendering control} *) + +type style_renderer =3D [ `Ansi_tty | `None ] +(** The type for style renderers. + {ul + {- [`Ansi_tty], renders styles using + {{:http://www.ecma-international.org/publications/standards/Ecma-04= 8.htm} + ANSI escape sequences}.} + {- [`None], styled rendering has no effect.}} *) + +val style_renderer : Format.formatter -> style_renderer +(** [style_renderer ppf] is the style renderer used by [ppf]. If + {!set_style_renderer} has never been called on [ppf] this is + [`None]. *) + +val set_style_renderer : Format.formatter -> style_renderer -> unit +(** [set_style_renderer ppf r] sets the style renderer of [ppf] to [r]. + + @raise Invalid_argument if [ppf] is {!Format.str_formatter}: its + renderer is always [`None]. *) + +(** {1:stringconverters Converting with string value converters} *) + +val of_to_string : ('a -> string) -> 'a t +(** [of_to_string f ppf v] is [string ppf (f v)]. *) + +val to_to_string : 'a t -> 'a -> string +(** [to_to_string pp_v v] is [strf "%a" pp_v v]. *) + +(** {1:deprecated Deprecated} *) + +val strf : ('a, Format.formatter, unit, string) format4 -> 'a +(** @deprecated use {!str} instead. *) + +val kstrf : (string -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> = 'b +(** @deprecated use {!kstr} instead. *) + +val strf_like : + Format.formatter -> ('a, Format.formatter, unit, string) format4 -> 'a +(** @deprecated use {!str_like} instead. *) + +val always : (unit, Format.formatter, unit) Stdlib.format -> 'a t +(** @deprecated use {!any} instead. *) + +val unit : (unit, Format.formatter, unit) Stdlib.format -> unit t +(** @deprecated use {!any}. *) + +val prefix : unit t -> 'a t -> 'a t +(** @deprecated use {!( ++ )}. *) + +val suffix : unit t -> 'a t -> 'a t +(** @deprecated use {!( ++ )}. *) + +val styled_unit : + style -> (unit, Format.formatter, unit) Stdlib.format -> unit t +(** @deprecated, use [styled s (any fmt)] instead *) + +(** {1:nameconv Naming conventions} + + Given a type [ty] use: + + {ul + {- [pp_ty] for a pretty printer that provides full control to the + client and does not wrap the formatted value in an enclosing + box. See {{!stdlib}these examples}.} + {- [pp_dump_ty] for a pretty printer that provides little control + over the pretty-printing process, wraps the rendering in an + enclosing box and tries as much as possible to respect the + OCaml syntax. These pretty-printers should make it easy to + inspect and understand values of the given type, they are + mainly used for quick printf debugging and/or toplevel interaction. + See {{!Dump.stdlib} these examples}.}} + + If you are in a situation where making a difference between [dump_ty] + and [pp_ty] doesn't make sense then use [pp_ty]. + + For a type [ty] that is the main type of the module (the "[M.t]" + convention) drop the suffix, that is simply use [M.pp] and + [M.pp_dump]. *) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2014 The fmt programmers + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/fmt/src/fmt.mllib b/tools/ocaml/dunivers= e/fmt/src/fmt.mllib new file mode 100644 index 0000000000..977dbb9876 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt.mllib @@ -0,0 +1 @@ +Fmt diff --git a/tools/ocaml/duniverse/fmt/src/fmt_cli.ml b/tools/ocaml/duniver= se/fmt/src/fmt_cli.ml new file mode 100644 index 0000000000..0376806759 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt_cli.ml @@ -0,0 +1,32 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +let strf =3D Format.asprintf + +open Cmdliner + +let style_renderer ?env ?docs () =3D + let enum =3D ["auto", None; "always", Some `Ansi_tty; "never", Some `Non= e] in + let color =3D Arg.enum enum in + let enum_alts =3D Arg.doc_alts_enum enum in + let doc =3D strf "Colorize the output. $(docv) must be %s." enum_alts in + Arg.(value & opt color None & info ["color"] ?env ~doc ~docv:"WHEN" ?doc= s) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/fmt/src/fmt_cli.mli b/tools/ocaml/dunive= rse/fmt/src/fmt_cli.mli new file mode 100644 index 0000000000..dcdd5d86aa --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt_cli.mli @@ -0,0 +1,45 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** {!Cmdliner} support for [Fmt]. *) + +(** {1 Option for setting the style renderer} *) + +val style_renderer : ?env:Cmdliner.Arg.env -> ?docs:string -> unit -> + Fmt.style_renderer option Cmdliner.Term.t +(** [style_renderer ?env ?docs ()] is a {!Cmdliner} option [--color] that = can + be directly used with the optional arguments of + {{!Fmt_tty.tty_setup}TTY setup} or to control + {{!Fmt.set_style_renderer}style rendering}. The option is + documented under [docs] (defaults to the default in + {!Cmdliner.Arg.info}). + + The option is a tri-state enumerated value that when used with + {{!Fmt_tty.tty_setup}TTY setup} takes over the automatic setup: + {ul + {- [--color=3Dnever], the value is [Some `None], forces no styling.} + {- [--color=3Dalways], the value is [Some `Ansi], forces ANSI styling.} + {- [--color=3Dauto] or absent, the value is [None], automatic setup + takes place.}} + + If [env] is provided, the option default value ([None]) can be + overridden by the corresponding environment variable. *) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/fmt/src/fmt_cli.mllib b/tools/ocaml/duni= verse/fmt/src/fmt_cli.mllib new file mode 100644 index 0000000000..6a0743e652 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt_cli.mllib @@ -0,0 +1 @@ +Fmt_cli diff --git a/tools/ocaml/duniverse/fmt/src/fmt_top.ml b/tools/ocaml/duniver= se/fmt/src/fmt_top.ml new file mode 100644 index 0000000000..7bcf4b2062 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt_top.ml @@ -0,0 +1,23 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +let () =3D ignore (Toploop.use_file Format.err_formatter "fmt_tty_top_init= .ml") + +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/fmt/src/fmt_top.mllib b/tools/ocaml/duni= verse/fmt/src/fmt_top.mllib new file mode 100644 index 0000000000..49c6b94c54 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt_top.mllib @@ -0,0 +1 @@ +Fmt_top \ No newline at end of file diff --git a/tools/ocaml/duniverse/fmt/src/fmt_tty.ml b/tools/ocaml/duniver= se/fmt/src/fmt_tty.ml new file mode 100644 index 0000000000..eb28007131 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt_tty.ml @@ -0,0 +1,78 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +let is_infix ~affix s =3D + (* Damned, already missing astring, from which this is c&p *) + let len_a =3D String.length affix in + let len_s =3D String.length s in + if len_a > len_s then false else + let max_idx_a =3D len_a - 1 in + let max_idx_s =3D len_s - len_a in + let rec loop i k =3D + if i > max_idx_s then false else + if k > max_idx_a then true else + if k > 0 then + if String.get affix k =3D String.get s (i + k) then loop i (k + 1) e= lse + loop (i + 1) 0 + else if String.get affix 0 =3D String.get s i then loop i 1 else + loop (i + 1) 0 + in + loop 0 0 + +let setup ?style_renderer ?utf_8 oc =3D + let ppf =3D + if oc =3D=3D Stdlib.stdout then Fmt.stdout else + if oc =3D=3D Stdlib.stderr then Fmt.stderr else + Format.formatter_of_out_channel oc + in + let style_renderer =3D match style_renderer with + | Some r -> r + | None -> + let dumb =3D + try match Sys.getenv "TERM" with + | "dumb" | "" -> true + | _ -> false + with + Not_found -> true + in + let isatty =3D try Unix.(isatty (descr_of_out_channel oc)) with + | Unix.Unix_error _ -> false + in + if not dumb && isatty then `Ansi_tty else `None + in + let utf_8 =3D match utf_8 with + | Some b -> b + | None -> + let has_utf_8 var =3D + try is_infix "UTF-8" (String.uppercase_ascii (Sys.getenv var)) + with Not_found -> false + in + has_utf_8 "LANG" || has_utf_8 "LC_ALL" || has_utf_8 "LC_CTYPE" + in + Fmt.set_style_renderer ppf style_renderer; + Fmt.set_utf_8 ppf utf_8; + ppf + +let setup_std_outputs ?style_renderer ?utf_8 () =3D + ignore (setup ?style_renderer ?utf_8 stdout); + ignore (setup ?style_renderer ?utf_8 stderr); + () + +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/fmt/src/fmt_tty.mli b/tools/ocaml/dunive= rse/fmt/src/fmt_tty.mli new file mode 100644 index 0000000000..f894325e1d --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt_tty.mli @@ -0,0 +1,50 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(** [Fmt] TTY setup. + + [Fmt_tty] provides simple automatic setup on channel formatters for: + {ul + {- {!Fmt.set_style_renderer}. [`Ansi_tty] is used if the channel + {{!Unix.isatty}is a tty} and the environment variable + [TERM] is defined and its value is not ["dumb"]. [`None] is + used otherwise.} + {- {!Fmt.set_utf_8}. [true] is used if one of the following + environment variables has ["UTF-8"] as a case insensitive + substring: [LANG], [LC_ALL], [LC_CTYPE].}} *) + +(** {1:tty_setup TTY setup} *) + +val setup : ?style_renderer:Fmt.style_renderer -> ?utf_8:bool -> + out_channel -> Format.formatter +(** [setup ?style_renderer ?utf_8 outc] is a formatter for [outc] with + {!Fmt.set_style_renderer} and {!Fmt.set_utf_8} correctly setup. If + [style_renderer] or [utf_8] are specified they override the automatic + setup. + + If [outc] is {!stdout}, {!Fmt.stdout} is returned. If [outc] is + {!stderr}, {!Fmt.stderr} is returned. *) + +val setup_std_outputs : ?style_renderer:Fmt.style_renderer -> ?utf_8:bool = -> + unit -> unit +(** [setup_std_outputs ?style_renderer ?utf_8 ()] applies {!setup} + on {!stdout} and {!stderr}. *) + +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/fmt/src/fmt_tty.mllib b/tools/ocaml/duni= verse/fmt/src/fmt_tty.mllib new file mode 100644 index 0000000000..4e15d82115 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt_tty.mllib @@ -0,0 +1 @@ +Fmt_tty diff --git a/tools/ocaml/duniverse/fmt/src/fmt_tty_top_init.ml b/tools/ocam= l/duniverse/fmt/src/fmt_tty_top_init.ml new file mode 100644 index 0000000000..3309166c5e --- /dev/null +++ b/tools/ocaml/duniverse/fmt/src/fmt_tty_top_init.ml @@ -0,0 +1,23 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +let () =3D Fmt_tty.setup_std_outputs () + +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/fmt/test/test.ml b/tools/ocaml/duniverse= /fmt/test/test.ml new file mode 100644 index 0000000000..48476dffb7 --- /dev/null +++ b/tools/ocaml/duniverse/fmt/test/test.ml @@ -0,0 +1,322 @@ +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ------------------------------------------------------------------------= ---*) + +(* +let test_exn_backtrace () =3D (* Don't move this test in the file. *) + try failwith "Test" with + | ex -> + let bt =3D Printexc.get_raw_backtrace () in + let fmt =3D Fmt.strf "%a" Fmt.exn_backtrace (ex,bt) in + assert begin match Printexc.backtrace_status () with + | false -> fmt =3D "Exception: Failure(\"Test\")\nNo backtrace avail= able." + | true -> + fmt =3D "Exception: Failure(\"Test\")\n\ + Raised at file \"pervasives.ml\", line 32, characters 22-= 33\n\ + Called from file \"test/test.ml\", line 8, characters 6-2= 1" + end +*) + +let test_dump_uchar () =3D + let str u =3D Format.asprintf "%a" Fmt.Dump.uchar u in + assert (str Uchar.min =3D "U+0000"); + assert (str Uchar.(succ min) =3D "U+0001"); + assert (str Uchar.(of_int 0xFFFF) =3D "U+FFFF"); + assert (str Uchar.(succ (of_int 0xFFFF)) =3D "U+10000"); + assert (str Uchar.(pred max) =3D "U+10FFFE"); + assert (str Uchar.max =3D "U+10FFFF"); + () + +let test_utf_8 () =3D + let ppf =3D Format.formatter_of_buffer (Buffer.create 23) in + assert (Fmt.utf_8 ppf =3D true); + Fmt.set_utf_8 ppf false; + assert (Fmt.utf_8 ppf =3D false); + Fmt.set_utf_8 ppf true; + assert (Fmt.utf_8 ppf =3D true); + () + +let test_style_renderer () =3D + let ppf =3D Format.formatter_of_buffer (Buffer.create 23) in + assert (Fmt.style_renderer ppf =3D `None); + Fmt.set_style_renderer ppf `Ansi_tty; + assert (Fmt.style_renderer ppf =3D `Ansi_tty); + Fmt.set_style_renderer ppf `None; + assert (Fmt.style_renderer ppf =3D `None); + () + +let test_exn_typechecks () =3D + let (_ : bool) =3D true || Fmt.failwith "%s" "" in + let (_ : bool) =3D true || Fmt.invalid_arg "%s" "" in + () + +let test_kstr_str_like_partial_app () =3D + let assertf f =3D assert (f "X" =3D f "X") in + let test_kstrf fmt =3D Fmt.kstr (fun x -> x) fmt in + let test_strf_like fmt =3D Fmt.str_like Fmt.stderr fmt in + assertf (test_strf_like "%s"); + assertf (test_kstrf "%s"); + () + + +let test_byte_size () =3D + let size s =3D Fmt.str "%a" Fmt.byte_size s in + assert (size 0 =3D "0B"); + assert (size 999 =3D "999B"); + assert (size 1000 =3D "1kB"); + assert (size 1001 =3D "1.01kB"); + assert (size 1010 =3D "1.01kB"); + assert (size 1011 =3D "1.02kB"); + assert (size 1020 =3D "1.02kB"); + assert (size 1100 =3D "1.1kB"); + assert (size 1101 =3D "1.11kB"); + assert (size 1109 =3D "1.11kB"); + assert (size 1111 =3D "1.12kB"); + assert (size 1119 =3D "1.12kB"); + assert (size 1120 =3D "1.12kB"); + assert (size 1121 =3D "1.13kB"); + assert (size 9990 =3D "9.99kB"); + assert (size 9991 =3D "10kB"); + assert (size 9999 =3D "10kB"); + assert (size 10_000 =3D "10kB"); + assert (size 10_001 =3D "10.1kB"); + assert (size 10_002 =3D "10.1kB"); + assert (size 10_099 =3D "10.1kB"); + assert (size 10_100 =3D "10.1kB"); + assert (size 10_100 =3D "10.1kB"); + assert (size 10_101 =3D "10.2kB"); + assert (size 10_199 =3D "10.2kB"); + assert (size 10_199 =3D "10.2kB"); + assert (size 10_200 =3D "10.2kB"); + assert (size 10_201 =3D "10.3kB"); + assert (size 99_901 =3D "100kB"); + assert (size 99_999 =3D "100kB"); + assert (size 100_000 =3D "100kB"); + assert (size 100_001 =3D "101kB"); + assert (size 100_999 =3D "101kB"); + assert (size 101_000 =3D "101kB"); + assert (size 101_001 =3D "102kB"); + assert (size 999_000 =3D "999kB"); + assert (size 999_001 =3D "1MB"); + assert (size 999_999 =3D "1MB"); + assert (size 1_000_000 =3D "1MB"); + assert (size 1_000_001 =3D "1.01MB"); + assert (size 1_009_999 =3D "1.01MB"); + assert (size 1_010_000 =3D "1.01MB"); + assert (size 1_010_001 =3D "1.02MB"); + assert (size 1_019_999 =3D "1.02MB"); + assert (size 1_020_000 =3D "1.02MB"); + assert (size 1_020_001 =3D "1.03MB"); + assert (size 1_990_000 =3D "1.99MB"); + assert (size 1_990_001 =3D "2MB"); + assert (size 1_999_999 =3D "2MB"); + assert (size 2_000_000 =3D "2MB"); + assert (size 9_990_000 =3D "9.99MB"); + assert (size 9_990_001 =3D "10MB"); + assert (size 9_990_999 =3D "10MB"); + assert (size 10_000_000 =3D "10MB"); + assert (size 10_000_001 =3D "10.1MB"); + assert (size 10_099_999 =3D "10.1MB"); + assert (size 10_100_000 =3D "10.1MB"); + assert (size 10_900_001 =3D "11MB"); + assert (size 10_999_999 =3D "11MB"); + assert (size 11_000_000 =3D "11MB"); + assert (size 11_000_001 =3D "11.1MB"); + assert (size 99_900_000 =3D "99.9MB"); + assert (size 99_900_001 =3D "100MB"); + assert (size 99_999_999 =3D "100MB"); + assert (size 100_000_000 =3D "100MB"); + assert (size 100_000_001 =3D "101MB"); + assert (size 100_999_999 =3D "101MB"); + assert (size 101_000_000 =3D "101MB"); + assert (size 101_000_000 =3D "101MB"); + assert (size 999_000_000 =3D "999MB"); + assert (size 999_000_001 =3D "1GB"); + assert (size 999_999_999 =3D "1GB"); + assert (size 1_000_000_000 =3D "1GB"); + assert (size 1_000_000_001 =3D "1.01GB"); + assert (size 1_000_000_001 =3D "1.01GB"); + () + +let test_uint64_ns_span () =3D + let span s =3D Fmt.str "%a" Fmt.uint64_ns_span (Int64.of_string s) in + assert (span "0u0" =3D "0ns"); + assert (span "0u999" =3D "999ns"); + assert (span "0u1_000" =3D "1us"); + assert (span "0u1_001" =3D "1.01us"); + assert (span "0u1_009" =3D "1.01us"); + assert (span "0u1_010" =3D "1.01us"); + assert (span "0u1_011" =3D "1.02us"); + assert (span "0u1_090" =3D "1.09us"); + assert (span "0u1_091" =3D "1.1us"); + assert (span "0u1_100" =3D "1.1us"); + assert (span "0u1_101" =3D "1.11us"); + assert (span "0u1_109" =3D "1.11us"); + assert (span "0u1_110" =3D "1.11us"); + assert (span "0u1_111" =3D "1.12us"); + assert (span "0u1_990" =3D "1.99us"); + assert (span "0u1_991" =3D "2us"); + assert (span "0u1_999" =3D "2us"); + assert (span "0u2_000" =3D "2us"); + assert (span "0u2_001" =3D "2.01us"); + assert (span "0u9_990" =3D "9.99us"); + assert (span "0u9_991" =3D "10us"); + assert (span "0u9_999" =3D "10us"); + assert (span "0u10_000" =3D "10us"); + assert (span "0u10_001" =3D "10.1us"); + assert (span "0u10_099" =3D "10.1us"); + assert (span "0u10_100" =3D "10.1us"); + assert (span "0u10_101" =3D "10.2us"); + assert (span "0u10_900" =3D "10.9us"); + assert (span "0u10_901" =3D "11us"); + assert (span "0u10_999" =3D "11us"); + assert (span "0u11_000" =3D "11us"); + assert (span "0u11_001" =3D "11.1us"); + assert (span "0u11_099" =3D "11.1us"); + assert (span "0u11_100" =3D "11.1us"); + assert (span "0u11_101" =3D "11.2us"); + assert (span "0u99_900" =3D "99.9us"); + assert (span "0u99_901" =3D "100us"); + assert (span "0u99_999" =3D "100us"); + assert (span "0u100_000" =3D "100us"); + assert (span "0u100_001" =3D "101us"); + assert (span "0u100_999" =3D "101us"); + assert (span "0u101_000" =3D "101us"); + assert (span "0u101_001" =3D "102us"); + assert (span "0u101_999" =3D "102us"); + assert (span "0u102_000" =3D "102us"); + assert (span "0u999_000" =3D "999us"); + assert (span "0u999_001" =3D "1ms"); + assert (span "0u999_001" =3D "1ms"); + assert (span "0u999_999" =3D "1ms"); + assert (span "0u1_000_000" =3D "1ms"); + assert (span "0u1_000_001" =3D "1.01ms"); + assert (span "0u1_009_999" =3D "1.01ms"); + assert (span "0u1_010_000" =3D "1.01ms"); + assert (span "0u1_010_001" =3D "1.02ms"); + assert (span "0u9_990_000" =3D "9.99ms"); + assert (span "0u9_990_001" =3D "10ms"); + assert (span "0u9_999_999" =3D "10ms"); + assert (span "0u10_000_000" =3D "10ms"); + assert (span "0u10_000_001" =3D "10.1ms"); + assert (span "0u10_000_001" =3D "10.1ms"); + assert (span "0u10_099_999" =3D "10.1ms"); + assert (span "0u10_100_000" =3D "10.1ms"); + assert (span "0u10_100_001" =3D "10.2ms"); + assert (span "0u99_900_000" =3D "99.9ms"); + assert (span "0u99_900_001" =3D "100ms"); + assert (span "0u99_999_999" =3D "100ms"); + assert (span "0u100_000_000" =3D "100ms"); + assert (span "0u100_000_001" =3D "101ms"); + assert (span "0u100_999_999" =3D "101ms"); + assert (span "0u101_000_000" =3D "101ms"); + assert (span "0u101_000_001" =3D "102ms"); + assert (span "0u999_000_000" =3D "999ms"); + assert (span "0u999_000_001" =3D "1s"); + assert (span "0u999_999_999" =3D "1s"); + assert (span "0u1_000_000_000" =3D "1s"); + assert (span "0u1_000_000_001" =3D "1.01s"); + assert (span "0u1_009_999_999" =3D "1.01s"); + assert (span "0u1_010_000_000" =3D "1.01s"); + assert (span "0u1_010_000_001" =3D "1.02s"); + assert (span "0u1_990_000_000" =3D "1.99s"); + assert (span "0u1_990_000_001" =3D "2s"); + assert (span "0u1_999_999_999" =3D "2s"); + assert (span "0u2_000_000_000" =3D "2s"); + assert (span "0u2_000_000_001" =3D "2.01s"); + assert (span "0u9_990_000_000" =3D "9.99s"); + assert (span "0u9_999_999_999" =3D "10s"); + assert (span "0u10_000_000_000" =3D "10s"); + assert (span "0u10_000_000_001" =3D "10.1s"); + assert (span "0u10_099_999_999" =3D "10.1s"); + assert (span "0u10_100_000_000" =3D "10.1s"); + assert (span "0u10_100_000_001" =3D "10.2s"); + assert (span "0u59_900_000_000" =3D "59.9s"); + assert (span "0u59_900_000_001" =3D "1min"); + assert (span "0u59_999_999_999" =3D "1min"); + assert (span "0u60_000_000_000" =3D "1min"); + assert (span "0u60_000_000_001" =3D "1min1s"); + assert (span "0u60_999_999_999" =3D "1min1s"); + assert (span "0u61_000_000_000" =3D "1min1s"); + assert (span "0u61_000_000_001" =3D "1min2s"); + assert (span "0u119_000_000_000" =3D "1min59s"); + assert (span "0u119_000_000_001" =3D "2min"); + assert (span "0u119_999_999_999" =3D "2min"); + assert (span "0u120_000_000_000" =3D "2min"); + assert (span "0u120_000_000_001" =3D "2min1s"); + assert (span "0u3599_000_000_000" =3D "59min59s"); + assert (span "0u3599_000_000_001" =3D "1h"); + assert (span "0u3599_999_999_999" =3D "1h"); + assert (span "0u3600_000_000_000" =3D "1h"); + assert (span "0u3600_000_000_001" =3D "1h1min"); + assert (span "0u3659_000_000_000" =3D "1h1min"); + assert (span "0u3659_000_000_001" =3D "1h1min"); + assert (span "0u3659_999_999_999" =3D "1h1min"); + assert (span "0u3660_000_000_000" =3D "1h1min"); + assert (span "0u3660_000_000_001" =3D "1h2min"); + assert (span "0u3660_000_000_001" =3D "1h2min"); + assert (span "0u3660_000_000_001" =3D "1h2min"); + assert (span "0u3720_000_000_000" =3D "1h2min"); + assert (span "0u3720_000_000_001" =3D "1h3min"); + assert (span "0u7140_000_000_000" =3D "1h59min"); + assert (span "0u7140_000_000_001" =3D "2h"); + assert (span "0u7199_999_999_999" =3D "2h"); + assert (span "0u7200_000_000_000" =3D "2h"); + assert (span "0u7200_000_000_001" =3D "2h1min"); + assert (span "0u86340_000_000_000" =3D "23h59min"); + assert (span "0u86340_000_000_001" =3D "1d"); + assert (span "0u86400_000_000_000" =3D "1d"); + assert (span "0u86400_000_000_001" =3D "1d1h"); + assert (span "0u89999_999_999_999" =3D "1d1h"); + assert (span "0u90000_000_000_000" =3D "1d1h"); + assert (span "0u90000_000_000_001" =3D "1d2h"); + assert (span "0u169200_000_000_000" =3D "1d23h"); + assert (span "0u169200_000_000_001" =3D "2d"); + assert (span "0u169200_000_000_001" =3D "2d"); + assert (span "0u172799_999_999_999" =3D "2d"); + assert (span "0u172800_000_000_000" =3D "2d"); + assert (span "0u172800_000_000_001" =3D "2d1h"); + assert (span "0u31536000_000_000_000" =3D "365d"); + assert (span "0u31554000_000_000_000" =3D "365d5h"); + assert ( + (* Technically this should round to a year but it does get rendered. + I don't think it matters, it's not inacurate per se. *) + span "0u31554000_000_000_001" =3D "365d6h"); + assert (span "0u31557600_000_000_000" =3D "1a"); + assert (span "0u31557600_000_000_001" =3D "1a1d"); + assert (span "0u63028800_000_000_000" =3D "1a365d"); + assert (span "0u63093600_000_000_000" =3D "1a365d"); + assert (span "0u63093600_000_000_001" =3D "2a"); + assert (span "0u63115200_000_000_000" =3D "2a"); + assert (span "0u63115200_000_000_001" =3D "2a1d"); + () + +let tests () =3D + test_dump_uchar (); + test_utf_8 (); + test_style_renderer (); + test_kstr_str_like_partial_app (); + test_byte_size (); + test_uint64_ns_span (); + Printf.printf "Done.\n"; + () + +let () =3D tests () + +(*------------------------------------------------------------------------= --- + Copyright (c) 2015 The fmt programmers + + Permission to use, copy, modify, and/or 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. + ------------------------------------------------------------------------= ---*) diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/.gitignore b/tools/= ocaml/duniverse/ocaml-afl-persistent/.gitignore new file mode 100644 index 0000000000..655e32b07c --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/.gitignore @@ -0,0 +1,2 @@ +_build +.merlin diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/CHANGES.md b/tools/= ocaml/duniverse/ocaml-afl-persistent/CHANGES.md new file mode 100644 index 0000000000..da38d286bc --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/CHANGES.md @@ -0,0 +1,22 @@ +v1.3 (13th Nov 2018) +--------------------- + +Uses /bin/sh instead of /bin/bash to fix install problems + +v1.2 (22nd May 2017) +--------------------- + +Allow installation on non-AFL switches. +(Doesn't do much, but lets you use Crowbar in quickcheck mode) + + +v1.1 (12th January 2017) +--------------------- + +Improved stability of instrumentation output + + +v1.0 (6th December 2016) +--------------------- + +Initial release diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/LICENSE.md b/tools/= ocaml/duniverse/ocaml-afl-persistent/LICENSE.md new file mode 100644 index 0000000000..89cbf71481 --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/LICENSE.md @@ -0,0 +1,8 @@ +Copyright (c) 2016 Stephen Dolan + +Permission is hereby granted, free of charge, to any person obtaining a co= py of this software and associated documentation files (the "Software"), to= deal in the Software without restriction, including without limitation the= rights to use, copy, modify, merge, publish, distribute, sublicense, and/o= r sell copies of the Software, and to permit persons to whom the Software i= s furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in= all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR= IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, F= ITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE = AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIAB= ILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, O= UT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN TH= E SOFTWARE. + diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/README.md b/tools/o= caml/duniverse/ocaml-afl-persistent/README.md new file mode 100644 index 0000000000..2ed9916c9f --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/README.md @@ -0,0 +1,17 @@ +# afl-persistent - persistent-mode afl-fuzz for ocaml + +by using `AflPersistent.run`, you can fuzz things really fast: + +```ocaml +let f () =3D + let s =3D read_line () in + match Array.to_list (Array.init (String.length s) (String.get s)) with + ['s'; 'e'; 'c'; 'r'; 'e'; 't'; ' '; 'c'; 'o'; 'd'; 'e'] -> failwith "u= h oh" + | _ -> () + +let _ =3D AflPersistent.run f +``` + +compile with a version of ocaml that supports afl. that means trunk +for now, but the next release (4.05) will work too, and pass the +`-afl-instrument` option to ocamlopt. diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/afl-persistent.opam= b/tools/ocaml/duniverse/ocaml-afl-persistent/afl-persistent.opam new file mode 100644 index 0000000000..12aedccab5 --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/afl-persistent.opam @@ -0,0 +1,49 @@ +# This file is generated by dune, edit dune-project instead +version: "1.3" +synopsis: "Use afl-fuzz in persistent mode" +description: """ +afl-fuzz normally works by repeatedly fork()ing the program being +tested. using this package, you can run afl-fuzz in 'persistent mode', +which avoids repeated forking and is much faster. +""" +maintainer: ["stephen.dolan@cl.cam.ac.uk"] +authors: ["Stephen Dolan"] +license: "MIT" +homepage: "https://github.com/stedolan/ocaml-afl-persistent" +bug-reports: "https://github.com/stedolan/ocaml-afl-persistent/issues" +depends: [ + "dune" {>=3D "2.0"} + "ocaml" {>=3D "4.00"} + "base-unix" +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/stedolan/ocaml-afl-persistent.git" +opam-version: "2.0" +post-messages: [ +"afl-persistent is installed, but since AFL instrumentation is not availab= le +with this OCaml compiler, instrumented fuzzing with afl-fuzz won't work. + +To use instrumented fuzzing, switch to an OCaml version supporting AFL, su= ch +as 4.07.1+afl." {success & !afl-available} + +"afl-persistent is installed, but since the current OCaml compiler does +not enable AFL instrumentation by default, most packages will not be +instrumented and fuzzing with afl-fuzz may not be effective. + +To globally enable AFL instrumentation, use an OCaml switch such as +4.07.1+afl." {success & afl-available & !afl-always} +] + diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/afl-persistent.opam= .template b/tools/ocaml/duniverse/ocaml-afl-persistent/afl-persistent.opam.= template new file mode 100644 index 0000000000..a9787ebc62 --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/afl-persistent.opam.templa= te @@ -0,0 +1,16 @@ +opam-version: "2.0" +post-messages: [ +"afl-persistent is installed, but since AFL instrumentation is not availab= le +with this OCaml compiler, instrumented fuzzing with afl-fuzz won't work. + +To use instrumented fuzzing, switch to an OCaml version supporting AFL, su= ch +as 4.07.1+afl." {success & !afl-available} + +"afl-persistent is installed, but since the current OCaml compiler does +not enable AFL instrumentation by default, most packages will not be +instrumented and fuzzing with afl-fuzz may not be effective. + +To globally enable AFL instrumentation, use an OCaml switch such as +4.07.1+afl." {success & afl-available & !afl-always} +] + diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.avail= able.ml b/tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.availabl= e.ml new file mode 100644 index 0000000000..351e16c2a6 --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.available.ml @@ -0,0 +1,21 @@ +external reset_instrumentation : bool -> unit =3D "caml_reset_afl_instrume= ntation" +external sys_exit : int -> 'a =3D "caml_sys_exit" + +let run f =3D + let _ =3D try ignore (Sys.getenv "##SIG_AFL_PERSISTENT##") with Not_foun= d -> () in + let persist =3D match Sys.getenv "__AFL_PERSISTENT" with + | _ -> true + | exception Not_found -> false in + let pid =3D Unix.getpid () in + if persist then begin + reset_instrumentation true; + for _ =3D 1 to 1000 do + f (); + Unix.kill pid Sys.sigstop; + reset_instrumentation false + done; + f (); + sys_exit 0; + end else + f () + diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.mli b= /tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.mli new file mode 100644 index 0000000000..f446ddd605 --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.mli @@ -0,0 +1 @@ +val run : (unit -> unit) -> unit diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.stub.= ml b/tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.stub.ml new file mode 100644 index 0000000000..2fd679dc1f --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.stub.ml @@ -0,0 +1 @@ +let run f =3D f () diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/detect.sh b/tools/o= caml/duniverse/ocaml-afl-persistent/detect.sh new file mode 100755 index 0000000000..45a427bda2 --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/detect.sh @@ -0,0 +1,43 @@ +#!/bin/sh + +set -e +set -x + +ocamlc=3D'ocamlc -g -bin-annot' +ocamlopt=3D'ocamlopt -g -bin-annot' + +echo 'print_string "hello"' > afl_check.ml + +if ocamlopt -dcmm -c afl_check.ml 2>&1 | grep -q caml_afl; then + afl_always=3Dtrue +else + afl_always=3Dfalse +fi + +if [ "$(ocamlopt -afl-instrument afl_check.ml -o test 2>/dev/null && ./tes= t)" =3D "hello" ]; then + ocamlopt=3D"$ocamlopt -afl-inst-ratio 0" + afl_available=3Dtrue +elif [ "$(ocamlopt -version)" =3D 4.04.0+afl ]; then + # hack for the backported 4.04+afl branch + export AFL_INST_RATIO=3D0 + afl_available=3Dtrue +else + afl_available=3Dfalse +fi + +cat > afl-persistent.config <=3D 4.00)) + base-unix)) diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/test.ml b/tools/oca= ml/duniverse/ocaml-afl-persistent/test.ml new file mode 100644 index 0000000000..1d12af1877 --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/test.ml @@ -0,0 +1,3 @@ +let () =3D + AflPersistent.run (fun () -> exit 0); + failwith "AflPersistent.run failed" diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/test/harness.ml b/t= ools/ocaml/duniverse/ocaml-afl-persistent/test/harness.ml new file mode 100644 index 0000000000..dbcbebf0b1 --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/test/harness.ml @@ -0,0 +1,22 @@ +external reset_instrumentation : bool -> unit =3D "caml_reset_afl_instrume= ntation" +external sys_exit : int -> 'a =3D "caml_sys_exit" + +let name n =3D + fst (Test.tests.(int_of_string n - 1)) +let run n =3D + snd (Test.tests.(int_of_string n - 1)) () + +let orig_random =3D Random.get_state () + +let () =3D + (* Random.set_state orig_random; *) + reset_instrumentation true; + begin + match Sys.argv with + | [| _; "len" |] -> print_int (Array.length Test.tests); print_newline= (); flush stdout + | [| _; "name"; n |] -> print_string (name n); flush stdout + | [| _; "1"; n |] -> run n + | [| _; "2"; n |] -> run n; (* Random.set_state orig_random; *)reset_= instrumentation false; run n + | _ -> failwith "error" + end; + sys_exit 0 diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/test/test.ml b/tool= s/ocaml/duniverse/ocaml-afl-persistent/test/test.ml new file mode 100644 index 0000000000..83c1fc00fe --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/test/test.ml @@ -0,0 +1,73 @@ +let opaque =3D Sys.opaque_identity + +let lists n =3D + let l =3D opaque [n; n; n] in + match List.rev l with + | [a; b; c] when a =3D n && b =3D n && c =3D n -> () + | _ -> assert false + +let fresh_exception x =3D + opaque @@ + let module M =3D struct + exception E of int + let throw () =3D raise (E x) + end in + try + M.throw () + with + M.E n -> assert (n =3D x) + +let obj_with_closure x =3D + opaque (object method foo =3D x end) + +let r =3D ref 42 +let state () =3D + incr r; + if !r > 43 then print_string "woo" else () + +let classes (x : int) =3D + opaque @@ + let module M =3D struct + class a =3D object + method foo =3D x + end + class c =3D object + inherit a + end + end in + let o =3D new M.c in + assert (o#foo =3D x) + + +class c_global =3D object + method foo =3D 42 +end +let obj_ordering () =3D opaque @@ + (* Object IDs change, but should be in the same relative order *) + let a =3D new c_global in + let b =3D new c_global in + if a < b then print_string "a" else print_string "b" + +let random () =3D opaque @@ + (* as long as there's no self_init, this should be deterministic *) + if Random.int 100 < 50 then print_string "a" else print_string "b"; + if Random.int 100 < 50 then print_string "a" else print_string "b"; + if Random.int 100 < 50 then print_string "a" else print_string "b"; + if Random.int 100 < 50 then print_string "a" else print_string "b"; + if Random.int 100 < 50 then print_string "a" else print_string "b"; + if Random.int 100 < 50 then print_string "a" else print_string "b"; + if Random.int 100 < 50 then print_string "a" else print_string "b"; + if Random.int 100 < 50 then print_string "a" else print_string "b"; + if Random.int 100 < 50 then print_string "a" else print_string "b" + +let tests =3D + [| ("lists", fun () -> lists 42); + ("manylists", fun () -> for i =3D 1 to 10 do lists 42 done); + ("exceptions", fun () -> fresh_exception 100); + ("objects", fun () -> ignore (obj_with_closure 42)); + (* ("state", state); *) (* this one should fail *) + ("classes", fun () -> classes 42); + ("obj_ordering", obj_ordering); + (* ("random", random); *) + |] + =20 diff --git a/tools/ocaml/duniverse/ocaml-afl-persistent/test/test.sh b/tool= s/ocaml/duniverse/ocaml-afl-persistent/test/test.sh new file mode 100755 index 0000000000..32044dffa7 --- /dev/null +++ b/tools/ocaml/duniverse/ocaml-afl-persistent/test/test.sh @@ -0,0 +1,33 @@ +#!/bin/bash + +set -e + +ocamlopt -c -afl-instrument test.ml +ocamlopt -afl-inst-ratio 0 test.cmx harness.ml -o test + +NTESTS=3D`./test len` +failures=3D'' +echo "running $NTESTS tests..." +for t in `seq 1 $NTESTS`; do + printf "%14s: " `./test name $t` + # when run twice, the instrumentation output should double + afl-showmap -q -o output-1 -- ./test 1 $t + afl-showmap -q -o output-2 -- ./test 2 $t + # see afl-showmap.c for what the numbers mean + cat output-1 | sed ' + s/:6/:7/; s/:5/:6/; + s/:4/:5/; s/:3/:4/; + s/:2/:4/; s/:1/:2/; + ' > output-2-predicted + if cmp -s output-2-predicted output-2; then + echo "passed." + else + echo "failed:" + paste output-2 output-1 + failures=3D1 + fi +done + +if [ -z "$failures" ]; then echo "all tests passed"; fi + +rm -f {test,harness}.{cmi,cmx,o} test output-{1,2,2-predicted} diff --git a/tools/ocaml/duniverse/ocplib-endian/.gitignore b/tools/ocaml/d= universe/ocplib-endian/.gitignore new file mode 100644 index 0000000000..f06221ceba --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/.gitignore @@ -0,0 +1,3 @@ +_build/ +.merlin +*.install diff --git a/tools/ocaml/duniverse/ocplib-endian/.travis.yml b/tools/ocaml/= duniverse/ocplib-endian/.travis.yml new file mode 100644 index 0000000000..0e2ae0b572 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/.travis.yml @@ -0,0 +1,19 @@ +language: c +sudo: required +install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/mas= ter/.travis-opam.sh +script: bash -ex .travis-opam.sh +global: + - PACKAGE=3Docplib-endian + - TESTS=3Dtrue +env: + - OCAML_VERSION=3D4.09 + - OCAML_VERSION=3D4.08 + - OCAML_VERSION=3D4.07 + - OCAML_VERSION=3D4.06 + - OCAML_VERSION=3D4.05 + - OCAML_VERSION=3D4.04 + - OCAML_VERSION=3D4.03 + - OCAML_VERSION=3D4.02 +os: + - linux + - osx diff --git a/tools/ocaml/duniverse/ocplib-endian/CHANGES.md b/tools/ocaml/d= universe/ocplib-endian/CHANGES.md new file mode 100644 index 0000000000..bedaa36b83 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/CHANGES.md @@ -0,0 +1,55 @@ +1.1 +--- + +* Add the OPAM support for building the documentation +* Use the correct bytes_set primitive for OCaml >=3D 4.07.0 + (issue #21 fixed in #22 @hhugo) +* Fix tests on big endian architectures + (issue #20 reported by @TC01 and @olafhering) +* Fix documentation typo (@bobot) +* Change cppo to a build dependency (@TheLortex) +* Port to Dune from jbuilder (@avsm) +* Upgrade opam metadata to 2.0 format (@avsm) +* Remove code for OCaml <4.01 support, as the minimum + supported version is now OCaml 4.02+ (@avsm) +* Build with jbuilder (unreleased, superseded by dune) + +1.0 +--------------- + +* Install generated .mli files +* Build documentation +* Fix README links + +0.8 +--------------- + +* Replace optcomp with cppo, removing hard dependency on camlp4. + +0.7 +--------------- + +* Fix dependencies. + +0.6 +--------------- + +* Port to OCaml 4.02 -safe-string: Add an EndianBytes module. +* Add unoptimized get_float, get_double, set_float and set_double to every= modules. +* Add a native endian version of interfaces. + +0.5 +--------------- + +* Fix to avoid problems with integers outside of the range [0; 255] with s= et_int8. +* Add travis CI files. + +0.4 +--------------- + +* Fix ocamlfind dependency on optcomp + +0.3 +--------------- + +First release. diff --git a/tools/ocaml/duniverse/ocplib-endian/COPYING.txt b/tools/ocaml/= duniverse/ocplib-endian/COPYING.txt new file mode 100644 index 0000000000..55831aa883 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/COPYING.txt @@ -0,0 +1,521 @@ + +As a special exception to the GNU Library General Public License, you may = link, +statically or dynamically, a "work that uses the Library" with a publicly +distributed version of the Library to produce an executable file containing +portions of the Library, and distribute that executable file under terms of +your choice, without any of the additional requirements listed in clause 6= of +the GNU Library General Public License. By "a publicly distributed versio= n of +the Library", we mean either the unmodified Library as distributed by upst= ream +author, or a modified version of the Library that is distributed under the +conditions defined in clause 3 of the GNU Library General Public License. = This +exception does not however invalidate any other reasons why the executable= file +might be covered by the GNU Library General Public License. + +----------------------------------------------------------------------- + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations +below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. +^L + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it +becomes a de-facto standard. To achieve this, non-free programs must +be allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. +^L + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control +compilation and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. +=0C + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. +^L + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. +^L + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at least + three years, to give the same user the materials specified in + Subsection 6a, above, for a charge no more than the cost of + performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. +^L + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. +^L + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply, and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License +may add an explicit geographical distribution limitation excluding those +countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. +^L + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS +^L + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms +of the ordinary General Public License). + + To apply these terms, attach the following notices to the library. +It is safest to attach them to the start of each source file to most +effectively convey the exclusion of warranty; and each file should +have at least the "copyright" line and a pointer to where the full +notice is found. + + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 U= SA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or +your school, if any, to sign a "copyright disclaimer" for the library, +if necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James + Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/tools/ocaml/duniverse/ocplib-endian/Makefile b/tools/ocaml/dun= iverse/ocplib-endian/Makefile new file mode 100644 index 0000000000..63fb0da7f0 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/Makefile @@ -0,0 +1,13 @@ +.PHONY: all clean test doc + +all: + dune build + +clean: + dune clean + +test: + dune runtest --profile=3Drelease + +doc: + dune build @doc diff --git a/tools/ocaml/duniverse/ocplib-endian/README.md b/tools/ocaml/du= niverse/ocplib-endian/README.md new file mode 100644 index 0000000000..095959be94 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/README.md @@ -0,0 +1,16 @@ +ocplib-endian +=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D + +Optimised functions to read and write int16/32/64 from strings, bytes +and bigarrays, based on primitives added in version 4.01. + +The library implements three modules: +- [EndianString](src/endianString.cppo.mli) works directly on strings, and= provides submodules BigEndian and LittleEndian, with their unsafe counter-= parts; +- [EndianBytes](src/endianBytes.cppo.mli) works directly on bytes, and pro= vides submodules BigEndian and LittleEndian, with their unsafe counter-part= s; +- [EndianBigstring](src/endianBigstring.cppo.mli) works on bigstrings (Big= arrays of chars), and provides submodules BigEndian and LittleEndian, with = their unsafe counter-parts; + + +=3D Hacking =3D + +The tests only pass in dune release profile. The debug mode prevents +cross module inlining, which prevents unboxing in the tests. \ No newline at end of file diff --git a/tools/ocaml/duniverse/ocplib-endian/dune-project b/tools/ocaml= /duniverse/ocplib-endian/dune-project new file mode 100644 index 0000000000..ae33d72195 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.0) +(name ocplib-endian) diff --git a/tools/ocaml/duniverse/ocplib-endian/ocplib-endian.opam b/tools= /ocaml/duniverse/ocplib-endian/ocplib-endian.opam new file mode 100644 index 0000000000..642829c51b --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/ocplib-endian.opam @@ -0,0 +1,30 @@ +opam-version: "2.0" +name: "ocplib-endian" +synopsis: "Optimised functions to read and write int16/32/64 from strings = and bigarrays" +description: """ +The library implements three modules: +* [EndianString](https://github.com/OCamlPro/ocplib-endian/blob/master/src= /endianString.mli) works directly on strings, and provides submodules BigEn= dian and LittleEndian, with their unsafe counter-parts; +* [EndianBytes](https://github.com/OCamlPro/ocplib-endian/blob/master/src/= endianBytes.mli) works directly on bytes, and provides submodules BigEndian= and LittleEndian, with their unsafe counter-parts; +* [EndianBigstring](https://github.com/OCamlPro/ocplib-endian/blob/master/= src/endianBigstring.mli) works on bigstrings (Bigarrays of chars), and prov= ides submodules BigEndian and LittleEndian, with their unsafe counter-parts. +""" +maintainer: "pierre.chambart@ocamlpro.com" +authors: "Pierre Chambart" +homepage: "https://github.com/OCamlPro/ocplib-endian" +bug-reports: "https://github.com/OCamlPro/ocplib-endian/issues" +doc: "https://ocamlpro.github.io/ocplib-endian/ocplib-endian/" +depends: [ + "base-bytes" + "ocaml" {>=3D "4.02.3"} + "cppo" {>=3D "1.1.0" & build} + "dune" {build & >=3D "1.0"} +] +build: [ + ["dune" "build" "-p" name "-j" jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc}] +] +dev-repo: "git+https://github.com/OCamlPro/ocplib-endian.git" +url { + src: "https://github.com/OCamlPro/ocplib-endian/archive/1.1.tar.gz" +} diff --git a/tools/ocaml/duniverse/ocplib-endian/src/be_ocaml_401.ml b/tool= s/ocaml/duniverse/ocplib-endian/src/be_ocaml_401.ml new file mode 100644 index 0000000000..38de28c1ca --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/be_ocaml_401.ml @@ -0,0 +1,32 @@ + let get_uint16 s off =3D + if not Sys.big_endian + then swap16 (get_16 s off) + else get_16 s off + + let get_int16 s off =3D + ((get_uint16 s off) lsl ( Sys.word_size - 17 )) asr ( Sys.word_size - 1= 7 ) + + let get_int32 s off =3D + if not Sys.big_endian + then swap32 (get_32 s off) + else get_32 s off + + let get_int64 s off =3D + if not Sys.big_endian + then swap64 (get_64 s off) + else get_64 s off + + let set_int16 s off v =3D + if not Sys.big_endian + then (set_16 s off (swap16 v)) + else set_16 s off v + + let set_int32 s off v =3D + if not Sys.big_endian + then set_32 s off (swap32 v) + else set_32 s off v + + let set_int64 s off v =3D + if not Sys.big_endian + then set_64 s off (swap64 v) + else set_64 s off v diff --git a/tools/ocaml/duniverse/ocplib-endian/src/common.ml b/tools/ocam= l/duniverse/ocplib-endian/src/common.ml new file mode 100644 index 0000000000..54df23effa --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/common.ml @@ -0,0 +1,24 @@ +[@@@warning "-32"] + +let sign8 v =3D + (v lsl ( Sys.word_size - 9 )) asr ( Sys.word_size - 9 ) + +let sign16 v =3D + (v lsl ( Sys.word_size - 17 )) asr ( Sys.word_size - 17 ) + +let get_uint8 s off =3D + Char.code (get_char s off) +let get_int8 s off =3D + ((get_uint8 s off) lsl ( Sys.word_size - 9 )) asr ( Sys.word_size - 9 ) +let set_int8 s off v =3D + (* It is ok to cast using unsafe_chr because both String.set + and Bigarray.Array1.set (on bigstrings) use the 'store unsigned int8' + primitives that effectively extract the bits before writing *) + set_char s off (Char.unsafe_chr v) + +let unsafe_get_uint8 s off =3D + Char.code (unsafe_get_char s off) +let unsafe_get_int8 s off =3D + ((unsafe_get_uint8 s off) lsl ( Sys.word_size - 9 )) asr ( Sys.word_size= - 9 ) +let unsafe_set_int8 s off v =3D + unsafe_set_char s off (Char.unsafe_chr v) diff --git a/tools/ocaml/duniverse/ocplib-endian/src/common_401.cppo.ml b/t= ools/ocaml/duniverse/ocplib-endian/src/common_401.cppo.ml new file mode 100644 index 0000000000..eba9509bd4 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/common_401.cppo.ml @@ -0,0 +1,100 @@ +external swap16 : int -> int =3D "%bswap16" +external swap32 : int32 -> int32 =3D "%bswap_int32" +external swap64 : int64 -> int64 =3D "%bswap_int64" +external swapnative : nativeint -> nativeint =3D "%bswap_native" + +module BigEndian =3D struct + + let get_char =3D get_char + let get_uint8 =3D get_uint8 + let get_int8 =3D get_int8 + let set_char =3D set_char + let set_int8 =3D set_int8 + +#include "be_ocaml_401.ml" +#include "common_float.ml" + +end + +module BigEndian_unsafe =3D struct + + let get_char =3D unsafe_get_char + let get_uint8 =3D unsafe_get_uint8 + let get_int8 =3D unsafe_get_int8 + let set_char =3D unsafe_set_char + let set_int8 =3D unsafe_set_int8 + let get_16 =3D unsafe_get_16 + let get_32 =3D unsafe_get_32 + let get_64 =3D unsafe_get_64 + let set_16 =3D unsafe_set_16 + let set_32 =3D unsafe_set_32 + let set_64 =3D unsafe_set_64 + +#include "be_ocaml_401.ml" +#include "common_float.ml" + +end + +module LittleEndian =3D struct + + let get_char =3D get_char + let get_uint8 =3D get_uint8 + let get_int8 =3D get_int8 + let set_char =3D set_char + let set_int8 =3D set_int8 + +#include "le_ocaml_401.ml" +#include "common_float.ml" + +end + +module LittleEndian_unsafe =3D struct + + let get_char =3D unsafe_get_char + let get_uint8 =3D unsafe_get_uint8 + let get_int8 =3D unsafe_get_int8 + let set_char =3D unsafe_set_char + let set_int8 =3D unsafe_set_int8 + let get_16 =3D unsafe_get_16 + let get_32 =3D unsafe_get_32 + let get_64 =3D unsafe_get_64 + let set_16 =3D unsafe_set_16 + let set_32 =3D unsafe_set_32 + let set_64 =3D unsafe_set_64 + +#include "le_ocaml_401.ml" +#include "common_float.ml" + +end + +module NativeEndian =3D struct + + let get_char =3D get_char + let get_uint8 =3D get_uint8 + let get_int8 =3D get_int8 + let set_char =3D set_char + let set_int8 =3D set_int8 + +#include "ne_ocaml_401.ml" +#include "common_float.ml" + +end + +module NativeEndian_unsafe =3D struct + + let get_char =3D unsafe_get_char + let get_uint8 =3D unsafe_get_uint8 + let get_int8 =3D unsafe_get_int8 + let set_char =3D unsafe_set_char + let set_int8 =3D unsafe_set_int8 + let get_16 =3D unsafe_get_16 + let get_32 =3D unsafe_get_32 + let get_64 =3D unsafe_get_64 + let set_16 =3D unsafe_set_16 + let set_32 =3D unsafe_set_32 + let set_64 =3D unsafe_set_64 + +#include "ne_ocaml_401.ml" +#include "common_float.ml" + +end diff --git a/tools/ocaml/duniverse/ocplib-endian/src/common_float.ml b/tool= s/ocaml/duniverse/ocplib-endian/src/common_float.ml new file mode 100644 index 0000000000..3d28d2da1f --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/common_float.ml @@ -0,0 +1,5 @@ + +let get_float buff i =3D Int32.float_of_bits (get_int32 buff i) +let get_double buff i =3D Int64.float_of_bits (get_int64 buff i) +let set_float buff i v =3D set_int32 buff i (Int32.bits_of_float v) +let set_double buff i v =3D set_int64 buff i (Int64.bits_of_float v) diff --git a/tools/ocaml/duniverse/ocplib-endian/src/dune b/tools/ocaml/dun= iverse/ocplib-endian/src/dune new file mode 100644 index 0000000000..a5b90d1107 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/dune @@ -0,0 +1,75 @@ +(rule + (targets endianString.mli) + (deps (:< endianString.cppo.mli)) + (action + (run %{bin:cppo} %{<} -o %{targets}))) + +(rule + (targets endianString.ml) + (deps + (:< endianString.cppo.ml) + common.ml + common_401.ml) + (action + (run %{bin:cppo} -V OCAML:%{ocaml_version} %{<} -o %{targets}))) + +(rule + (targets endianBytes.mli) + (deps + (:< endianBytes.cppo.mli)) + (action + (run %{bin:cppo} %{<} -o %{targets}))) + +(rule + (targets endianBytes.ml) + (deps + (:< endianBytes.cppo.ml) + common.ml + common_401.ml) + (action + (run %{bin:cppo} -V OCAML:%{ocaml_version} %{<} -o %{targets}))) + +(rule + (targets endianBigstring.mli) + (deps + (:< endianBigstring.cppo.mli)) + (action + (run %{bin:cppo} %{<} -o %{targets}))) + +(rule + (targets endianBigstring.ml) + (deps + (:< endianBigstring.cppo.ml) + common.ml + common_401.ml) + (action + (run %{bin:cppo} %{<} -o %{targets}))) + +(rule + (targets common_401.ml) + (deps + (:< common_401.cppo.ml) + be_ocaml_401.ml + le_ocaml_401.ml + ne_ocaml_401.ml + common_float.ml) + (action + (run %{bin:cppo} %{<} -o %{targets}))) + +(library + (name ocplib_endian) + (public_name ocplib-endian) + (synopsis "Optimised functions to read and write int16/32/64 from strings= and bytes") + (wrapped false) + (ocamlopt_flags (:standard -inline 1000)) + (modules endianString endianBytes) + (libraries bytes)) + +(library + (name ocplib_endian_bigstring) + (public_name ocplib-endian.bigstring) + (synopsis "Optimised functions to read and write int16/32/64 from bigarra= ys") + (wrapped false) + (modules endianBigstring) + (ocamlopt_flags (:standard -inline 1000)) + (libraries ocplib_endian bigarray bytes)) diff --git a/tools/ocaml/duniverse/ocplib-endian/src/endianBigstring.cppo.m= l b/tools/ocaml/duniverse/ocplib-endian/src/endianBigstring.cppo.ml new file mode 100644 index 0000000000..b7a6abae79 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/endianBigstring.cppo.ml @@ -0,0 +1,112 @@ +(************************************************************************) +(* ocplib-endian *) +(* *) +(* Copyright 2012 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-endian is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +open Bigarray + +type bigstring =3D (char, int8_unsigned_elt, c_layout) Array1.t + +module type EndianBigstringSig =3D sig + (** Functions reading according to Big Endian byte order *) + + val get_char : bigstring -> int -> char + (** [get_char buff i] reads 1 byte at offset i as a char *) + + val get_uint8 : bigstring -> int -> int + (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8 + bits. i.e. It returns a value between 0 and 2^8-1 *) + + val get_int8 : bigstring -> int -> int + (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8 + bits. i.e. It returns a value between -2^7 and 2^7-1 *) + + val get_uint16 : bigstring -> int -> int + (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int + of 16 bits. i.e. It returns a value between 0 and 2^16-1 *) + + val get_int16 : bigstring -> int -> int + (** [get_int16 buff i] reads 2 byte at offset i as a signed int of + 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *) + + val get_int32 : bigstring -> int -> int32 + (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *) + + val get_int64 : bigstring -> int -> int64 + (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *) + + val get_float : bigstring -> int -> float + (** [get_float buff i] is equivalent to + [Int32.float_of_bits (get_int32 buff i)] *) + + val get_double : bigstring -> int -> float + (** [get_double buff i] is equivalent to + [Int64.float_of_bits (get_int64 buff i)] *) + + val set_char : bigstring -> int -> char -> unit + (** [set_char buff i v] writes [v] to [buff] at offset [i] *) + + val set_int8 : bigstring -> int -> int -> unit + (** [set_int8 buff i v] writes the least significant 8 bits of [v] + to [buff] at offset [i] *) + + val set_int16 : bigstring -> int -> int -> unit + (** [set_int16 buff i v] writes the least significant 16 bits of [v] + to [buff] at offset [i] *) + + val set_int32 : bigstring -> int -> int32 -> unit + (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *) + + val set_int64 : bigstring -> int -> int64 -> unit + (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *) + + val set_float : bigstring -> int -> float -> unit + (** [set_float buff i v] is equivalent to + [set_int32 buff i (Int32.bits_of_float v)] *) + + val set_double : bigstring -> int -> float -> unit + (** [set_double buff i v] is equivalent to + [set_int64 buff i (Int64.bits_of_float v)] *) + +end + +let get_char (s:bigstring) off =3D + Array1.get s off +let set_char (s:bigstring) off v =3D + Array1.set s off v +let unsafe_get_char (s:bigstring) off =3D + Array1.unsafe_get s off +let unsafe_set_char (s:bigstring) off v =3D + Array1.unsafe_set s off v + +#include "common.ml" + +external unsafe_get_16 : bigstring -> int -> int =3D "%caml_bigstring_get1= 6u" +external unsafe_get_32 : bigstring -> int -> int32 =3D "%caml_bigstring_ge= t32u" +external unsafe_get_64 : bigstring -> int -> int64 =3D "%caml_bigstring_ge= t64u" + +external unsafe_set_16 : bigstring -> int -> int -> unit =3D "%caml_bigstr= ing_set16u" +external unsafe_set_32 : bigstring -> int -> int32 -> unit =3D "%caml_bigs= tring_set32u" +external unsafe_set_64 : bigstring -> int -> int64 -> unit =3D "%caml_bigs= tring_set64u" + +external get_16 : bigstring -> int -> int =3D "%caml_bigstring_get16" +external get_32 : bigstring -> int -> int32 =3D "%caml_bigstring_get32" +external get_64 : bigstring -> int -> int64 =3D "%caml_bigstring_get64" + +external set_16 : bigstring -> int -> int -> unit =3D "%caml_bigstring_set= 16" +external set_32 : bigstring -> int -> int32 -> unit =3D "%caml_bigstring_s= et32" +external set_64 : bigstring -> int -> int64 -> unit =3D "%caml_bigstring_s= et64" + +#include "common_401.ml" diff --git a/tools/ocaml/duniverse/ocplib-endian/src/endianBigstring.cppo.m= li b/tools/ocaml/duniverse/ocplib-endian/src/endianBigstring.cppo.mli new file mode 100644 index 0000000000..73f51abfe3 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/endianBigstring.cppo.mli @@ -0,0 +1,128 @@ +(************************************************************************) +(* ocplib-endian *) +(* *) +(* Copyright 2012 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-endian is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +open Bigarray +type bigstring =3D (char, int8_unsigned_elt, c_layout) Array1.t + +module type EndianBigstringSig =3D sig + (** Functions reading according to Big Endian byte order *) + + val get_char : bigstring -> int -> char + (** [get_char buff i] reads 1 byte at offset i as a char *) + + val get_uint8 : bigstring -> int -> int + (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8 + bits. i.e. It returns a value between 0 and 2^8-1 *) + + val get_int8 : bigstring -> int -> int + (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8 + bits. i.e. It returns a value between -2^7 and 2^7-1 *) + + val get_uint16 : bigstring -> int -> int + (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int + of 16 bits. i.e. It returns a value between 0 and 2^16-1 *) + + val get_int16 : bigstring -> int -> int + (** [get_int16 buff i] reads 2 byte at offset i as a signed int of + 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *) + + val get_int32 : bigstring -> int -> int32 + (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *) + + val get_int64 : bigstring -> int -> int64 + (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *) + + val get_float : bigstring -> int -> float + (** [get_float buff i] is equivalent to + [Int32.float_of_bits (get_int32 buff i)] *) + + val get_double : bigstring -> int -> float + (** [get_double buff i] is equivalent to + [Int64.float_of_bits (get_int64 buff i)] *) + + val set_char : bigstring -> int -> char -> unit + (** [set_char buff i v] writes [v] to [buff] at offset [i] *) + + val set_int8 : bigstring -> int -> int -> unit + (** [set_int8 buff i v] writes the least significant 8 bits of [v] + to [buff] at offset [i] *) + + val set_int16 : bigstring -> int -> int -> unit + (** [set_int16 buff i v] writes the least significant 16 bits of [v] + to [buff] at offset [i] *) + + val set_int32 : bigstring -> int -> int32 -> unit + (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *) + + val set_int64 : bigstring -> int -> int64 -> unit + (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *) + + val set_float : bigstring -> int -> float -> unit + (** [set_float buff i v] is equivalent to + [set_int32 buff i (Int32.bits_of_float v)] *) + + val set_double : bigstring -> int -> float -> unit + (** [set_double buff i v] is equivalent to + [set_int64 buff i (Int64.bits_of_float v)] *) + +end + +module BigEndian : sig + (** Functions reading according to Big Endian byte order without + checking for overflow *) + + include EndianBigstringSig + +end + +module BigEndian_unsafe : sig + (** Functions reading according to Big Endian byte order without + checking for overflow *) + + include EndianBigstringSig + +end + +module LittleEndian : sig + (** Functions reading according to Little Endian byte order *) + + include EndianBigstringSig + +end + +module LittleEndian_unsafe : sig + (** Functions reading according to Big Endian byte order without + checking for overflow *) + + include EndianBigstringSig + +end + +module NativeEndian : sig + (** Functions reading according to machine endianness *) + + include EndianBigstringSig + +end + +module NativeEndian_unsafe : sig + (** Functions reading according to machine endianness without + checking for overflow *) + + include EndianBigstringSig + +end diff --git a/tools/ocaml/duniverse/ocplib-endian/src/endianBytes.cppo.ml b/= tools/ocaml/duniverse/ocplib-endian/src/endianBytes.cppo.ml new file mode 100644 index 0000000000..419f06316a --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/endianBytes.cppo.ml @@ -0,0 +1,130 @@ +(************************************************************************) +(* ocplib-endian *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-endian is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +module type EndianBytesSig =3D sig + (** Functions reading according to Big Endian byte order *) + + val get_char : Bytes.t -> int -> char + (** [get_char buff i] reads 1 byte at offset i as a char *) + + val get_uint8 : Bytes.t -> int -> int + (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8 + bits. i.e. It returns a value between 0 and 2^8-1 *) + + val get_int8 : Bytes.t -> int -> int + (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8 + bits. i.e. It returns a value between -2^7 and 2^7-1 *) + + val get_uint16 : Bytes.t -> int -> int + (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int + of 16 bits. i.e. It returns a value between 0 and 2^16-1 *) + + val get_int16 : Bytes.t -> int -> int + (** [get_int16 buff i] reads 2 byte at offset i as a signed int of + 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *) + + val get_int32 : Bytes.t -> int -> int32 + (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *) + + val get_int64 : Bytes.t -> int -> int64 + (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *) + + val get_float : Bytes.t -> int -> float + (** [get_float buff i] is equivalent to + [Int32.float_of_bits (get_int32 buff i)] *) + + val get_double : Bytes.t -> int -> float + (** [get_double buff i] is equivalent to + [Int64.float_of_bits (get_int64 buff i)] *) + + val set_char : Bytes.t -> int -> char -> unit + (** [set_char buff i v] writes [v] to [buff] at offset [i] *) + + val set_int8 : Bytes.t -> int -> int -> unit + (** [set_int8 buff i v] writes the least significant 8 bits of [v] + to [buff] at offset [i] *) + + val set_int16 : Bytes.t -> int -> int -> unit + (** [set_int16 buff i v] writes the least significant 16 bits of [v] + to [buff] at offset [i] *) + + val set_int32 : Bytes.t -> int -> int32 -> unit + (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *) + + val set_int64 : Bytes.t -> int -> int64 -> unit + (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *) + + val set_float : Bytes.t -> int -> float -> unit + (** [set_float buff i v] is equivalent to + [set_int32 buff i (Int32.bits_of_float v)] *) + + val set_double : Bytes.t -> int -> float -> unit + (** [set_double buff i v] is equivalent to + [set_int64 buff i (Int64.bits_of_float v)] *) + +end + +let get_char (s:Bytes.t) off =3D + Bytes.get s off +let set_char (s:Bytes.t) off v =3D + Bytes.set s off v +let unsafe_get_char (s:Bytes.t) off =3D + Bytes.unsafe_get s off +let unsafe_set_char (s:Bytes.t) off v =3D + Bytes.unsafe_set s off v + +#include "common.ml" + +#if OCAML_VERSION < (4, 07, 0) + +external unsafe_get_16 : Bytes.t -> int -> int =3D "%caml_string_get16u" +external unsafe_get_32 : Bytes.t -> int -> int32 =3D "%caml_string_get32u" +external unsafe_get_64 : Bytes.t -> int -> int64 =3D "%caml_string_get64u" + +external unsafe_set_16 : Bytes.t -> int -> int -> unit =3D "%caml_string_s= et16u" +external unsafe_set_32 : Bytes.t -> int -> int32 -> unit =3D "%caml_string= _set32u" +external unsafe_set_64 : Bytes.t -> int -> int64 -> unit =3D "%caml_string= _set64u" + +external get_16 : Bytes.t -> int -> int =3D "%caml_string_get16" +external get_32 : Bytes.t -> int -> int32 =3D "%caml_string_get32" +external get_64 : Bytes.t -> int -> int64 =3D "%caml_string_get64" + +external set_16 : Bytes.t -> int -> int -> unit =3D "%caml_string_set16" +external set_32 : Bytes.t -> int -> int32 -> unit =3D "%caml_string_set32" +external set_64 : Bytes.t -> int -> int64 -> unit =3D "%caml_string_set64" + +#else + +external unsafe_get_16 : Bytes.t -> int -> int =3D "%caml_bytes_get16u" +external unsafe_get_32 : Bytes.t -> int -> int32 =3D "%caml_bytes_get32u" +external unsafe_get_64 : Bytes.t -> int -> int64 =3D "%caml_bytes_get64u" + +external unsafe_set_16 : Bytes.t -> int -> int -> unit =3D "%caml_bytes_se= t16u" +external unsafe_set_32 : Bytes.t -> int -> int32 -> unit =3D "%caml_bytes_= set32u" +external unsafe_set_64 : Bytes.t -> int -> int64 -> unit =3D "%caml_bytes_= set64u" + +external get_16 : Bytes.t -> int -> int =3D "%caml_bytes_get16" +external get_32 : Bytes.t -> int -> int32 =3D "%caml_bytes_get32" +external get_64 : Bytes.t -> int -> int64 =3D "%caml_bytes_get64" + +external set_16 : Bytes.t -> int -> int -> unit =3D "%caml_bytes_set16" +external set_32 : Bytes.t -> int -> int32 -> unit =3D "%caml_bytes_set32" +external set_64 : Bytes.t -> int -> int64 -> unit =3D "%caml_bytes_set64" + +#endif + +#include "common_401.ml" diff --git a/tools/ocaml/duniverse/ocplib-endian/src/endianBytes.cppo.mli b= /tools/ocaml/duniverse/ocplib-endian/src/endianBytes.cppo.mli new file mode 100644 index 0000000000..25abbb1961 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/endianBytes.cppo.mli @@ -0,0 +1,124 @@ +(************************************************************************) +(* ocplib-endian *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-endian is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +module type EndianBytesSig =3D sig + (** Functions reading according to Big Endian byte order *) + + val get_char : Bytes.t -> int -> char + (** [get_char buff i] reads 1 byte at offset i as a char *) + + val get_uint8 : Bytes.t -> int -> int + (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8 + bits. i.e. It returns a value between 0 and 2^8-1 *) + + val get_int8 : Bytes.t -> int -> int + (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8 + bits. i.e. It returns a value between -2^7 and 2^7-1 *) + + val get_uint16 : Bytes.t -> int -> int + (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int + of 16 bits. i.e. It returns a value between 0 and 2^16-1 *) + + val get_int16 : Bytes.t -> int -> int + (** [get_int16 buff i] reads 2 byte at offset i as a signed int of + 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *) + + val get_int32 : Bytes.t -> int -> int32 + (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *) + + val get_int64 : Bytes.t -> int -> int64 + (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *) + + val get_float : Bytes.t -> int -> float + (** [get_float buff i] is equivalent to + [Int32.float_of_bits (get_int32 buff i)] *) + + val get_double : Bytes.t -> int -> float + (** [get_double buff i] is equivalent to + [Int64.float_of_bits (get_int64 buff i)] *) + + val set_char : Bytes.t -> int -> char -> unit + (** [set_char buff i v] writes [v] to [buff] at offset [i] *) + + val set_int8 : Bytes.t -> int -> int -> unit + (** [set_int8 buff i v] writes the least significant 8 bits of [v] + to [buff] at offset [i] *) + + val set_int16 : Bytes.t -> int -> int -> unit + (** [set_int16 buff i v] writes the least significant 16 bits of [v] + to [buff] at offset [i] *) + + val set_int32 : Bytes.t -> int -> int32 -> unit + (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *) + + val set_int64 : Bytes.t -> int -> int64 -> unit + (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *) + + val set_float : Bytes.t -> int -> float -> unit + (** [set_float buff i v] is equivalent to + [set_int32 buff i (Int32.bits_of_float v)] *) + + val set_double : Bytes.t -> int -> float -> unit + (** [set_double buff i v] is equivalent to + [set_int64 buff i (Int64.bits_of_float v)] *) + +end + +module BigEndian : sig + (** Functions reading according to Big Endian byte order *) + + include EndianBytesSig + +end + +module BigEndian_unsafe : sig + (** Functions reading according to Big Endian byte order without + checking for overflow *) + + include EndianBytesSig + +end + +module LittleEndian : sig + (** Functions reading according to Little Endian byte order *) + + include EndianBytesSig + +end + +module LittleEndian_unsafe : sig + (** Functions reading according to Big Endian byte order without + checking for overflow *) + + include EndianBytesSig + +end + +module NativeEndian : sig + (** Functions reading according to machine endianness *) + + include EndianBytesSig + +end + +module NativeEndian_unsafe : sig + (** Functions reading according to machine endianness without + checking for overflow *) + + include EndianBytesSig + +end diff --git a/tools/ocaml/duniverse/ocplib-endian/src/endianString.cppo.ml b= /tools/ocaml/duniverse/ocplib-endian/src/endianString.cppo.ml new file mode 100644 index 0000000000..df8ccd4072 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/endianString.cppo.ml @@ -0,0 +1,118 @@ +(************************************************************************) +(* ocplib-endian *) +(* *) +(* Copyright 2012 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-endian is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +module type EndianStringSig =3D sig + (** Functions reading according to Big Endian byte order *) + + val get_char : string -> int -> char + (** [get_char buff i] reads 1 byte at offset i as a char *) + + val get_uint8 : string -> int -> int + (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8 + bits. i.e. It returns a value between 0 and 2^8-1 *) + + val get_int8 : string -> int -> int + (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8 + bits. i.e. It returns a value between -2^7 and 2^7-1 *) + + val get_uint16 : string -> int -> int + (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int + of 16 bits. i.e. It returns a value between 0 and 2^16-1 *) + + val get_int16 : string -> int -> int + (** [get_int16 buff i] reads 2 byte at offset i as a signed int of + 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *) + + val get_int32 : string -> int -> int32 + (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *) + + val get_int64 : string -> int -> int64 + (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *) + + val get_float : string -> int -> float + (** [get_float buff i] is equivalent to + [Int32.float_of_bits (get_int32 buff i)] *) + + val get_double : string -> int -> float + (** [get_double buff i] is equivalent to + [Int64.float_of_bits (get_int64 buff i)] *) + + val set_char : Bytes.t -> int -> char -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_char}. *) + + val set_int8 : Bytes.t -> int -> int -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_int8}. *) + + val set_int16 : Bytes.t -> int -> int -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_int16}. = *) + + val set_int32 : Bytes.t -> int -> int32 -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_int32}. = *) + + val set_int64 : Bytes.t -> int -> int64 -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_int64}. = *) + + val set_float : Bytes.t -> int -> float -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_float}. = *) + + val set_double : Bytes.t -> int -> float -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_double}.= *) + +end + +let get_char (s:string) off =3D + String.get s off +let set_char (s:Bytes.t) off v =3D + Bytes.set s off v +let unsafe_get_char (s:string) off =3D + String.unsafe_get s off +let unsafe_set_char (s:Bytes.t) off v =3D + Bytes.unsafe_set s off v + +#include "common.ml" + +external unsafe_get_16 : string -> int -> int =3D "%caml_string_get16u" +external unsafe_get_32 : string -> int -> int32 =3D "%caml_string_get32u" +external unsafe_get_64 : string -> int -> int64 =3D "%caml_string_get64u" + +external get_16 : string -> int -> int =3D "%caml_string_get16" +external get_32 : string -> int -> int32 =3D "%caml_string_get32" +external get_64 : string -> int -> int64 =3D "%caml_string_get64" + +#if OCAML_VERSION < (4, 07, 0) + +external unsafe_set_16 : Bytes.t -> int -> int -> unit =3D "%caml_string_s= et16u" +external unsafe_set_32 : Bytes.t -> int -> int32 -> unit =3D "%caml_string= _set32u" +external unsafe_set_64 : Bytes.t -> int -> int64 -> unit =3D "%caml_string= _set64u" + +external set_16 : Bytes.t -> int -> int -> unit =3D "%caml_string_set16" +external set_32 : Bytes.t -> int -> int32 -> unit =3D "%caml_string_set32" +external set_64 : Bytes.t -> int -> int64 -> unit =3D "%caml_string_set64" + +#else + +external unsafe_set_16 : Bytes.t -> int -> int -> unit =3D "%caml_bytes_se= t16u" +external unsafe_set_32 : Bytes.t -> int -> int32 -> unit =3D "%caml_bytes_= set32u" +external unsafe_set_64 : Bytes.t -> int -> int64 -> unit =3D "%caml_bytes_= set64u" + +external set_16 : Bytes.t -> int -> int -> unit =3D "%caml_bytes_set16" +external set_32 : Bytes.t -> int -> int32 -> unit =3D "%caml_bytes_set32" +external set_64 : Bytes.t -> int -> int64 -> unit =3D "%caml_bytes_set64" + +#endif + +#include "common_401.ml" diff --git a/tools/ocaml/duniverse/ocplib-endian/src/endianString.cppo.mli = b/tools/ocaml/duniverse/ocplib-endian/src/endianString.cppo.mli new file mode 100644 index 0000000000..2b703d6d6b --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/endianString.cppo.mli @@ -0,0 +1,121 @@ +(************************************************************************) +(* ocplib-endian *) +(* *) +(* Copyright 2012 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-endian is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +module type EndianStringSig =3D sig + (** Functions reading according to Big Endian byte order *) + + val get_char : string -> int -> char + (** [get_char buff i] reads 1 byte at offset i as a char *) + + val get_uint8 : string -> int -> int + (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8 + bits. i.e. It returns a value between 0 and 2^8-1 *) + + val get_int8 : string -> int -> int + (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8 + bits. i.e. It returns a value between -2^7 and 2^7-1 *) + + val get_uint16 : string -> int -> int + (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int + of 16 bits. i.e. It returns a value between 0 and 2^16-1 *) + + val get_int16 : string -> int -> int + (** [get_int16 buff i] reads 2 byte at offset i as a signed int of + 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *) + + val get_int32 : string -> int -> int32 + (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *) + + val get_int64 : string -> int -> int64 + (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *) + + val get_float : string -> int -> float + (** [get_float buff i] is equivalent to + [Int32.float_of_bits (get_int32 buff i)] *) + + val get_double : string -> int -> float + (** [get_double buff i] is equivalent to + [Int64.float_of_bits (get_int64 buff i)] *) + + val set_char : Bytes.t -> int -> char -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_char}. *) + + val set_int8 : Bytes.t -> int -> int -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_int8}. *) + + val set_int16 : Bytes.t -> int -> int -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_int16}. = *) + + val set_int32 : Bytes.t -> int -> int32 -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_int32}. = *) + + val set_int64 : Bytes.t -> int -> int64 -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_int64}. = *) + + val set_float : Bytes.t -> int -> float -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_float}. = *) + + val set_double : Bytes.t -> int -> float -> unit + (** @deprecated This is a deprecated alias of {!endianBytes.set_double}.= *) + +end + +module BigEndian : sig + (** Functions reading according to Big Endian byte order without + checking for overflow *) + + include EndianStringSig + +end + +module BigEndian_unsafe : sig + (** Functions reading according to Big Endian byte order without + checking for overflow *) + + include EndianStringSig + +end + +module LittleEndian : sig + (** Functions reading according to Little Endian byte order *) + + include EndianStringSig + +end + +module LittleEndian_unsafe : sig + (** Functions reading according to Big Endian byte order without + checking for overflow *) + + include EndianStringSig + +end + +module NativeEndian : sig + (** Functions reading according to machine endianness *) + + include EndianStringSig + +end + +module NativeEndian_unsafe : sig + (** Functions reading according to machine endianness without + checking for overflow *) + + include EndianStringSig + +end diff --git a/tools/ocaml/duniverse/ocplib-endian/src/le_ocaml_401.ml b/tool= s/ocaml/duniverse/ocplib-endian/src/le_ocaml_401.ml new file mode 100644 index 0000000000..b65184ca8d --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/le_ocaml_401.ml @@ -0,0 +1,32 @@ + let get_uint16 s off =3D + if Sys.big_endian + then swap16 (get_16 s off) + else get_16 s off + + let get_int16 s off =3D + ((get_uint16 s off) lsl ( Sys.word_size - 17 )) asr ( Sys.word_size - 1= 7 ) + + let get_int32 s off =3D + if Sys.big_endian + then swap32 (get_32 s off) + else get_32 s off + + let get_int64 s off =3D + if Sys.big_endian + then swap64 (get_64 s off) + else get_64 s off + + let set_int16 s off v =3D + if Sys.big_endian + then (set_16 s off (swap16 v)) + else set_16 s off v + + let set_int32 s off v =3D + if Sys.big_endian + then set_32 s off (swap32 v) + else set_32 s off v + + let set_int64 s off v =3D + if Sys.big_endian + then set_64 s off (swap64 v) + else set_64 s off v diff --git a/tools/ocaml/duniverse/ocplib-endian/src/ne_ocaml_401.ml b/tool= s/ocaml/duniverse/ocplib-endian/src/ne_ocaml_401.ml new file mode 100644 index 0000000000..2348135809 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/src/ne_ocaml_401.ml @@ -0,0 +1,20 @@ + let get_uint16 s off =3D + get_16 s off + + let get_int16 s off =3D + ((get_uint16 s off) lsl ( Sys.word_size - 17 )) asr ( Sys.word_size - 1= 7 ) + + let get_int32 s off =3D + get_32 s off + + let get_int64 s off =3D + get_64 s off + + let set_int16 s off v =3D + set_16 s off v + + let set_int32 s off v =3D + set_32 s off v + + let set_int64 s off v =3D + set_64 s off v diff --git a/tools/ocaml/duniverse/ocplib-endian/tests/bench.ml b/tools/oca= ml/duniverse/ocplib-endian/tests/bench.ml new file mode 100644 index 0000000000..8b0c88d192 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/tests/bench.ml @@ -0,0 +1,436 @@ + +let buffer_size =3D 10000 +let loops =3D 10000 + +let allocdiff =3D + let stat1 =3D Gc.quick_stat () in + let stat2 =3D Gc.quick_stat () in + (stat2.Gc.minor_words -. stat1.Gc.minor_words) + +let test_fun s f =3D + let t1 =3D Unix.gettimeofday () in + let stat1 =3D Gc.quick_stat () in + f (); + let stat2 =3D Gc.quick_stat () in + let t2 =3D Unix.gettimeofday () in + Printf.printf "%s: time %f alloc: %f\n%!" s (t2 -. t1) + (stat2.Gc.minor_words -. stat1.Gc.minor_words -. allocdiff) + +module Bytes_test =3D struct + open EndianBytes + module BE =3D BigEndian + module LE =3D LittleEndian + + let buffer =3D Bytes.create buffer_size + + let loop_read_uint16_be () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(BE.get_uint16 buffer i) + done + + let loop_read_uint16_le () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(LE.get_uint16 buffer i) + done + + let loop_read_int16_be () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(BE.get_int16 buffer i) + done + + let loop_read_int16_le () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(LE.get_int16 buffer i) + done + + let loop_read_int32_be () =3D + for i =3D 0 to Bytes.length buffer - 4 do + ignore(Int32.to_int (BE.get_int32 buffer i)) + done + + let loop_read_int32_le () =3D + for i =3D 0 to Bytes.length buffer - 4 do + ignore(Int32.to_int (LE.get_int32 buffer i)) + done + + let loop_read_int64_be () =3D + for i =3D 0 to Bytes.length buffer - 8 do + ignore(Int64.to_int (BE.get_int64 buffer i)) + done + + let loop_read_int64_le () =3D + for i =3D 0 to Bytes.length buffer - 8 do + ignore(Int64.to_int (LE.get_int64 buffer i)) + done + + let loop_write_int16_be () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(BE.set_int16 buffer i 10) + done + + let loop_write_int16_le () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(LE.set_int16 buffer i 10) + done + + let loop_write_int32_be () =3D + for i =3D 0 to Bytes.length buffer - 4 do + ignore((BE.set_int32 buffer i) 10l) + done + + let loop_write_int32_le () =3D + for i =3D 0 to Bytes.length buffer - 4 do + ignore((LE.set_int32 buffer i) 10l) + done + + let loop_write_int64_be () =3D + for i =3D 0 to Bytes.length buffer - 8 do + ignore((BE.set_int64 buffer i) 10L) + done + + let loop_write_int64_le () =3D + for i =3D 0 to Bytes.length buffer - 8 do + ignore((LE.set_int64 buffer i) 10L) + done + + let do_loop f () =3D + for i =3D 0 to loops - 1 do + f () + done + + let run s f =3D test_fun s (do_loop f) + + let run_test () =3D + run "loop_read_uint16_be" loop_read_uint16_be; + run "loop_read_uint16_le" loop_read_uint16_le; + run "loop_read_int16_be" loop_read_int16_be; + run "loop_read_int16_le" loop_read_int16_le; + run "loop_read_int32_be" loop_read_int32_be; + run "loop_read_int32_le" loop_read_int32_le; + run "loop_read_int64_be" loop_read_int64_be; + run "loop_read_int64_le" loop_read_int64_le; + run "loop_write_int16_be" loop_write_int16_be; + run "loop_write_int16_le" loop_write_int16_le; + run "loop_write_int32_be" loop_write_int32_be; + run "loop_write_int32_le" loop_write_int32_le; + run "loop_write_int64_be" loop_write_int64_be; + run "loop_write_int64_le" loop_write_int64_le + +end + +module Bytes_unsafe_test =3D struct + open EndianBytes + module BE =3D BigEndian_unsafe + module LE =3D LittleEndian_unsafe + + let buffer =3D Bytes.create buffer_size + + let loop_read_uint16_be () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(BE.get_uint16 buffer i) + done + + let loop_read_uint16_le () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(LE.get_uint16 buffer i) + done + + let loop_read_int16_be () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(BE.get_int16 buffer i) + done + + let loop_read_int16_le () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(LE.get_int16 buffer i) + done + + let loop_read_int32_be () =3D + for i =3D 0 to Bytes.length buffer - 4 do + ignore(Int32.to_int (BE.get_int32 buffer i)) + done + + let loop_read_int32_le () =3D + for i =3D 0 to Bytes.length buffer - 4 do + ignore(Int32.to_int (LE.get_int32 buffer i)) + done + + let loop_read_int64_be () =3D + for i =3D 0 to Bytes.length buffer - 8 do + ignore(Int64.to_int (BE.get_int64 buffer i)) + done + + let loop_read_int64_le () =3D + for i =3D 0 to Bytes.length buffer - 8 do + ignore(Int64.to_int (LE.get_int64 buffer i)) + done + + let loop_write_int16_be () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(BE.set_int16 buffer i 10) + done + + let loop_write_int16_le () =3D + for i =3D 0 to Bytes.length buffer - 2 do + ignore(LE.set_int16 buffer i 10) + done + + let loop_write_int32_be () =3D + for i =3D 0 to Bytes.length buffer - 4 do + ignore((BE.set_int32 buffer i) 10l) + done + + let loop_write_int32_le () =3D + for i =3D 0 to Bytes.length buffer - 4 do + ignore((LE.set_int32 buffer i) 10l) + done + + let loop_write_int64_be () =3D + for i =3D 0 to Bytes.length buffer - 8 do + ignore((BE.set_int64 buffer i) 10L) + done + + let loop_write_int64_le () =3D + for i =3D 0 to Bytes.length buffer - 8 do + ignore((LE.set_int64 buffer i) 10L) + + done + + let do_loop f () =3D + for i =3D 0 to loops - 1 do + f () + done + + let run s f =3D test_fun s (do_loop f) + + let run_test () =3D + run "loop_read_uint16_be" loop_read_uint16_be; + run "loop_read_uint16_le" loop_read_uint16_le; + run "loop_read_int16_be" loop_read_int16_be; + run "loop_read_int16_le" loop_read_int16_le; + run "loop_read_int32_be" loop_read_int32_be; + run "loop_read_int32_le" loop_read_int32_le; + run "loop_read_int64_be" loop_read_int64_be; + run "loop_read_int64_le" loop_read_int64_le; + run "loop_write_int16_be" loop_write_int16_be; + run "loop_write_int16_le" loop_write_int16_le; + run "loop_write_int32_be" loop_write_int32_be; + run "loop_write_int32_le" loop_write_int32_le; + run "loop_write_int64_be" loop_write_int64_be; + run "loop_write_int64_le" loop_write_int64_le + +end + +module Bigstring_test =3D struct + open EndianBigstring + module BE =3D BigEndian + module LE =3D LittleEndian + open Bigarray + let buffer =3D Array1.create char c_layout buffer_size + + let loop_read_uint16_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(BE.get_uint16 buffer i) + done + + let loop_read_uint16_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(LE.get_uint16 buffer i) + done + + let loop_read_int16_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(BE.get_int16 buffer i) + done + + let loop_read_int16_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(LE.get_int16 buffer i) + done + + let loop_read_int32_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 4 do + ignore(Int32.to_int (BE.get_int32 buffer i)) + done + + let loop_read_int32_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 4 do + ignore(Int32.to_int (LE.get_int32 buffer i)) + done + + let loop_read_int64_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 8 do + ignore(Int64.to_int (BE.get_int64 buffer i)) + done + + let loop_read_int64_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 8 do + ignore(Int64.to_int (LE.get_int64 buffer i)) + done + + let loop_write_int16_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(BE.set_int16 buffer i 10) + done + + let loop_write_int16_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(LE.set_int16 buffer i 10) + done + + let loop_write_int32_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 4 do + ignore((BE.set_int32 buffer i) 10l) + done + + let loop_write_int32_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 4 do + ignore((LE.set_int32 buffer i) 10l) + done + + let loop_write_int64_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 8 do + ignore((BE.set_int64 buffer i) 10L) + done + + let loop_write_int64_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 8 do + ignore((LE.set_int64 buffer i) 10L) + done + + let do_loop f () =3D + for i =3D 0 to loops - 1 do + f () + done + + let run s f =3D test_fun s (do_loop f) + + let run_test () =3D + run "loop_read_uint16_be" loop_read_uint16_be; + run "loop_read_uint16_le" loop_read_uint16_le; + run "loop_read_int16_be" loop_read_int16_be; + run "loop_read_int16_le" loop_read_int16_le; + run "loop_read_int32_be" loop_read_int32_be; + run "loop_read_int32_le" loop_read_int32_le; + run "loop_read_int64_be" loop_read_int64_be; + run "loop_read_int64_le" loop_read_int64_le; + run "loop_write_int16_be" loop_write_int16_be; + run "loop_write_int16_le" loop_write_int16_le; + run "loop_write_int32_be" loop_write_int32_be; + run "loop_write_int32_le" loop_write_int32_le; + run "loop_write_int64_be" loop_write_int64_be; + run "loop_write_int64_le" loop_write_int64_le + +end + +module Bigstring_unsafe_test =3D struct + open EndianBigstring + module BE =3D BigEndian_unsafe + module LE =3D LittleEndian_unsafe + open Bigarray + let buffer =3D Array1.create char c_layout buffer_size + + let loop_read_uint16_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(BE.get_uint16 buffer i) + done + + let loop_read_uint16_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(LE.get_uint16 buffer i) + done + + let loop_read_int16_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(BE.get_int16 buffer i) + done + + let loop_read_int16_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(LE.get_int16 buffer i) + done + + let loop_read_int32_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 4 do + ignore(Int32.to_int (BE.get_int32 buffer i)) + done + + let loop_read_int32_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 4 do + ignore(Int32.to_int (LE.get_int32 buffer i)) + done + + let loop_read_int64_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 8 do + ignore(Int64.to_int (BE.get_int64 buffer i)) + done + + let loop_read_int64_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 8 do + ignore(Int64.to_int (LE.get_int64 buffer i)) + done + + let loop_write_int16_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(BE.set_int16 buffer i 10) + done + + let loop_write_int16_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 2 do + ignore(LE.set_int16 buffer i 10) + done + + let loop_write_int32_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 4 do + ignore((BE.set_int32 buffer i) 10l) + done + + let loop_write_int32_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 4 do + ignore((LE.set_int32 buffer i) 10l) + done + + let loop_write_int64_be () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 8 do + ignore((BE.set_int64 buffer i) 10L) + done + + let loop_write_int64_le () =3D + for i =3D 0 to Bigarray.Array1.dim buffer - 8 do + ignore((LE.set_int64 buffer i) 10L) + done + + let do_loop f () =3D + for i =3D 0 to loops - 1 do + f () + done + + let run s f =3D test_fun s (do_loop f) + + let run_test () =3D + run "loop_read_uint16_be" loop_read_uint16_be; + run "loop_read_uint16_le" loop_read_uint16_le; + run "loop_read_int16_be" loop_read_int16_be; + run "loop_read_int16_le" loop_read_int16_le; + run "loop_read_int32_be" loop_read_int32_be; + run "loop_read_int32_le" loop_read_int32_le; + run "loop_read_int64_be" loop_read_int64_be; + run "loop_read_int64_le" loop_read_int64_le; + run "loop_write_int16_be" loop_write_int16_be; + run "loop_write_int16_le" loop_write_int16_le; + run "loop_write_int32_be" loop_write_int32_be; + run "loop_write_int32_le" loop_write_int32_le; + run "loop_write_int64_be" loop_write_int64_be; + run "loop_write_int64_le" loop_write_int64_le + +end + +let () =3D + Printf.printf "safe bytes:\n%!"; + Bytes_test.run_test (); + Printf.printf "unsafe bytes:\n%!"; + Bytes_unsafe_test.run_test (); + Printf.printf "safe bigstring:\n%!"; + Bigstring_test.run_test (); + Printf.printf "unsafe bigstring:\n%!"; + Bigstring_unsafe_test.run_test () diff --git a/tools/ocaml/duniverse/ocplib-endian/tests/dune b/tools/ocaml/d= universe/ocplib-endian/tests/dune new file mode 100644 index 0000000000..e3e0f17940 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/tests/dune @@ -0,0 +1,35 @@ +(rule + (targets test_string.ml) + (deps (:< test_string.cppo.ml)) + (action (run %{bin:cppo} %{<} -o %{targets}))) + +(rule + (targets test_bytes.ml) + (deps (:< test_bytes.cppo.ml)) + (action (run %{bin:cppo} %{<} -o %{targets}))) + +(rule + (targets test_bigstring.ml) + (deps (:< test_bigstring.cppo.ml)) + (action (run %{bin:cppo} %{<} -o %{targets}))) + +(library + (name tests) + (wrapped false) + (modules test_string test_bytes test_bigstring) + (libraries ocplib-endian ocplib-endian.bigstring bigarray bytes)) + +(executables + (names test) + (modules test) + (libraries ocplib-endian tests)) + +(executables + (names bench) + (modules bench) + (libraries ocplib-endian ocplib-endian.bigstring)) + +(alias + (name runtest) + (deps (:< test.exe)) + (action (run %{<}))) diff --git a/tools/ocaml/duniverse/ocplib-endian/tests/test.ml b/tools/ocam= l/duniverse/ocplib-endian/tests/test.ml new file mode 100644 index 0000000000..387fcc16b3 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/tests/test.ml @@ -0,0 +1,39 @@ + +let allocdiff =3D + let stat1 =3D Gc.quick_stat () in + let stat2 =3D Gc.quick_stat () in + (stat2.Gc.minor_words -. stat1.Gc.minor_words) + +let () =3D + Test_bigstring.test1 (); + let stat1 =3D Gc.quick_stat () in + Test_bigstring.test2 (); + if Sys.word_size =3D 64 then Test_bigstring.test_64 (); + let stat2 =3D Gc.quick_stat () in + (* with a 32 bit system, int64 must be heap allocated *) + if Sys.word_size =3D 32 then Test_bigstring.test_64 (); + let alloc1 =3D stat2.Gc.minor_words -. stat1.Gc.minor_words -. allocdiff= in + Printf.printf "bigstring: allocated words %f\n%!" alloc1; + + Test_string.test1 (); + let stat1 =3D Gc.quick_stat () in + Test_string.test2 (); + if Sys.word_size =3D 64 then Test_string.test_64 (); + let stat2 =3D Gc.quick_stat () in + if Sys.word_size =3D 32 then Test_string.test_64 (); + let alloc2 =3D stat2.Gc.minor_words -. stat1.Gc.minor_words -. allocdiff= in + Printf.printf "string: allocated words %f\n%!" alloc2; + + Test_bytes.test1 (); + let stat1 =3D Gc.quick_stat () in + Test_bytes.test2 (); + if Sys.word_size =3D 64 then Test_bytes.test_64 (); + let stat2 =3D Gc.quick_stat () in + if Sys.word_size =3D 32 then Test_bytes.test_64 (); + let alloc3 =3D stat2.Gc.minor_words -. stat1.Gc.minor_words -. allocdiff= in + Printf.printf "bytes: allocated words %f\n%!" alloc3; + (* we cannot ensure that there are no allocations only with the + primives added in 4.01.0 *) + if (alloc1 <> 0. || alloc2 <> 0. || alloc3 <> 0.) + then exit 1 + else exit 0 diff --git a/tools/ocaml/duniverse/ocplib-endian/tests/test_bigstring.cppo.= ml b/tools/ocaml/duniverse/ocplib-endian/tests/test_bigstring.cppo.ml new file mode 100644 index 0000000000..35d926b52c --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/tests/test_bigstring.cppo.ml @@ -0,0 +1,191 @@ +open Bigarray +open EndianBigstring + +[@@@warning "-52-53"] + +module BE =3D BigEndian +module LE =3D LittleEndian +module NE =3D NativeEndian + +let big_endian =3D Sys.big_endian + +let bigstring_of_string s =3D + let a =3D Array1.create char c_layout (String.length s) in + for i =3D 0 to String.length s - 1 do + a.{i} <- s.[i] + done; + a + +let s =3D bigstring_of_string (String.make 10 '\x00') + +let assert_bound_check2 f v1 v2 =3D + try + ignore(f v1 v2); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let assert_bound_check3 f v1 v2 v3 =3D + try + ignore(f v1 v2 v3); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let test1 () =3D + assert_bound_check2 BE.get_int8 s (-1); + assert_bound_check2 BE.get_int8 s 10; + assert_bound_check2 BE.get_uint16 s (-1); + assert_bound_check2 BE.get_uint16 s 9; + assert_bound_check2 BE.get_int32 s (-1); + assert_bound_check2 BE.get_int32 s 7; + assert_bound_check2 BE.get_int64 s (-1); + assert_bound_check2 BE.get_int64 s 3; + + assert_bound_check3 BE.set_int8 s (-1) 0; + assert_bound_check3 BE.set_int8 s 10 0; + assert_bound_check3 BE.set_int16 s (-1) 0; + assert_bound_check3 BE.set_int16 s 9 0; + assert_bound_check3 BE.set_int32 s (-1) 0l; + assert_bound_check3 BE.set_int32 s 7 0l; + assert_bound_check3 BE.set_int64 s (-1) 0L; + assert_bound_check3 BE.set_int64 s 3 0L + +let test2 () =3D + BE.set_int8 s 0 63; (* in [0; 127] *) + assert( BE.get_uint8 s 0 =3D 63 ); + assert( BE.get_int8 s 0 =3D 63 ); + + BE.set_int8 s 0 155; (* in [128; 255] *) + assert( BE.get_uint8 s 0 =3D 155 ); + + BE.set_int8 s 0 (-103); (* in [-128; -1] *) + assert( BE.get_int8 s 0 =3D (-103) ); + + BE.set_int8 s 0 0x1234; (* outside of the [-127;255] range *) + assert( BE.get_uint8 s 0 =3D 0x34 ); + assert( BE.get_int8 s 0 =3D 0x34 ); + + BE.set_int8 s 0 0xAACD; (* outside of the [-127;255] range, -0x33 land 0= xFF =3D 0xCD*) + assert( BE.get_uint8 s 0 =3D 0xCD ); + assert( BE.get_int8 s 0 =3D (-0x33) ); + + BE.set_int16 s 0 0x1234; + assert( BE.get_uint16 s 0 =3D 0x1234 ); + assert( BE.get_uint16 s 1 =3D 0x3400 ); + assert( BE.get_uint16 s 2 =3D 0 ); + + assert( LE.get_uint16 s 0 =3D 0x3412 ); + assert( LE.get_uint16 s 1 =3D 0x0034 ); + assert( LE.get_uint16 s 2 =3D 0 ); + + if big_endian then begin + assert( BE.get_uint16 s 0 =3D NE.get_uint16 s 0 ); + assert( BE.get_uint16 s 1 =3D NE.get_uint16 s 1 ); + assert( BE.get_uint16 s 2 =3D NE.get_uint16 s 2 ); + end + else begin + assert( LE.get_uint16 s 0 =3D NE.get_uint16 s 0 ); + assert( LE.get_uint16 s 1 =3D NE.get_uint16 s 1 ); + assert( LE.get_uint16 s 2 =3D NE.get_uint16 s 2 ); + end; + + assert( BE.get_int16 s 0 =3D 0x1234 ); + assert( BE.get_int16 s 1 =3D 0x3400 ); + assert( BE.get_int16 s 2 =3D 0 ); + + BE.set_int16 s 0 0xFEDC; + assert( BE.get_uint16 s 0 =3D 0xFEDC ); + assert( BE.get_uint16 s 1 =3D 0xDC00 ); + assert( BE.get_uint16 s 2 =3D 0 ); + + assert( LE.get_uint16 s 0 =3D 0xDCFE ); + assert( LE.get_uint16 s 1 =3D 0x00DC ); + assert( LE.get_uint16 s 2 =3D 0 ); + + if big_endian then begin + assert( BE.get_uint16 s 0 =3D NE.get_uint16 s 0 ); + assert( BE.get_uint16 s 1 =3D NE.get_uint16 s 1 ); + assert( BE.get_uint16 s 2 =3D NE.get_uint16 s 2 ); + end + else begin + assert( LE.get_uint16 s 0 =3D NE.get_uint16 s 0 ); + assert( LE.get_uint16 s 1 =3D NE.get_uint16 s 1 ); + assert( LE.get_uint16 s 2 =3D NE.get_uint16 s 2 ); + end; + + assert( BE.get_int16 s 0 =3D -292 ); + assert( BE.get_int16 s 1 =3D -9216 ); + assert( BE.get_int16 s 2 =3D 0 ); + + if big_endian + then begin + NE.set_int16 s 0 0x1234; + assert( BE.get_uint16 s 0 =3D 0x1234 ); + assert( BE.get_uint16 s 1 =3D 0x3400 ); + assert( BE.get_uint16 s 2 =3D 0 ) + end; + + LE.set_int16 s 0 0x1234; + assert( BE.get_uint16 s 0 =3D 0x3412 ); + assert( BE.get_uint16 s 1 =3D 0x1200 ); + assert( BE.get_uint16 s 2 =3D 0 ); + + if not big_endian + then begin + NE.set_int16 s 0 0x1234; + assert( BE.get_uint16 s 0 =3D 0x3412 ); + assert( BE.get_uint16 s 1 =3D 0x1200 ); + assert( BE.get_uint16 s 2 =3D 0 ) + end; + + LE.set_int16 s 0 0xFEDC; + assert( LE.get_uint16 s 0 =3D 0xFEDC ); + assert( LE.get_uint16 s 1 =3D 0x00FE ); + assert( LE.get_uint16 s 2 =3D 0 ); + + BE.set_int32 s 0 0x12345678l; + assert( BE.get_int32 s 0 =3D 0x12345678l ); + assert( LE.get_int32 s 0 =3D 0x78563412l ); + if big_endian + then assert( BE.get_int32 s 0 =3D NE.get_int32 s 0 ) + else assert( LE.get_int32 s 0 =3D NE.get_int32 s 0 ); + + LE.set_int32 s 0 0x12345678l; + assert( LE.get_int32 s 0 =3D 0x12345678l ); + assert( BE.get_int32 s 0 =3D 0x78563412l ); + + if big_endian + then assert( BE.get_int32 s 0 =3D NE.get_int32 s 0 ) + else assert( LE.get_int32 s 0 =3D NE.get_int32 s 0 ); + + NE.set_int32 s 0 0x12345678l; + if big_endian + then assert( BE.get_int32 s 0 =3D 0x12345678l ) + else assert( LE.get_int32 s 0 =3D 0x12345678l ); + + () + +let test_64 () =3D + BE.set_int64 s 0 0x1234567890ABCDEFL; + assert( BE.get_int64 s 0 =3D 0x1234567890ABCDEFL ); + assert( LE.get_int64 s 0 =3D 0xEFCDAB9078563412L ); + + if big_endian + then assert( BE.get_int64 s 0 =3D NE.get_int64 s 0 ) + else assert( LE.get_int64 s 0 =3D NE.get_int64 s 0 ); + + LE.set_int64 s 0 0x1234567890ABCDEFL; + assert( LE.get_int64 s 0 =3D 0x1234567890ABCDEFL ); + assert( BE.get_int64 s 0 =3D 0xEFCDAB9078563412L ); + + if big_endian + then assert( BE.get_int64 s 0 =3D NE.get_int64 s 0 ) + else assert( LE.get_int64 s 0 =3D NE.get_int64 s 0 ); + + NE.set_int64 s 0 0x1234567890ABCDEFL; + if big_endian + then assert( BE.get_int64 s 0 =3D 0x1234567890ABCDEFL ) + else assert( LE.get_int64 s 0 =3D 0x1234567890ABCDEFL ); + + () diff --git a/tools/ocaml/duniverse/ocplib-endian/tests/test_bytes.cppo.ml b= /tools/ocaml/duniverse/ocplib-endian/tests/test_bytes.cppo.ml new file mode 100644 index 0000000000..f51b9523d2 --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/tests/test_bytes.cppo.ml @@ -0,0 +1,185 @@ +open EndianBytes +[@@@warning "-52"] + +let to_t x =3D x +(* do not allocate to avoid breaking tests *) + +module BE =3D BigEndian +module LE =3D LittleEndian +module NE =3D NativeEndian + +let big_endian =3D Sys.big_endian + +let s =3D Bytes.make 10 '\x00' + +let assert_bound_check2 f v1 v2 =3D + try + ignore(f v1 v2); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let assert_bound_check3 f v1 v2 v3 =3D + try + ignore(f v1 v2 v3); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let test1 () =3D + assert_bound_check2 BE.get_int8 (to_t s) (-1); + assert_bound_check2 BE.get_int8 (to_t s) 10; + assert_bound_check2 BE.get_uint16 (to_t s) (-1); + assert_bound_check2 BE.get_uint16 (to_t s) 9; + assert_bound_check2 BE.get_int32 (to_t s) (-1); + assert_bound_check2 BE.get_int32 (to_t s) 7; + assert_bound_check2 BE.get_int64 (to_t s) (-1); + assert_bound_check2 BE.get_int64 (to_t s) 3; + + assert_bound_check3 BE.set_int8 s (-1) 0; + assert_bound_check3 BE.set_int8 s 10 0; + assert_bound_check3 BE.set_int16 s (-1) 0; + assert_bound_check3 BE.set_int16 s 9 0; + assert_bound_check3 BE.set_int32 s (-1) 0l; + assert_bound_check3 BE.set_int32 s 7 0l; + assert_bound_check3 BE.set_int64 s (-1) 0L; + assert_bound_check3 BE.set_int64 s 3 0L + +let test2 () =3D + BE.set_int8 s 0 63; (* in [0; 127] *) + assert( BE.get_uint8 (to_t s) 0 =3D 63 ); + assert( BE.get_int8 (to_t s) 0 =3D 63 ); + + BE.set_int8 s 0 155; (* in [128; 255] *) + assert( BE.get_uint8 (to_t s) 0 =3D 155 ); + + BE.set_int8 s 0 (-103); (* in [-128; -1] *) + assert( BE.get_int8 (to_t s) 0 =3D (-103) ); + + BE.set_int8 s 0 0x1234; (* outside of the [-127;255] range *) + assert( BE.get_uint8 (to_t s) 0 =3D 0x34 ); + assert( BE.get_int8 (to_t s) 0 =3D 0x34 ); + + BE.set_int8 s 0 0xAACD; (* outside of the [-127;255] range, -0x33 land 0= xFF =3D 0xCD*) + assert( BE.get_uint8 (to_t s) 0 =3D 0xCD ); + assert( BE.get_int8 (to_t s) 0 =3D (-0x33) ); + + BE.set_int16 s 0 0x1234; + assert( BE.get_uint16 (to_t s) 0 =3D 0x1234 ); + assert( BE.get_uint16 (to_t s) 1 =3D 0x3400 ); + assert( BE.get_uint16 (to_t s) 2 =3D 0 ); + + assert( LE.get_uint16 (to_t s) 0 =3D 0x3412 ); + assert( LE.get_uint16 (to_t s) 1 =3D 0x0034 ); + assert( LE.get_uint16 (to_t s) 2 =3D 0 ); + + if big_endian then begin + assert( BE.get_uint16 (to_t s) 0 =3D NE.get_uint16 (to_t s) 0 ); + assert( BE.get_uint16 (to_t s) 1 =3D NE.get_uint16 (to_t s) 1 ); + assert( BE.get_uint16 (to_t s) 2 =3D NE.get_uint16 (to_t s) 2 ); + end + else begin + assert( LE.get_uint16 (to_t s) 0 =3D NE.get_uint16 (to_t s) 0 ); + assert( LE.get_uint16 (to_t s) 1 =3D NE.get_uint16 (to_t s) 1 ); + assert( LE.get_uint16 (to_t s) 2 =3D NE.get_uint16 (to_t s) 2 ); + end; + + assert( BE.get_int16 (to_t s) 0 =3D 0x1234 ); + assert( BE.get_int16 (to_t s) 1 =3D 0x3400 ); + assert( BE.get_int16 (to_t s) 2 =3D 0 ); + + BE.set_int16 s 0 0xFEDC; + assert( BE.get_uint16 (to_t s) 0 =3D 0xFEDC ); + assert( BE.get_uint16 (to_t s) 1 =3D 0xDC00 ); + assert( BE.get_uint16 (to_t s) 2 =3D 0 ); + + assert( LE.get_uint16 (to_t s) 0 =3D 0xDCFE ); + assert( LE.get_uint16 (to_t s) 1 =3D 0x00DC ); + assert( LE.get_uint16 (to_t s) 2 =3D 0 ); + + if big_endian then begin + assert( BE.get_uint16 (to_t s) 0 =3D NE.get_uint16 (to_t s) 0 ); + assert( BE.get_uint16 (to_t s) 1 =3D NE.get_uint16 (to_t s) 1 ); + assert( BE.get_uint16 (to_t s) 2 =3D NE.get_uint16 (to_t s) 2 ); + end + else begin + assert( LE.get_uint16 (to_t s) 0 =3D NE.get_uint16 (to_t s) 0 ); + assert( LE.get_uint16 (to_t s) 1 =3D NE.get_uint16 (to_t s) 1 ); + assert( LE.get_uint16 (to_t s) 2 =3D NE.get_uint16 (to_t s) 2 ); + end; + + assert( BE.get_int16 (to_t s) 0 =3D -292 ); + assert( BE.get_int16 (to_t s) 1 =3D -9216 ); + assert( BE.get_int16 (to_t s) 2 =3D 0 ); + + if big_endian + then begin + NE.set_int16 s 0 0x1234; + assert( BE.get_uint16 (to_t s) 0 =3D 0x1234 ); + assert( BE.get_uint16 (to_t s) 1 =3D 0x3400 ); + assert( BE.get_uint16 (to_t s) 2 =3D 0 ) + end; + + LE.set_int16 s 0 0x1234; + assert( BE.get_uint16 (to_t s) 0 =3D 0x3412 ); + assert( BE.get_uint16 (to_t s) 1 =3D 0x1200 ); + assert( BE.get_uint16 (to_t s) 2 =3D 0 ); + + if not big_endian + then begin + NE.set_int16 s 0 0x1234; + assert( BE.get_uint16 (to_t s) 0 =3D 0x3412 ); + assert( BE.get_uint16 (to_t s) 1 =3D 0x1200 ); + assert( BE.get_uint16 (to_t s) 2 =3D 0 ) + end; + + LE.set_int16 s 0 0xFEDC; + assert( LE.get_uint16 (to_t s) 0 =3D 0xFEDC ); + assert( LE.get_uint16 (to_t s) 1 =3D 0x00FE ); + assert( LE.get_uint16 (to_t s) 2 =3D 0 ); + + BE.set_int32 s 0 0x12345678l; + assert( BE.get_int32 (to_t s) 0 =3D 0x12345678l ); + assert( LE.get_int32 (to_t s) 0 =3D 0x78563412l ); + if big_endian + then assert( BE.get_int32 (to_t s) 0 =3D NE.get_int32 (to_t s) 0 ) + else assert( LE.get_int32 (to_t s) 0 =3D NE.get_int32 (to_t s) 0 ); + + LE.set_int32 s 0 0x12345678l; + assert( LE.get_int32 (to_t s) 0 =3D 0x12345678l ); + assert( BE.get_int32 (to_t s) 0 =3D 0x78563412l ); + + if big_endian + then assert( BE.get_int32 (to_t s) 0 =3D NE.get_int32 (to_t s) 0 ) + else assert( LE.get_int32 (to_t s) 0 =3D NE.get_int32 (to_t s) 0 ); + + NE.set_int32 s 0 0x12345678l; + if big_endian + then assert( BE.get_int32 (to_t s) 0 =3D 0x12345678l ) + else assert( LE.get_int32 (to_t s) 0 =3D 0x12345678l ); + + () + +let test_64 () =3D + BE.set_int64 s 0 0x1234567890ABCDEFL; + assert( BE.get_int64 (to_t s) 0 =3D 0x1234567890ABCDEFL ); + assert( LE.get_int64 (to_t s) 0 =3D 0xEFCDAB9078563412L ); + + if big_endian + then assert( BE.get_int64 (to_t s) 0 =3D NE.get_int64 (to_t s) 0 ) + else assert( LE.get_int64 (to_t s) 0 =3D NE.get_int64 (to_t s) 0 ); + + LE.set_int64 s 0 0x1234567890ABCDEFL; + assert( LE.get_int64 (to_t s) 0 =3D 0x1234567890ABCDEFL ); + assert( BE.get_int64 (to_t s) 0 =3D 0xEFCDAB9078563412L ); + + if big_endian + then assert( BE.get_int64 (to_t s) 0 =3D NE.get_int64 (to_t s) 0 ) + else assert( LE.get_int64 (to_t s) 0 =3D NE.get_int64 (to_t s) 0 ); + + NE.set_int64 s 0 0x1234567890ABCDEFL; + if big_endian + then assert( BE.get_int64 (to_t s) 0 =3D 0x1234567890ABCDEFL ) + else assert( LE.get_int64 (to_t s) 0 =3D 0x1234567890ABCDEFL ); + + () diff --git a/tools/ocaml/duniverse/ocplib-endian/tests/test_string.cppo.ml = b/tools/ocaml/duniverse/ocplib-endian/tests/test_string.cppo.ml new file mode 100644 index 0000000000..dec25216cc --- /dev/null +++ b/tools/ocaml/duniverse/ocplib-endian/tests/test_string.cppo.ml @@ -0,0 +1,185 @@ +open EndianString +[@@@warning "-52"] + +let to_t =3D Bytes.unsafe_to_string +(* do not allocate to avoid breaking tests *) + +module BE =3D BigEndian +module LE =3D LittleEndian +module NE =3D NativeEndian + +let big_endian =3D Sys.big_endian + +let s =3D Bytes.make 10 '\x00' + +let assert_bound_check2 f v1 v2 =3D + try + ignore(f v1 v2); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let assert_bound_check3 f v1 v2 v3 =3D + try + ignore(f v1 v2 v3); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let test1 () =3D + assert_bound_check2 BE.get_int8 (to_t s) (-1); + assert_bound_check2 BE.get_int8 (to_t s) 10; + assert_bound_check2 BE.get_uint16 (to_t s) (-1); + assert_bound_check2 BE.get_uint16 (to_t s) 9; + assert_bound_check2 BE.get_int32 (to_t s) (-1); + assert_bound_check2 BE.get_int32 (to_t s) 7; + assert_bound_check2 BE.get_int64 (to_t s) (-1); + assert_bound_check2 BE.get_int64 (to_t s) 3; + + assert_bound_check3 BE.set_int8 s (-1) 0; + assert_bound_check3 BE.set_int8 s 10 0; + assert_bound_check3 BE.set_int16 s (-1) 0; + assert_bound_check3 BE.set_int16 s 9 0; + assert_bound_check3 BE.set_int32 s (-1) 0l; + assert_bound_check3 BE.set_int32 s 7 0l; + assert_bound_check3 BE.set_int64 s (-1) 0L; + assert_bound_check3 BE.set_int64 s 3 0L + +let test2 () =3D + BE.set_int8 s 0 63; (* in [0; 127] *) + assert( BE.get_uint8 (to_t s) 0 =3D 63 ); + assert( BE.get_int8 (to_t s) 0 =3D 63 ); + + BE.set_int8 s 0 155; (* in [128; 255] *) + assert( BE.get_uint8 (to_t s) 0 =3D 155 ); + + BE.set_int8 s 0 (-103); (* in [-128; -1] *) + assert( BE.get_int8 (to_t s) 0 =3D (-103) ); + + BE.set_int8 s 0 0x1234; (* outside of the [-127;255] range *) + assert( BE.get_uint8 (to_t s) 0 =3D 0x34 ); + assert( BE.get_int8 (to_t s) 0 =3D 0x34 ); + + BE.set_int8 s 0 0xAACD; (* outside of the [-127;255] range, -0x33 land 0= xFF =3D 0xCD*) + assert( BE.get_uint8 (to_t s) 0 =3D 0xCD ); + assert( BE.get_int8 (to_t s) 0 =3D (-0x33) ); + + BE.set_int16 s 0 0x1234; + assert( BE.get_uint16 (to_t s) 0 =3D 0x1234 ); + assert( BE.get_uint16 (to_t s) 1 =3D 0x3400 ); + assert( BE.get_uint16 (to_t s) 2 =3D 0 ); + + assert( LE.get_uint16 (to_t s) 0 =3D 0x3412 ); + assert( LE.get_uint16 (to_t s) 1 =3D 0x0034 ); + assert( LE.get_uint16 (to_t s) 2 =3D 0 ); + + if big_endian then begin + assert( BE.get_uint16 (to_t s) 0 =3D NE.get_uint16 (to_t s) 0 ); + assert( BE.get_uint16 (to_t s) 1 =3D NE.get_uint16 (to_t s) 1 ); + assert( BE.get_uint16 (to_t s) 2 =3D NE.get_uint16 (to_t s) 2 ); + end + else begin + assert( LE.get_uint16 (to_t s) 0 =3D NE.get_uint16 (to_t s) 0 ); + assert( LE.get_uint16 (to_t s) 1 =3D NE.get_uint16 (to_t s) 1 ); + assert( LE.get_uint16 (to_t s) 2 =3D NE.get_uint16 (to_t s) 2 ); + end; + + assert( BE.get_int16 (to_t s) 0 =3D 0x1234 ); + assert( BE.get_int16 (to_t s) 1 =3D 0x3400 ); + assert( BE.get_int16 (to_t s) 2 =3D 0 ); + + BE.set_int16 s 0 0xFEDC; + assert( BE.get_uint16 (to_t s) 0 =3D 0xFEDC ); + assert( BE.get_uint16 (to_t s) 1 =3D 0xDC00 ); + assert( BE.get_uint16 (to_t s) 2 =3D 0 ); + + assert( LE.get_uint16 (to_t s) 0 =3D 0xDCFE ); + assert( LE.get_uint16 (to_t s) 1 =3D 0x00DC ); + assert( LE.get_uint16 (to_t s) 2 =3D 0 ); + + if big_endian then begin + assert( BE.get_uint16 (to_t s) 0 =3D NE.get_uint16 (to_t s) 0 ); + assert( BE.get_uint16 (to_t s) 1 =3D NE.get_uint16 (to_t s) 1 ); + assert( BE.get_uint16 (to_t s) 2 =3D NE.get_uint16 (to_t s) 2 ); + end + else begin + assert( LE.get_uint16 (to_t s) 0 =3D NE.get_uint16 (to_t s) 0 ); + assert( LE.get_uint16 (to_t s) 1 =3D NE.get_uint16 (to_t s) 1 ); + assert( LE.get_uint16 (to_t s) 2 =3D NE.get_uint16 (to_t s) 2 ); + end; + + assert( BE.get_int16 (to_t s) 0 =3D -292 ); + assert( BE.get_int16 (to_t s) 1 =3D -9216 ); + assert( BE.get_int16 (to_t s) 2 =3D 0 ); + + if big_endian + then begin + NE.set_int16 s 0 0x1234; + assert( BE.get_uint16 (to_t s) 0 =3D 0x1234 ); + assert( BE.get_uint16 (to_t s) 1 =3D 0x3400 ); + assert( BE.get_uint16 (to_t s) 2 =3D 0 ) + end; + + LE.set_int16 s 0 0x1234; + assert( BE.get_uint16 (to_t s) 0 =3D 0x3412 ); + assert( BE.get_uint16 (to_t s) 1 =3D 0x1200 ); + assert( BE.get_uint16 (to_t s) 2 =3D 0 ); + + if not big_endian + then begin + NE.set_int16 s 0 0x1234; + assert( BE.get_uint16 (to_t s) 0 =3D 0x3412 ); + assert( BE.get_uint16 (to_t s) 1 =3D 0x1200 ); + assert( BE.get_uint16 (to_t s) 2 =3D 0 ) + end; + + LE.set_int16 s 0 0xFEDC; + assert( LE.get_uint16 (to_t s) 0 =3D 0xFEDC ); + assert( LE.get_uint16 (to_t s) 1 =3D 0x00FE ); + assert( LE.get_uint16 (to_t s) 2 =3D 0 ); + + BE.set_int32 s 0 0x12345678l; + assert( BE.get_int32 (to_t s) 0 =3D 0x12345678l ); + assert( LE.get_int32 (to_t s) 0 =3D 0x78563412l ); + if big_endian + then assert( BE.get_int32 (to_t s) 0 =3D NE.get_int32 (to_t s) 0 ) + else assert( LE.get_int32 (to_t s) 0 =3D NE.get_int32 (to_t s) 0 ); + + LE.set_int32 s 0 0x12345678l; + assert( LE.get_int32 (to_t s) 0 =3D 0x12345678l ); + assert( BE.get_int32 (to_t s) 0 =3D 0x78563412l ); + + if big_endian + then assert( BE.get_int32 (to_t s) 0 =3D NE.get_int32 (to_t s) 0 ) + else assert( LE.get_int32 (to_t s) 0 =3D NE.get_int32 (to_t s) 0 ); + + NE.set_int32 s 0 0x12345678l; + if big_endian + then assert( BE.get_int32 (to_t s) 0 =3D 0x12345678l ) + else assert( LE.get_int32 (to_t s) 0 =3D 0x12345678l ); + + () + +let test_64 () =3D + BE.set_int64 s 0 0x1234567890ABCDEFL; + assert( BE.get_int64 (to_t s) 0 =3D 0x1234567890ABCDEFL ); + assert( LE.get_int64 (to_t s) 0 =3D 0xEFCDAB9078563412L ); + + if big_endian + then assert( BE.get_int64 (to_t s) 0 =3D NE.get_int64 (to_t s) 0 ) + else assert( LE.get_int64 (to_t s) 0 =3D NE.get_int64 (to_t s) 0 ); + + LE.set_int64 s 0 0x1234567890ABCDEFL; + assert( LE.get_int64 (to_t s) 0 =3D 0x1234567890ABCDEFL ); + assert( BE.get_int64 (to_t s) 0 =3D 0xEFCDAB9078563412L ); + + if big_endian + then assert( BE.get_int64 (to_t s) 0 =3D NE.get_int64 (to_t s) 0 ) + else assert( LE.get_int64 (to_t s) 0 =3D NE.get_int64 (to_t s) 0 ); + + NE.set_int64 s 0 0x1234567890ABCDEFL; + if big_endian + then assert( BE.get_int64 (to_t s) 0 =3D 0x1234567890ABCDEFL ) + else assert( LE.get_int64 (to_t s) 0 =3D 0x1234567890ABCDEFL ); + + () diff --git a/tools/ocaml/duniverse/result/CHANGES.md b/tools/ocaml/dunivers= e/result/CHANGES.md new file mode 100755 index 0000000000..fc04a554f5 --- /dev/null +++ b/tools/ocaml/duniverse/result/CHANGES.md @@ -0,0 +1,15 @@ +1.5 (17/02/2020) +---------------- + +- Make Result an alias of Stdlib.Result on OCaml >=3D 4.08. + +1.4 (27/03/2019) +---------------- + +- Switch to Dune. +- Do not refer to Pervasives; it is deprecated. + +1.3 (05/02/2018) +---------------- + +- Switch to jbuilder. diff --git a/tools/ocaml/duniverse/result/LICENSE.md b/tools/ocaml/dunivers= e/result/LICENSE.md new file mode 100755 index 0000000000..42d16a9902 --- /dev/null +++ b/tools/ocaml/duniverse/result/LICENSE.md @@ -0,0 +1,24 @@ +Copyright (c) 2015, Jane Street Group, LLC +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Jane Street Group nor the names of his + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHOR AND CONTRIBUTORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICE= S; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF T= HIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/tools/ocaml/duniverse/result/Makefile b/tools/ocaml/duniverse/= result/Makefile new file mode 100755 index 0000000000..f5dd44305e --- /dev/null +++ b/tools/ocaml/duniverse/result/Makefile @@ -0,0 +1,17 @@ +INSTALL_ARGS :=3D $(if $(PREFIX),--prefix $(PREFIX),) + +default: + dune build @install + +install: + dune install $(INSTALL_ARGS) + +uninstall: + dune uninstall $(INSTALL_ARGS) + +reinstall: uninstall reinstall + +clean: + dune clean + +.PHONY: default install uninstall reinstall clean diff --git a/tools/ocaml/duniverse/result/README.md b/tools/ocaml/duniverse= /result/README.md new file mode 100755 index 0000000000..ade131944c --- /dev/null +++ b/tools/ocaml/duniverse/result/README.md @@ -0,0 +1,5 @@ +Compatibility Result module. + +Projects that want to use the new result type defined in OCaml >=3D 4.03 +while staying compatible with older version of OCaml should use the +`Result` module defined in this library. diff --git a/tools/ocaml/duniverse/result/dune b/tools/ocaml/duniverse/resu= lt/dune new file mode 100755 index 0000000000..8b7ef9b882 --- /dev/null +++ b/tools/ocaml/duniverse/result/dune @@ -0,0 +1,12 @@ +(library + (name result) + (public_name result) + (modules result)) + +(rule + (with-stdout-to + selected + (run %{ocaml} %{dep:which_result.ml} %{ocaml_version}))) + +(rule + (copy# %{read:selected} result.ml)) diff --git a/tools/ocaml/duniverse/result/dune-project b/tools/ocaml/dunive= rse/result/dune-project new file mode 100755 index 0000000000..377a3f80cb --- /dev/null +++ b/tools/ocaml/duniverse/result/dune-project @@ -0,0 +1,3 @@ +(lang dune 1.0) +(name result) +(version 1.5) diff --git a/tools/ocaml/duniverse/result/result-as-alias-4.08.ml b/tools/o= caml/duniverse/result/result-as-alias-4.08.ml new file mode 100755 index 0000000000..a654b7438a --- /dev/null +++ b/tools/ocaml/duniverse/result/result-as-alias-4.08.ml @@ -0,0 +1,2 @@ +include Stdlib.Result +type ('a, 'b) result =3D ('a, 'b) Stdlib.Result.t =3D Ok of 'a | Error of = 'b diff --git a/tools/ocaml/duniverse/result/result-as-alias.ml b/tools/ocaml/= duniverse/result/result-as-alias.ml new file mode 100755 index 0000000000..5d695816c2 --- /dev/null +++ b/tools/ocaml/duniverse/result/result-as-alias.ml @@ -0,0 +1,2 @@ +type nonrec ('a, 'b) result =3D ('a, 'b) result =3D Ok of 'a | Error of 'b +type ('a, 'b) t =3D ('a, 'b) result diff --git a/tools/ocaml/duniverse/result/result-as-newtype.ml b/tools/ocam= l/duniverse/result/result-as-newtype.ml new file mode 100755 index 0000000000..275c663883 --- /dev/null +++ b/tools/ocaml/duniverse/result/result-as-newtype.ml @@ -0,0 +1,2 @@ +type ('a, 'b) result =3D Ok of 'a | Error of 'b +type ('a, 'b) t =3D ('a, 'b) result diff --git a/tools/ocaml/duniverse/result/result.opam b/tools/ocaml/duniver= se/result/result.opam new file mode 100755 index 0000000000..11e41c9468 --- /dev/null +++ b/tools/ocaml/duniverse/result/result.opam @@ -0,0 +1,18 @@ +version: "1.5" +opam-version: "2.0" +maintainer: "opensource@janestreet.com" +authors: ["Jane Street Group, LLC "] +homepage: "https://github.com/janestreet/result" +dev-repo: "git+https://github.com/janestreet/result.git" +bug-reports: "https://github.com/janestreet/result/issues" +license: "BSD-3-Clause" +build: [["dune" "build" "-p" name "-j" jobs]] +depends: [ + "ocaml" + "dune" {>=3D "1.0"} +] +synopsis: "Compatibility Result module" +description: """ +Projects that want to use the new result type defined in OCaml >=3D 4.03 +while staying compatible with older version of OCaml should use the +Result module defined in this library.""" \ No newline at end of file diff --git a/tools/ocaml/duniverse/result/which_result.ml b/tools/ocaml/dun= iverse/result/which_result.ml new file mode 100755 index 0000000000..7c40c21d2e --- /dev/null +++ b/tools/ocaml/duniverse/result/which_result.ml @@ -0,0 +1,14 @@ +let () =3D + let version =3D + Scanf.sscanf Sys.argv.(1) "%d.%d" (fun major minor -> (major, minor)) + in + let file =3D + if version < (4, 03) then + "result-as-newtype.ml" + else + if version < (4, 08) then + "result-as-alias.ml" + else + "result-as-alias-4.08.ml" + in + print_string file diff --git a/tools/ocaml/duniverse/stdlib-shims/CHANGES.md b/tools/ocaml/du= niverse/stdlib-shims/CHANGES.md new file mode 100644 index 0000000000..de768873cc --- /dev/null +++ b/tools/ocaml/duniverse/stdlib-shims/CHANGES.md @@ -0,0 +1,5 @@ +0.1.0 2019-02-19 London +----------------------- + +First release. In this release, only the `Stdlib` module is backported +to older version of OCaml. diff --git a/tools/ocaml/duniverse/stdlib-shims/LICENSE b/tools/ocaml/duniv= erse/stdlib-shims/LICENSE new file mode 100644 index 0000000000..3666ebe155 --- /dev/null +++ b/tools/ocaml/duniverse/stdlib-shims/LICENSE @@ -0,0 +1,203 @@ +In the following, "the OCaml Core System" refers to all files marked +"Copyright INRIA" in this distribution. + +The OCaml Core System is distributed under the terms of the +GNU Lesser General Public License (LGPL) version 2.1 (included below). + +As a special exception to the GNU Lesser General Public License, you +may link, statically or dynamically, a "work that uses the OCaml Core +System" with a publicly distributed version of the OCaml Core System +to produce an executable file containing portions of the OCaml Core +System, and distribute that executable file under terms of your +choice, without any of the additional requirements listed in clause 6 +of the GNU Lesser General Public License. By "a publicly distributed +version of the OCaml Core System", we mean either the unmodified OCaml +Core System as distributed by INRIA, or a modified version of the +OCaml Core System that is distributed under the conditions defined in +clause 2 of the GNU Lesser General Public License. This exception +does not however invalidate any other reasons why the executable file +might be covered by the GNU Lesser General Public License. + +---------------------------------------------------------------------- + +GNU LESSER GENERAL PUBLIC LICENSE + +Version 2.1, February 1999 + +Copyright (C) 1991, 1999 Free Software Foundation, Inc. +51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + +Preamble + +The licenses for most software are designed to take away your freedom to s= hare and change it. By contrast, the GNU General Public Licenses are intend= ed to guarantee your freedom to share and change free software--to make sur= e the software is free for all its users. + +This license, the Lesser General Public License, applies to some specially= designated software packages--typically libraries--of the Free Software Fo= undation and other authors who decide to use it. You can use it too, but we= suggest you first think carefully about whether this license or the ordina= ry General Public License is the better strategy to use in any particular c= ase, based on the explanations below. + +When we speak of free software, we are referring to freedom of use, not pr= ice. Our General Public Licenses are designed to make sure that you have th= e freedom to distribute copies of free software (and charge for this servic= e if you wish); that you receive source code or can get it if you want it; = that you can change the software and use pieces of it in new free programs;= and that you are informed that you can do these things. + +To protect your rights, we need to make restrictions that forbid distribut= ors to deny you these rights or to ask you to surrender these rights. These= restrictions translate to certain responsibilities for you if you distribu= te copies of the library or if you modify it. + +For example, if you distribute copies of the library, whether gratis or fo= r a fee, you must give the recipients all the rights that we gave you. You = must make sure that they, too, receive or can get the source code. If you l= ink other code with the library, you must provide complete object files to = the recipients, so that they can relink them with the library after making = changes to the library and recompiling it. And you must show them these ter= ms so they know their rights. + +We protect your rights with a two-step method: (1) we copyright the librar= y, and (2) we offer you this license, which gives you legal permission to c= opy, distribute and/or modify the library. + +To protect each distributor, we want to make it very clear that there is n= o warranty for the free library. Also, if the library is modified by someon= e else and passed on, the recipients should know that what they have is not= the original version, so that the original author's reputation will not be= affected by problems that might be introduced by others. + +Finally, software patents pose a constant threat to the existence of any f= ree program. We wish to make sure that a company cannot effectively restric= t the users of a free program by obtaining a restrictive license from a pat= ent holder. Therefore, we insist that any patent license obtained for a ver= sion of the library must be consistent with the full freedom of use specifi= ed in this license. + +Most GNU software, including some libraries, is covered by the ordinary GN= U General Public License. This license, the GNU Lesser General Public Licen= se, applies to certain designated libraries, and is quite different from th= e ordinary General Public License. We use this license for certain librarie= s in order to permit linking those libraries into non-free programs. + +When a program is linked with a library, whether statically or using a sha= red library, the combination of the two is legally speaking a combined work= , a derivative of the original library. The ordinary General Public License= therefore permits such linking only if the entire combination fits its cri= teria of freedom. The Lesser General Public License permits more lax criter= ia for linking other code with the library. + +We call this license the "Lesser" General Public License because it does L= ess to protect the user's freedom than the ordinary General Public License.= It also provides other free software developers Less of an advantage over = competing non-free programs. These disadvantages are the reason we use the = ordinary General Public License for many libraries. However, the Lesser lic= ense provides advantages in certain special circumstances. + +For example, on rare occasions, there may be a special need to encourage t= he widest possible use of a certain library, so that it becomes a de-facto = standard. To achieve this, non-free programs must be allowed to use the lib= rary. A more frequent case is that a free library does the same job as wide= ly used non-free libraries. In this case, there is little to gain by limiti= ng the free library to free software only, so we use the Lesser General Pub= lic License. + +In other cases, permission to use a particular library in non-free program= s enables a greater number of people to use a large body of free software. = For example, permission to use the GNU C Library in non-free programs enabl= es many more people to use the whole GNU operating system, as well as its v= ariant, the GNU/Linux operating system. + +Although the Lesser General Public License is Less protective of the users= ' freedom, it does ensure that the user of a program that is linked with th= e Library has the freedom and the wherewithal to run that program using a m= odified version of the Library. + +The precise terms and conditions for copying, distribution and modificatio= n follow. Pay close attention to the difference between a "work based on th= e library" and a "work that uses the library". The former contains code der= ived from the library, whereas the latter must be combined with the library= in order to run. + +TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + +0. This License Agreement applies to any software library or other program= which contains a notice placed by the copyright holder or other authorized= party saying it may be distributed under the terms of this Lesser General = Public License (also called "this License"). Each licensee is addressed as = "you". + +A "library" means a collection of software functions and/or data prepared = so as to be conveniently linked with application programs (which use some o= f those functions and data) to form executables. + +The "Library", below, refers to any such software library or work which ha= s been distributed under these terms. A "work based on the Library" means e= ither the Library or any derivative work under copyright law: that is to sa= y, a work containing the Library or a portion of it, either verbatim or wit= h modifications and/or translated straightforwardly into another language. = (Hereinafter, translation is included without limitation in the term "modif= ication".) + +"Source code" for a work means the preferred form of the work for making m= odifications to it. For a library, complete source code means all the sourc= e code for all modules it contains, plus any associated interface definitio= n files, plus the scripts used to control compilation and installation of t= he library. + +Activities other than copying, distribution and modification are not cover= ed by this License; they are outside its scope. The act of running a progra= m using the Library is not restricted, and output from such a program is co= vered only if its contents constitute a work based on the Library (independ= ent of the use of the Library in a tool for writing it). Whether that is tr= ue depends on what the Library does and what the program that uses the Libr= ary does. + +1. You may copy and distribute verbatim copies of the Library's complete s= ource code as you receive it, in any medium, provided that you conspicuousl= y and appropriately publish on each copy an appropriate copyright notice an= d disclaimer of warranty; keep intact all the notices that refer to this Li= cense and to the absence of any warranty; and distribute a copy of this Lic= ense along with the Library. + +You may charge a fee for the physical act of transferring a copy, and you = may at your option offer warranty protection in exchange for a fee. + +2. You may modify your copy or copies of the Library or any portion of it,= thus forming a work based on the Library, and copy and distribute such mod= ifications or work under the terms of Section 1 above, provided that you al= so meet all of these conditions: + + a) The modified work must itself be a software library. + b) You must cause the files modified to carry prominent notices statin= g that you changed the files and the date of any change. + c) You must cause the whole of the work to be licensed at no charge to= all third parties under the terms of this License. + d) If a facility in the modified Library refers to a function or a tab= le of data to be supplied by an application program that uses the facility,= other than as an argument passed when the facility is invoked, then you mu= st make a good faith effort to ensure that, in the event an application doe= s not supply such function or table, the facility still operates, and perfo= rms whatever part of its purpose remains meaningful. + + (For example, a function in a library to compute square roots has a pu= rpose that is entirely well-defined independent of the application. Therefo= re, Subsection 2d requires that any application-supplied function or table = used by this function must be optional: if the application does not supply = it, the square root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If identifiable = sections of that work are not derived from the Library, and can be reasonab= ly considered independent and separate works in themselves, then this Licen= se, and its terms, do not apply to those sections when you distribute them = as separate works. But when you distribute the same sections as part of a w= hole which is a work based on the Library, the distribution of the whole mu= st be on the terms of this License, whose permissions for other licensees e= xtend to the entire whole, and thus to each and every part regardless of wh= o wrote it. + +Thus, it is not the intent of this section to claim rights or contest your= rights to work written entirely by you; rather, the intent is to exercise = the right to control the distribution of derivative or collective works bas= ed on the Library. + +In addition, mere aggregation of another work not based on the Library wit= h the Library (or with a work based on the Library) on a volume of a storag= e or distribution medium does not bring the other work under the scope of t= his License. + +3. You may opt to apply the terms of the ordinary GNU General Public Licen= se instead of this License to a given copy of the Library. To do this, you = must alter all the notices that refer to this License, so that they refer t= o the ordinary GNU General Public License, version 2, instead of to this Li= cense. (If a newer version than version 2 of the ordinary GNU General Publi= c License has appeared, then you can specify that version instead if you wi= sh.) Do not make any other change in these notices. + +Once this change is made in a given copy, it is irreversible for that copy= , so the ordinary GNU General Public License applies to all subsequent copi= es and derivative works made from that copy. + +This option is useful when you wish to copy part of the code of the Librar= y into a program that is not a library. + +4. You may copy and distribute the Library (or a portion or derivative of = it, under Section 2) in object code or executable form under the terms of S= ections 1 and 2 above provided that you accompany it with the complete corr= esponding machine-readable source code, which must be distributed under the= terms of Sections 1 and 2 above on a medium customarily used for software = interchange. + +If distribution of object code is made by offering access to copy from a d= esignated place, then offering equivalent access to copy the source code fr= om the same place satisfies the requirement to distribute the source code, = even though third parties are not compelled to copy the source along with t= he object code. + +5. A program that contains no derivative of any portion of the Library, bu= t is designed to work with the Library by being compiled or linked with it,= is called a "work that uses the Library". Such a work, in isolation, is no= t a derivative work of the Library, and therefore falls outside the scope o= f this License. + +However, linking a "work that uses the Library" with the Library creates a= n executable that is a derivative of the Library (because it contains porti= ons of the Library), rather than a "work that uses the library". The execut= able is therefore covered by this License. Section 6 states terms for distr= ibution of such executables. + +When a "work that uses the Library" uses material from a header file that = is part of the Library, the object code for the work may be a derivative wo= rk of the Library even though the source code is not. Whether this is true = is especially significant if the work can be linked without the Library, or= if the work is itself a library. The threshold for this to be true is not = precisely defined by law. + +If such an object file uses only numerical parameters, data structure layo= uts and accessors, and small macros and small inline functions (ten lines o= r less in length), then the use of the object file is unrestricted, regardl= ess of whether it is legally a derivative work. (Executables containing thi= s object code plus portions of the Library will still fall under Section 6.) + +Otherwise, if the work is a derivative of the Library, you may distribute = the object code for the work under the terms of Section 6. Any executables = containing that work also fall under Section 6, whether or not they are lin= ked directly with the Library itself. + +6. As an exception to the Sections above, you may also combine or link a "= work that uses the Library" with the Library to produce a work containing p= ortions of the Library, and distribute that work under terms of your choice= , provided that the terms permit modification of the work for the customer'= s own use and reverse engineering for debugging such modifications. + +You must give prominent notice with each copy of the work that the Library= is used in it and that the Library and its use are covered by this License= . You must supply a copy of this License. If the work during execution disp= lays copyright notices, you must include the copyright notice for the Libra= ry among them, as well as a reference directing the user to the copy of thi= s License. Also, you must do one of these things: + + a) Accompany the work with the complete corresponding machine-readable= source code for the Library including whatever changes were used in the wo= rk (which must be distributed under Sections 1 and 2 above); and, if the wo= rk is an executable linked with the Library, with the complete machine-read= able "work that uses the Library", as object code and/or source code, so th= at the user can modify the Library and then relink to produce a modified ex= ecutable containing the modified Library. (It is understood that the user w= ho changes the contents of definitions files in the Library will not necess= arily be able to recompile the application to use the modified definitions.) + b) Use a suitable shared library mechanism for linking with the Librar= y. A suitable mechanism is one that (1) uses at run time a copy of the libr= ary already present on the user's computer system, rather than copying libr= ary functions into the executable, and (2) will operate properly with a mod= ified version of the library, if the user installs one, as long as the modi= fied version is interface-compatible with the version that the work was mad= e with. + c) Accompany the work with a written offer, valid for at least three y= ears, to give the same user the materials specified in Subsection 6a, above= , for a charge no more than the cost of performing this distribution. + d) If distribution of the work is made by offering access to copy from= a designated place, offer equivalent access to copy the above specified ma= terials from the same place. + e) Verify that the user has already received a copy of these materials= or that you have already sent this user a copy. + +For an executable, the required form of the "work that uses the Library" m= ust include any data and utility programs needed for reproducing the execut= able from it. However, as a special exception, the materials to be distribu= ted need not include anything that is normally distributed (in either sourc= e or binary form) with the major components (compiler, kernel, and so on) o= f the operating system on which the executable runs, unless that component = itself accompanies the executable. + +It may happen that this requirement contradicts the license restrictions o= f other proprietary libraries that do not normally accompany the operating = system. Such a contradiction means you cannot use both them and the Library= together in an executable that you distribute. + +7. You may place library facilities that are a work based on the Library s= ide-by-side in a single library together with other library facilities not = covered by this License, and distribute such a combined library, provided t= hat the separate distribution of the work based on the Library and of the o= ther library facilities is otherwise permitted, and provided that you do th= ese two things: + + a) Accompany the combined library with a copy of the same work based o= n the Library, uncombined with any other library facilities. This must be d= istributed under the terms of the Sections above. + b) Give prominent notice with the combined library of the fact that pa= rt of it is a work based on the Library, and explaining where to find the a= ccompanying uncombined form of the same work. + +8. You may not copy, modify, sublicense, link with, or distribute the Libr= ary except as expressly provided under this License. Any attempt otherwise = to copy, modify, sublicense, link with, or distribute the Library is void, = and will automatically terminate your rights under this License. However, p= arties who have received copies, or rights, from you under this License wil= l not have their licenses terminated so long as such parties remain in full= compliance. + +9. You are not required to accept this License, since you have not signed = it. However, nothing else grants you permission to modify or distribute the= Library or its derivative works. These actions are prohibited by law if yo= u do not accept this License. Therefore, by modifying or distributing the L= ibrary (or any work based on the Library), you indicate your acceptance of = this License to do so, and all its terms and conditions for copying, distri= buting or modifying the Library or works based on it. + +10. Each time you redistribute the Library (or any work based on the Libra= ry), the recipient automatically receives a license from the original licen= sor to copy, distribute, link with or modify the Library subject to these t= erms and conditions. You may not impose any further restrictions on the rec= ipients' exercise of the rights granted herein. You are not responsible for= enforcing compliance by third parties with this License. + +11. If, as a consequence of a court judgment or allegation of patent infri= ngement or for any other reason (not limited to patent issues), conditions = are imposed on you (whether by court order, agreement or otherwise) that co= ntradict the conditions of this License, they do not excuse you from the co= nditions of this License. If you cannot distribute so as to satisfy simulta= neously your obligations under this License and any other pertinent obligat= ions, then as a consequence you may not distribute the Library at all. For = example, if a patent license would not permit royalty-free redistribution o= f the Library by all those who receive copies directly or indirectly throug= h you, then the only way you could satisfy both it and this License would b= e to refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any = particular circumstance, the balance of the section is intended to apply, a= nd the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any patent= s or other property right claims or to contest validity of any such claims;= this section has the sole purpose of protecting the integrity of the free = software distribution system which is implemented by public license practic= es. Many people have made generous contributions to the wide range of softw= are distributed through that system in reliance on consistent application o= f that system; it is up to the author/donor to decide if he or she is willi= ng to distribute software through any other system and a licensee cannot im= pose that choice. + +This section is intended to make thoroughly clear what is believed to be a= consequence of the rest of this License. + +12. If the distribution and/or use of the Library is restricted in certain= countries either by patents or by copyrighted interfaces, the original cop= yright holder who places the Library under this License may add an explicit= geographical distribution limitation excluding those countries, so that di= stribution is permitted only in or among countries not thus excluded. In su= ch case, this License incorporates the limitation as if written in the body= of this License. + +13. The Free Software Foundation may publish revised and/or new versions o= f the Lesser General Public License from time to time. Such new versions wi= ll be similar in spirit to the present version, but may differ in detail to= address new problems or concerns. + +Each version is given a distinguishing version number. If the Library spec= ifies a version number of this License which applies to it and "any later v= ersion", you have the option of following the terms and conditions either o= f that version or of any later version published by the Free Software Found= ation. If the Library does not specify a license version number, you may ch= oose any version ever published by the Free Software Foundation. + +14. If you wish to incorporate parts of the Library into other free progra= ms whose distribution conditions are incompatible with these, write to the = author to ask for permission. For software which is copyrighted by the Free= Software Foundation, write to the Free Software Foundation; we sometimes m= ake exceptions for this. Our decision will be guided by the two goals of pr= eserving the free status of all derivatives of our free software and of pro= moting the sharing and reuse of software generally. + +NO WARRANTY + +15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY F= OR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHE= RWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE = THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLI= ED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILIT= Y AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY A= ND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTI= VE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + +16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING = WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTR= IBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDI= NG ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF= THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS= OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR TH= IRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE)= , EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF= SUCH DAMAGES. +END OF TERMS AND CONDITIONS + +How to Apply These Terms to Your New Libraries + +If you develop a new library, and you want it to be of the greatest possib= le use to the public, we recommend making it free software that everyone ca= n redistribute and change. You can do so by permitting redistribution under= these terms (or, alternatively, under the terms of the ordinary General Pu= blic License). + +To apply these terms, attach the following notices to the library. It is s= afest to attach them to the start of each source file to most effectively c= onvey the exclusion of warranty; and each file should have at least the "co= pyright" line and a pointer to where the full notice is found. + +one line to give the library's name and an idea of what it does. +Copyright (C) year name of author + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with this library; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 = USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your sc= hool, if any, to sign a "copyright disclaimer" for the library, if necessar= y. Here is a sample; alter the names: + +Yoyodyne, Inc., hereby disclaims all copyright interest in +the library `Frob' (a library for tweaking knobs) written +by James Random Hacker. + +signature of Ty Coon, 1 April 1990 +Ty Coon, President of Vice + +That's all there is to it! + +-------------------------------------------------- diff --git a/tools/ocaml/duniverse/stdlib-shims/README.md b/tools/ocaml/dun= iverse/stdlib-shims/README.md new file mode 100644 index 0000000000..79890c2d8f --- /dev/null +++ b/tools/ocaml/duniverse/stdlib-shims/README.md @@ -0,0 +1,2 @@ +# stdlib-shims +Shims for forward-compatibility between versions of the OCaml standard lib= rary diff --git a/tools/ocaml/duniverse/stdlib-shims/dune-project b/tools/ocaml/= duniverse/stdlib-shims/dune-project new file mode 100644 index 0000000000..de4fc20920 --- /dev/null +++ b/tools/ocaml/duniverse/stdlib-shims/dune-project @@ -0,0 +1 @@ +(lang dune 1.0) diff --git a/tools/ocaml/duniverse/stdlib-shims/dune-workspace.dev b/tools/= ocaml/duniverse/stdlib-shims/dune-workspace.dev new file mode 100644 index 0000000000..c793fa1927 --- /dev/null +++ b/tools/ocaml/duniverse/stdlib-shims/dune-workspace.dev @@ -0,0 +1,14 @@ +(lang dune 1.0) + +;; Run the following command to test against all supported versions of +;; OCaml: +;; +;; $ dune runtest --workspace dune-workspace.dev + +(context (opam (switch 4.02.3))) +(context (opam (switch 4.03.0))) +(context (opam (switch 4.04.2))) +(context (opam (switch 4.05.0))) +(context (opam (switch 4.06.1))) +(context (opam (switch 4.07.0))) +(context (opam (switch 4.08.0+trunk))) diff --git a/tools/ocaml/duniverse/stdlib-shims/src/dune b/tools/ocaml/duni= verse/stdlib-shims/src/dune new file mode 100644 index 0000000000..7981a8a11f --- /dev/null +++ b/tools/ocaml/duniverse/stdlib-shims/src/dune @@ -0,0 +1,97 @@ +(* -*- tuareg -*- *) + +open StdLabels +open Jbuild_plugin.V1 + +let version =3D Scanf.sscanf ocaml_version "%u.%u" (fun a b -> (a, b)) + +let modules_in_4_02 =3D + [ "Arg" + ; "Array" + ; "ArrayLabels" + ; "Buffer" + ; "Bytes" + ; "BytesLabels" + ; "Callback" + ; "Char" + ; "Complex" + ; "Digest" + ; "Filename" + ; "Format" + ; "Gc" + ; "Genlex" + ; "Hashtbl" + ; "Int32" + ; "Int64" + ; "Lazy" + ; "Lexing" + ; "List" + ; "ListLabels" + ; "Map" + ; "Marshal" + ; "MoreLabels" + ; "Nativeint" + ; "Obj" + ; "Oo" + ; "Parsing" + ; "Pervasives" + ; "Printexc" + ; "Printf" + ; "Queue" + ; "Random" + ; "Scanf" + ; "Set" + ; "Stack" + ; "StdLabels" + ; "Stream" + ; "String" + ; "StringLabels" + ; "Sys" + ; "Weak" + ] + +let modules_post_4_02 =3D + [ "Float", (4, 07) + ; "Seq", (4, 07) + ; "Stdlib", (4, 07) + ; "Uchar", (4, 03) + ] + +let available_modules =3D + modules_in_4_02 @ + (List.filter modules_post_4_02 ~f:(fun (m, v) -> + version >=3D v) + |> List.map ~f:fst) + +let all_modules_except_stdlib =3D + available_modules + |> List.filter ~f:((<>) "Stdlib") + |> List.sort ~cmp:String.compare + +let longest_module_name =3D + List.fold_left all_modules_except_stdlib ~init:0 + ~f:(fun acc m -> max acc (String.length m)) + +let stdlib_rule =3D + Printf.sprintf {| +(rule + (with-stdout-to stdlib.ml + (echo "\ +%s + +include Pervasives +"))) +|} + (List.map all_modules_except_stdlib + ~f:(fun m -> Printf.sprintf "module %-*s =3D %s" longest_module_nam= e m m) + |> String.concat ~sep:"\n") + +let () =3D + Printf.ksprintf send {| +(library + (wrapped false) + (name stdlib_shims) + (public_name stdlib-shims)) +%s +|} + (if version >=3D (4, 07) then "" else stdlib_rule) diff --git a/tools/ocaml/duniverse/stdlib-shims/stdlib-shims.opam b/tools/o= caml/duniverse/stdlib-shims/stdlib-shims.opam new file mode 100644 index 0000000000..c4e1fb9d86 --- /dev/null +++ b/tools/ocaml/duniverse/stdlib-shims/stdlib-shims.opam @@ -0,0 +1,24 @@ +version: "0.1.0" +opam-version: "2.0" +maintainer: "The stdlib-shims programmers" +authors: "The stdlib-shims programmers" +homepage: "https://github.com/ocaml/stdlib-shims" +doc: "https://ocaml.github.io/stdlib-shims/" +dev-repo: "git+https://github.com/ocaml/stdlib-shims.git" +bug-reports: "https://github.com/ocaml/stdlib-shims/issues" +tags: ["stdlib" "compatibility" "org:ocaml"] +license: ["typeof OCaml system"] +available: [ ] +depends: [ + "dune" + "ocaml" {>=3D "4.02.3"} +] +build: [ "dune" "build" "-p" name "-j" jobs ] +synopsis: "Backport some of the new stdlib features to older compiler" +description: """ +Backport some of the new stdlib features to older compiler, +such as the Stdlib module. + +This allows projects that require compatibility with older compiler to +use these new features in their code. +""" \ No newline at end of file diff --git a/tools/ocaml/duniverse/stdlib-shims/test/dune b/tools/ocaml/dun= iverse/stdlib-shims/test/dune new file mode 100644 index 0000000000..f31738ad94 --- /dev/null +++ b/tools/ocaml/duniverse/stdlib-shims/test/dune @@ -0,0 +1,3 @@ +(test + (name test) + (libraries stdlib_shims)) diff --git a/tools/ocaml/duniverse/stdlib-shims/test/test.ml b/tools/ocaml/= duniverse/stdlib-shims/test/test.ml new file mode 100644 index 0000000000..1f0e4941b6 --- /dev/null +++ b/tools/ocaml/duniverse/stdlib-shims/test/test.ml @@ -0,0 +1,2 @@ +let _ =3D Stdlib.(+) +let _ =3D Stdlib.List.map diff --git a/tools/ocaml/xen.opam.locked b/tools/ocaml/xen.opam.locked new file mode 100644 index 0000000000..fde42bc495 --- /dev/null +++ b/tools/ocaml/xen.opam.locked @@ -0,0 +1,119 @@ +opam-version: "2.0" +synopsis: "opam-monorepo generated lockfile" +maintainer: "opam-monorepo" +depends: [ + "afl-persistent" {=3D "1.3"} + "base-bigarray" {=3D "base"} + "base-bytes" {=3D "base"} + "base-threads" {=3D "base"} + "base-unix" {=3D "base"} + "cmdliner" {=3D "1.0.4+dune"} + "cppo" {=3D "1.6.7"} + "crowbar" {=3D "0.2"} + "csexp" {=3D "1.3.2"} + "fmt" {=3D "0.8.8+dune"} + "ocaml" {=3D "4.12.0"} + "ocaml-base-compiler" {=3D "4.12.0~beta1"} + "ocaml-config" {=3D "2"} + "ocaml-options-vanilla" {=3D "1"} + "ocplib-endian" {=3D "1.1"} + "result" {=3D "1.5"} + "stdlib-shims" {=3D "0.1.0"} +] +depexts: ["libsystemd-dev" "libxen-dev" "m4"] {os-distribution =3D "debian= "} +pin-depends: [ + [ + "afl-persistent.1.3" + "git+file:///home/edwin-work/afl-persistent#09539920681aafb7f792d5280c= 76d4020848b3c0" + ] + [ + "cmdliner.1.0.4+dune" + "https://github.com/dune-universe/cmdliner/archive/v1.0.4+dune.tar.gz" + ] + [ + "cppo.1.6.7" + "https://github.com/ocaml-community/cppo/releases/download/v1.6.7/cppo= -v1.6.7.tbz" + ] + ["crowbar.0.2" "https://github.com/stedolan/crowbar/archive/v0.2.tar.gz"] + [ + "csexp.1.3.2" + "https://github.com/ocaml-dune/csexp/releases/download/1.3.2/csexp-1.3= .2.tbz" + ] + [ + "fmt.0.8.8+dune" + "https://github.com/dune-universe/fmt/archive/v0.8.8+dune.tar.gz" + ] + [ + "ocplib-endian.1.1" + "https://github.com/OCamlPro/ocplib-endian/archive/1.1.tar.gz" + ] + [ + "result.1.5" + "https://github.com/janestreet/result/releases/download/1.5/result-1.5= .tbz" + ] + [ + "stdlib-shims.0.1.0" + "https://github.com/ocaml/stdlib-shims/releases/download/0.1.0/stdlib-= shims-0.1.0.tbz" + ] +] +x-opam-monorepo-duniverse-dirs: [ + [ + "git+file:///home/edwin-work/afl-persistent#09539920681aafb7f792d5280c= 76d4020848b3c0" + "ocaml-afl-persistent" + ] + [ + "https://github.com/OCamlPro/ocplib-endian/archive/1.1.tar.gz" + "ocplib-endian" + [ + "md5=3Ddedf4d69c1b87b3c6c7234f632399285" + "sha512=3D39351c666d1394770696fa89ac62f7c137ad1697d99888bfba2cc8de2c= 61df05dd8b3aa327c117bf38f3e29e081026d2c575c5ad0022bde92b3d43aba577d3f9" + ] + ] + [ + "https://github.com/dune-universe/cmdliner/archive/v1.0.4+dune.tar.gz" + "cmdliner" + [ + "sha256=3Dffc09f07a9e394d6be4dbecea7add601ff00519a91dff4c95b9cd0a4aa= 60eceb" + ] + ] + [ + "https://github.com/dune-universe/fmt/archive/v0.8.8+dune.tar.gz" + "fmt" + [ + "sha256=3Dda16172528cc5ebde062fcb25e46085962ddd5fd32d2dc00eb07697384= f0eb2d" + ] + ] + [ + "https://github.com/janestreet/result/releases/download/1.5/result-1.5= .tbz" + "result" + ["md5=3D1b82dec78849680b49ae9a8a365b831b"] + ] + [ + "https://github.com/ocaml-community/cppo/releases/download/v1.6.7/cppo= -v1.6.7.tbz" + "cppo" + [ + "sha256=3Ddb553e3e6c206df09b1858c3aef5e21e56564d593642a3c78bcedb6af3= 6f529d" + "sha512=3D9722b50fd23aaccf86816313333a3bf8fc7c6b4ef06b153e5e1e1aaf14= 670cf51a4aac52fb1b4a0e5531699c4047a1eff6c24c969f7e5063e78096c2195b5819" + ] + ] + [ + "https://github.com/ocaml-dune/csexp/releases/download/1.3.2/csexp-1.3= .2.tbz" + "csexp" + [ + "sha256=3Df21f427b277f07e8bfd050e00c640a5893c1bf4b689147640fa383255d= cf1c4a" + "sha512=3Dff1bd6a7c6bb3a73ca9ab0506c9ec1f357657deaa9ecc7eb32955817d9= b0f266d976af3e2b8fc34c621cb0caf1fde55f9a609dd184e2054f500bf09afeb83026" + ] + ] + [ + "https://github.com/ocaml/stdlib-shims/releases/download/0.1.0/stdlib-= shims-0.1.0.tbz" + "stdlib-shims" + ["md5=3D12b5704eed70c6bff5ac39a16db1425d"] + ] + [ + "https://github.com/stedolan/crowbar/archive/v0.2.tar.gz" + "crowbar" + ["md5=3D55e85b9fcc3a777bc7c70ec57b136e7c"] + ] +] +x-opam-monorepo-root-packages: ["xen" "xenstore" "xenstored"] +x-opam-monorepo-version: "0.2" --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620756439; cv=none; d=zohomail.com; s=zohoarc; b=jILEaxF9GQXCFOzniMIE0AcC07Ex7ck2pntld6nK0z6tl/R7fYqhWx5McXFQibOnvVAxLGOLBcqcU2b+dS7tSdg5v1YacHE8JmaaFN6sd24AAyvD6GTaNPHvh4Qp1TaR8zjQpUyZq9KqlWcmNCKb0nsEt45TKnWwt4VY1lrG+68= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620756439; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=7InRmdx51pM7E4qJtUc2vZ9pU13UkFgFt1oQ/whI8oY=; b=iAaXRU56jFEVereXpyZTGnE/5fGh0zw3YBJ5rzyUQCkaHVMM7hf5psc1BuPBuIOGRe6IQvHSlw77DHDRFnHA+vEOk39HlXrFxHVoiOZZMBK1ElQOnHskdykVpehPtgbiLf/fhXFq2wHl+qqTDITub5C3lmkSVRe8n2w0h3Q8kFM= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 162075643930924.554818915213673; Tue, 11 May 2021 11:07:19 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125899.236988 (Exim 4.92) (envelope-from ) id 1lgWma-00013q-8a; Tue, 11 May 2021 18:07:00 +0000 Received: by outflank-mailman (output) from mailman id 125899.236988; Tue, 11 May 2021 18:07:00 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWma-00013j-5B; Tue, 11 May 2021 18:07:00 +0000 Received: by outflank-mailman (input) for mailman id 125899; Tue, 11 May 2021 18:06:58 +0000 Received: from us1-rack-iad1.inumbo.com ([172.99.69.81]) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmY-0000hb-Pl for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:06:58 +0000 Received: from esa3.hc3370-68.iphmx.com (unknown [216.71.145.155]) by us1-rack-iad1.inumbo.com (Halon) with ESMTPS id 86efdff2-a848-4969-b83b-8343218ced3c; Tue, 11 May 2021 18:06:51 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 86efdff2-a848-4969-b83b-8343218ced3c DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620756411; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=kIHSglxPAwnvzoL5IzOBULzsMXsyyLvM7qOksEaxYCM=; b=YMNC1G1Ysy5r2XsAc+Nh97kZq5avg42cvFSB2o+uqSu2ctcMO1WAHhEd /v+llB8ozIWL0M2BdOrhxfD5CFA4sfeQYjdObe0lxOAr/xpiGo1xXGXL+ eyXuHy7BnHCE92yAvUV59MPqCFl1JwFNdUvlZxdwZWdtfMhZg3vAtl9hi Q=; Authentication-Results: esa3.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: cl8K5cFZfpjF/NnbS6sFm8sXJGgjZmf4SlKT6+vvWFjC+wuWBU94DAFj/WtLDoNfEZ/Z+joHpX n7BMXmNtI+c3UwGTuwnL4ezcOlnhqqrRLoonqp5cj/SKOwoUv+kOZqmRVEm0cAWODUulqKo+K8 JlyABlGXRh1B0WrP6UA5J/i2aizOZFdzMzeurbL6bpWaGlGHYu4DVjg8vKRRk+g30sCgPLqfth 8mzZx4cNy4oppVEFtRUl0WywzJkzANjpVpB5PB3utkNVzXtne7WELk7z9ShoDWD/NjcV7/AMiK Qys= X-SBRS: 5.1 X-MesageID: 43579247 X-Ironport-Server: esa3.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:9/6l269oOnbNBBwYLGJuk+DgI+orL9Y04lQ7vn2YSXRuHPBw8P re5cjztCWE7gr5N0tBpTntAsW9qDbnhPtICOoqTNCftWvdyQiVxehZhOOIqVDd8m/Fh4pgPM 9bAtBD4bbLbGSS4/yU3ODBKadD/OW6 X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43579247" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 04/17] tools/ocaml/xenstored: implement the live migration binary format Date: Tue, 11 May 2021 19:05:17 +0100 Message-ID: <1203d68f34f55b675e64df228c7d45405e1304a8.1620755942.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) This is implemented by C xenstored as live update dump format. oxenstored already has its own (text-based) dump format, but for compatibility implement one compatible with C xenstored. This will also be useful in the future for non-cooperative guest live migra= tion. docs/designs/xenstore-migration.md documents the format For now this always dumps integers in big endian order, because even old versions of OCaml have support for that. The binary format supports both little and big endian orders, so this should be compatible. To dump in little endian or native endian order we would require OCaml 4.08+. Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/xenstored/disk.ml | 318 ++++++++++++++++++++++++++++++++++ 1 file changed, 318 insertions(+) diff --git a/tools/ocaml/xenstored/disk.ml b/tools/ocaml/xenstored/disk.ml index 4739967b61..595fdab54a 100644 --- a/tools/ocaml/xenstored/disk.ml +++ b/tools/ocaml/xenstored/disk.ml @@ -155,3 +155,321 @@ let write store =3D Unix.rename tfile xs_daemon_database with exc -> error "caught exn %s" (Printexc.to_string exc) + + module BinaryOut =3D struct + let version =3D 0x1 + let endian =3D 1 + let padding =3D String.make 7 '\x00' + + let write_header ch =3D + (* for testing endian order *) + output_binary_int ch 0x78656e73; + output_binary_int ch 0x746f7265; + output_binary_int ch version; + output_binary_int ch endian; + ch + + let w8 =3D output_char + let w16 ch i =3D + assert (i >=3D 0 && i lsr 16 =3D 0); + output_byte ch (i lsr 8); + output_byte ch i + + let w32 ch v =3D + assert (v >=3D 0 && v <=3D 0xFFFF_FFFF); + output_binary_int ch v + + let pos =3D pos_out + let wpad ch =3D + let padto =3D 8 in + let padby =3D (padto - pos ch mod padto) mod padto in + if padby > 0 then + output_substring ch padding 0 padby + + let wstring =3D output_string + end + + module BinaryIn =3D struct + type t =3D in_channel + + let read_header t =3D + let h =3D Bytes.make 8 '\x00' in + really_input t h 0 (Bytes.length h); + let ver =3D input_binary_int t in + let endian =3D input_binary_int t in + if Bytes.to_string h <> "xenstore" then + failwith "Header doesn't begin with 'xenstore'"; + if ver <> BinaryOut.version then + failwith "Incompatible version"; + if endian <> BinaryOut.endian then + failwith "Incompatible endianness" + + let r8 =3D input_char + + let r16 t =3D=20 + let r0 =3D input_byte t in + let r1 =3D input_byte t in + (r0 lsl 8) lor r1 + + let r32 t =3D + (* read unsigned 32-bit int *) + let r =3D input_binary_int t land 0xFFFF_FFFF in + assert (r >=3D 0); + r + + let rstring =3D really_input_string + + let rpad t =3D + let padto =3D 8 in + let padby =3D (padto - pos_in t mod padto) mod padto in + if padby > 0 then + ignore (really_input_string t padby) + end + +module FD : sig + type t =3D Unix.file_descr + val of_int: int -> t + val to_int : t -> int +end =3D struct + type t =3D Unix.file_descr + (* This is like Obj.magic but just for these types, + and relies on Unix.file_descr =3D int *) + external to_int : t -> int =3D "%identity" + external of_int : int -> t =3D "%identity" +end + +module LiveRecord =3D struct + (* See docs/designs/xenstore-migration.md for binary format *) + module Type : sig + type t =3D private int + val end_ : t + val global_data : t + val connection_data : t + val watch_data : t + val transaction_data : t + val node_data: t + end =3D struct + type t =3D int + let end_ =3D 0x0 + let global_data =3D 0x01 + let connection_data =3D 0x02 + let watch_data =3D 0x03 + let transaction_data =3D 0x04 + let node_data =3D 0x05 + end + + module I =3D BinaryIn + module O =3D BinaryOut + + let write_expect msg expected actual =3D + if expected <> actual then + let m =3D Printf.sprintf "expected %d <> %d: %s" expected actual msg in + invalid_arg m + + let write_record t (typ: Type.t) len f =3D + assert (O.pos t mod 8 =3D 0); + O.w32 t (typ :> int); + O.w32 t len; + let p0 =3D O.pos t in + f t; + let p1 =3D O.pos t in + write_expect "position and length" len (p1-p0); + O.wpad t + + let write_end t =3D + write_record t Type.end_ 0 ignore + + let read_expect t msg expected actual =3D + if expected <> actual then + let pos =3D pos_in t in + let m =3D Printf.sprintf "expected %d <> %d at ~%d: %s" expected actual= pos msg in + invalid_arg m + + let read_end t ~len f =3D + read_expect t "end" 0 len; + f () + + let write_global_data t ~rw_sock =3D + write_record t Type.global_data 8 @@ fun b -> + O.w32 b (FD.to_int rw_sock); + O.w32 b (-1) + + let read_global_data t ~len f =3D + read_expect t "global_data" 8 len; + let rw_sock =3D FD.of_int (I.r32 t) in + let _ =3D FD.of_int (I.r32 t) in + f ~rw_sock + + let conn_shared_ring =3D 0x0 + let conn_socket =3D 0x1 + let domid_invalid =3D 0x7FF4 + + (* oxenstored doesn't support readonly sockets yet *) + let flags_connection_readonly =3D 0x1l + + type dom =3D { id: int; target: int; remote_port: int } + type conn =3D Socket of Unix.file_descr | Domain of dom + + let write_connection_data t ~conid ~conn xb_pktin xb_partialout xb_pktout= =3D + let in_data_len =3D Buffer.length xb_pktin in + let out_resp_len =3D String.length xb_partialout in + let out_data_len =3D Buffer.length xb_pktout in + let data_len =3D in_data_len + out_data_len in + + write_record t Type.connection_data (32 + data_len) @@ fun b -> + assert (conid > 0); + O.w32 b conid; + O.w32 b (match conn with + | Socket _ -> conn_socket + | Domain _ -> conn_shared_ring + ); + let flags =3D 0x0 in + O.w32 b flags; + + (match conn with + | Socket fd -> + O.w32 b (FD.to_int fd); + O.w32 b 0 (* pad *) + | Domain dom -> + O.w16 b dom.id; + O.w16 b dom.target; + O.w32 b dom.remote_port + ); + + O.w32 b in_data_len; + O.w32 b out_resp_len; + O.w32 b out_data_len; + Buffer.output_buffer b xb_pktin; + O.wstring b xb_partialout; + Buffer.output_buffer b xb_pktout + + let read_connection_data t ~len f =3D + let conid =3D I.r32 t in + assert (conid > 0); + let kind =3D I.r32 t in + let flags =3D I.r32 t in + read_expect t "flags" 0 flags; + let conn =3D (match kind with + | x when x =3D conn_socket -> + let fd =3D FD.of_int (I.r32 t) in + I.r32 t |> ignore; + Socket fd + | x when x =3D conn_shared_ring -> + let id =3D I.r16 t in + let target =3D I.r16 t in + let remote_port =3D I.r32 t in + Domain {id; target; remote_port } + | x -> + invalid_arg (Printf.sprintf "Unknown connection kind %x" x) + ) in + let in_data_len =3D I.r32 t in + let out_resp_len =3D I.r32 t in + let out_data_len =3D I.r32 t in + let in_data =3D really_input_string t in_data_len in + let out_data =3D really_input_string t out_data_len in + f ~conid ~conn ~in_data ~out_data ~out_resp_len + + + let write_watch_data t ~conid ~wpath ~token =3D + let wpath_len =3D String.length wpath in + let token_len =3D String.length token in + + write_record t Type.watch_data (12+wpath_len+token_len) @@ fun b -> + O.w32 b conid; + O.w32 b (String.length wpath); + O.w32 b (String.length token); + O.wstring b wpath; + O.wstring b token + + let read_watch_data t ~len f =3D + let conid =3D I.r32 t in + let wpathlen =3D I.r32 t in + let tokenlen =3D I.r32 t in + let wpath =3D I.rstring t wpathlen in + let token =3D I.rstring t tokenlen in + f ~conid ~wpath ~token + + let write_transaction_data t ~conid ~txid =3D + write_record t Type.transaction_data 8 @@ fun b -> + O.w32 b conid; + O.w32 b txid + + let read_transaction_data t ~len f =3D + read_expect t "transaction" 8 len; + let conid =3D I.r32 t in + let txid =3D I.r32 t in + f ~conid ~txid + + type access =3D R | W | RW | Del + + let write_node_data t ~txidaccess ~path ~value ~perms =3D + let path_len =3D String.length path in + let value_len =3D String.length value in + let perms =3D Perms.Node.acls perms in + let len =3D 24 + (List.length perms)*4 + path_len + value_len in + + write_record t Type.node_data len @@ fun b -> + O.w32 b (match txidaccess with None -> 0 | Some (conid, _, _) -> conid); + O.w32 b (match txidaccess with None -> 0 | Some (_, txid, _) -> txid); + O.w32 b path_len; + O.w32 b value_len; + O.w32 b (match txidaccess with + | None -> 0x0 + | Some (_, _, Del) -> 0x0 + | Some (_, _, R) -> 0x1 + | Some (_, _, W) -> 0x2 + | Some (_, _, RW) -> 0x3 + ); + O.w32 b (List.length perms); + List.iter (fun (domid, permty) -> + O.w8 b (Perms.char_of_permty permty); + O.w8 b '\x00'; + O.w16 b domid; + ) perms; + O.wstring b path; + O.wstring b value + + let read_node_data t ~len f =3D + let conid =3D I.r32 t in + let txid =3D I.r32 t in + let path_len =3D I.r32 t in + let value_len =3D I.r32 t in + let txaccess =3D match conid, I.r32 t with + | 0, _ -> None + | _, 0 -> Some (conid, txid, Del) + | _, 1 -> Some (conid, txid, R) + | _, 2 -> Some (conid, txid, W) + | _, 3 -> Some (conid, txid, RW) + | _ -> invalid_arg "invalid access flag" + in + let a =3D Array.init (I.r32 t) (fun _ -> + let perm =3D Perms.permty_of_char (I.r8 t) in + I.r8 t |> ignore; + let domid =3D I.r16 t in + domid, perm + ) in + let perms =3D match Array.to_list a with + | [] -> invalid_arg "Permission list cannot be empty"; + | (owner, other) :: acls -> + Perms.Node.create owner other acls + in + let path =3D I.rstring t path_len in + let value =3D I.rstring t value_len in + f ~txaccess ~perms ~path ~value + + let read_record t ~on_end ~on_global_data ~on_connection_data ~on_watch_d= ata ~on_transaction_data ~on_node_data =3D + I.rpad t; (* if we fail to process a record (e.g. callback raises, ensur= e we resume at right place *) + let typ =3D I.r32 t in + let len =3D I.r32 t in + let p0 =3D pos_in t in + (match typ with + | x when x =3D (Type.end_ :> int) -> read_end t ~len on_end + | x when x =3D (Type.global_data :> int) -> read_global_data t ~len on_g= lobal_data + | x when x =3D (Type.connection_data :> int) -> read_connection_data t ~= len on_connection_data + | x when x =3D (Type.watch_data :> int) -> read_watch_data t ~len on_wat= ch_data + | x when x =3D (Type.transaction_data :> int) -> read_transaction_data t= ~len on_transaction_data + | x when x =3D (Type.node_data :> int) -> read_node_data t ~len on_node_= data + | x -> failwith (Printf.sprintf "Unknown record type: %x" x)); + let p1 =3D pos_in t in + read_expect t "record length" len (p1-p0) +end --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620756428; cv=none; d=zohomail.com; s=zohoarc; b=AW2X5VhhSt35THhxp/4pjxtAi65MxSODM5k9C8LMl5eYkmBUIGTdasDPsBGYAodAs+/vv3CbOEsqPNX9MofCspxLd+I+PZ86+4VV6fzCp3onLE6sMQgiuDzw94auiXNj7raQ2fShbLP344PdmBnSF3dwn3s3y1vBGeY+fqUTaRg= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620756428; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=bNgxsbldBS8EnVRine+MOsZOfO8ZJnYq+virNFDLFTU=; b=BsAac9KpuxhSVpfaNQ7qGv5bsV/vJaNwI/SfLkjC7/f62jOV2T3tSY/gut2ygFvUksx2QGBAOay5bgt5guM1lYQplRqIRJKbCW5nWZgUXMVOMTOP6T51sectAjscG1sN76dS91IIybUiAoqbkzyw8HiYKJV08PSk51RYitBWbko= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 16207564286638.019195913568979; Tue, 11 May 2021 11:07:08 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125898.236977 (Exim 4.92) (envelope-from ) id 1lgWmU-0000hz-Vc; Tue, 11 May 2021 18:06:54 +0000 Received: by outflank-mailman (output) from mailman id 125898.236977; Tue, 11 May 2021 18:06:54 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmU-0000hs-Sm; Tue, 11 May 2021 18:06:54 +0000 Received: by outflank-mailman (input) for mailman id 125898; Tue, 11 May 2021 18:06:53 +0000 Received: from us1-rack-iad1.inumbo.com ([172.99.69.81]) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmT-0000hb-Qp for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:06:53 +0000 Received: from esa6.hc3370-68.iphmx.com (unknown [216.71.155.175]) by us1-rack-iad1.inumbo.com (Halon) with ESMTPS id 030b699d-ba57-4ff2-92aa-1b1c49c25836; Tue, 11 May 2021 18:06:52 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 030b699d-ba57-4ff2-92aa-1b1c49c25836 DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620756412; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=LJybmG+tBz4IHj5Tv2R6AGzuVV3gHz/bSFDawWJReUw=; b=Hnnvl/WIu49Q1HX5O/aKBIEfWdKtoAt7mEYDZvtniN6G3BnePUKKK1PY 9rvhEQQdDQBfleGYU5VP4407exUB0fSLugsxUN3j+NYE40PQvbPLVUphE EDq4BiXLw2XEfNud2dQTY9jJXPg4KvR7ZXNOruBNG0o8u7C7GEgO0G7FO o=; Authentication-Results: esa6.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: 2XBnpXDrfeAUsHExPzOU4DUtdbP3NkWpMxhDt2/N9KZXxZrAf8DE0E5VECDQoJdKOe+eVTcUNF Wnmairsgd8GscxkAymYmA3YauKCpr1MTQ2uil240NVafuLPpsq9xQngdpRpUsBhX7Ohp+OMTXA PXGdzw8acPYvfu9axqxRLUENFfoSAVc5Pz+jYARskbiOkPiC/jlNwiX6jUB2tomNkcjxCk8hOc xZEN8fdlRy8TbvcSYyGEdqIOjuIuflsOuaJR/gDe/FuEkYMYl1gDEGsi23CBbnmVQaX6d6nnvd m34= X-SBRS: 5.1 X-MesageID: 43675314 X-Ironport-Server: esa6.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:S4LKvq39hDQLwVEJvbUAtwqjBIokLtp133Aq2lEZdPRUGvb3qy nIpoVj6faUskd2ZJhOo7C90cW7LU80sKQFhLX5Xo3SOzUO2lHYT72KhLGKq1aLdhEWtNQtsZ uIG5IOcOEYZmIasS+V2maF+q4bsbu6zJw= X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43675314" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 05/17] tools/ocaml/xenstored: add binary dump format support Date: Tue, 11 May 2021 19:05:18 +0100 Message-ID: X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) Do not dump -1, it'll trigger an assertion, use 0xFF.. instead. Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/xenstored/connection.ml | 63 +++++++++++++++++++++-------- tools/ocaml/xenstored/disk.ml | 3 +- 2 files changed, 49 insertions(+), 17 deletions(-) diff --git a/tools/ocaml/xenstored/connection.ml b/tools/ocaml/xenstored/co= nnection.ml index 65f99ea6f2..7a894a2eb1 100644 --- a/tools/ocaml/xenstored/connection.ml +++ b/tools/ocaml/xenstored/connection.ml @@ -17,6 +17,7 @@ exception End_of_file =20 open Stdext +module LR =3D Disk.LiveRecord =20 let xenstore_payload_max =3D 4096 (* xen/include/public/io/xs_wire.h *) =20 @@ -77,6 +78,10 @@ let number_of_transactions con =3D =20 let get_domain con =3D con.dom =20 +let get_id con =3D match con.dom with +| None -> 2*LR.domid_invalid + con.anonid +| Some dom -> 1 + Domain.get_id dom + let anon_id_next =3D ref 1 =20 let get_domstr con =3D @@ -278,6 +283,9 @@ let end_transaction con tid commit =3D let get_transaction con tid =3D Hashtbl.find con.transactions tid =20 +let iter_transactions con f =3D + Hashtbl.iter f con.transactions + let do_input con =3D Xenbus.Xb.input con.xb let has_input con =3D Xenbus.Xb.has_in_packet con.xb let has_partial_input con =3D match con.xb.Xenbus.Xb.partial_in with @@ -336,22 +344,45 @@ let incr_ops con =3D con.stat_nb_ops <- con.stat_nb_o= ps + 1 let stats con =3D Hashtbl.length con.watches, con.stat_nb_ops =20 -let dump con chan =3D - let id =3D match con.dom with - | Some dom -> - let domid =3D Domain.get_id dom in - (* dump domain *) - Domain.dump dom chan; - domid - | None -> - let fd =3D con |> get_fd |> Utils.FD.to_int in - Printf.fprintf chan "socket,%d\n" fd; - -fd - in - (* dump watches *) - List.iter (fun (path, token) -> - Printf.fprintf chan "watch,%d,%s,%s\n" id (Utils.hexify path) (Utils.hex= ify token) - ) (list_watches con) +let serialize_pkt_in buf xb =3D + let open Xenbus.Xb in + Queue.iter (fun p -> Buffer.add_string buf (Packet.to_string p)) xb.pkt_i= n; + match xb.partial_in with + | NoHdr (to_read, hdrb) -> + (* see Xb.input *) + let used =3D Xenbus.Partial.header_size () - to_read in + Buffer.add_subbytes buf hdrb 0 used + | HaveHdr p -> + p |> Packet.of_partialpkt |> Packet.to_string |> Buffer.add_string buf + +let serialize_pkt_out buf xb =3D + let open Xenbus.Xb in + Buffer.add_string buf xb.partial_out; + Queue.iter (fun p -> Buffer.add_string buf (Packet.to_string p)) xb.pkt_o= ut + +let dump con store chan =3D + let conid =3D get_id con in + let conn =3D match con.dom with + | None -> LR.Socket (get_fd con) + | Some dom -> LR.Domain { + id =3D Domain.get_id dom; + target =3D LR.domid_invalid; (* TODO: we do not store this info *) + remote_port =3D Domain.get_remote_port dom + } in + let pkt_in =3D Buffer.create 4096 in + let pkt_out =3D Buffer.create 4096 in + serialize_pkt_in pkt_in con.xb; + serialize_pkt_out pkt_out con.xb; + LR.write_connection_data chan ~conid ~conn pkt_in con.xb.partial_out pkt= _out; + + con |> list_watches + |> List.rev (* preserve order in dump/reload *) + |> List.iter (fun (wpath, token) -> + LR.write_watch_data chan ~conid ~wpath ~token + ); + let conpath =3D get_path con in + iter_transactions con (fun _ txn -> + Transaction.dump store conpath ~conid txn chan) =20 let debug con =3D let domid =3D get_domstr con in diff --git a/tools/ocaml/xenstored/disk.ml b/tools/ocaml/xenstored/disk.ml index 595fdab54a..59794324e1 100644 --- a/tools/ocaml/xenstored/disk.ml +++ b/tools/ocaml/xenstored/disk.ml @@ -292,7 +292,8 @@ module LiveRecord =3D struct let write_global_data t ~rw_sock =3D write_record t Type.global_data 8 @@ fun b -> O.w32 b (FD.to_int rw_sock); - O.w32 b (-1) + (* TODO: this needs a unit test/live update test too! *) + O.w32 b 0xFFFF_FFFF =20 let read_global_data t ~len f =3D read_expect t "global_data" 8 len; --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620756453; cv=none; d=zohomail.com; s=zohoarc; b=bdRK+XJDY/01A9X0Dppm05tshgxliryL8sKIvdz9Ei2SFhHxHri6yGjArDBde0AdXn2SznP9h/kCVAikuShT1/itS6/y0BGw/sEDun+vQTrQUWR/JhodChyMYpwmHoSsteJzJl1S0LAA13R14T4cB+TnmGp/Hp5cGUFxOKQHgik= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620756453; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=VNMQc/PJEwWZnos7YvOsJtyWreSlRt/gjViOJencBpk=; b=YgYecl1zpniDp68U6x3tJPkn7VCvUQGLH9fvC+qWNRc+sY57tmivN8nv0/6cXKUpXBMUTs6mV17ArKBSRs1XKvWI5GDhALIwkCXNJKeT3TBYqwsp4mfC7r4f/K/+TnIhLRHKKkzHIHZeRSB4SNLYNzGeSDfDRTzONh/XqtIKUX0= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620756453978769.0298784904418; Tue, 11 May 2021 11:07:33 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125903.237037 (Exim 4.92) (envelope-from ) id 1lgWmo-0002Sp-OW; Tue, 11 May 2021 18:07:14 +0000 Received: by outflank-mailman (output) from mailman id 125903.237037; Tue, 11 May 2021 18:07:14 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmo-0002Sg-KK; Tue, 11 May 2021 18:07:14 +0000 Received: by outflank-mailman (input) for mailman id 125903; Tue, 11 May 2021 18:07:13 +0000 Received: from us1-rack-iad1.inumbo.com ([172.99.69.81]) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmn-0000hb-QA for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:07:13 +0000 Received: from esa1.hc3370-68.iphmx.com (unknown [216.71.145.142]) by us1-rack-iad1.inumbo.com (Halon) with ESMTPS id 26ebaf9d-3570-4e7d-92e8-e3ca2c9b182f; Tue, 11 May 2021 18:07:00 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 26ebaf9d-3570-4e7d-92e8-e3ca2c9b182f DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620756419; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=leCiJnwy6SsPHaP/NXfEhVjwwDD8mhaCyeX0SGCr7Vg=; b=bgXd0rvqL6y/C8IoIylLZc1P2NhbaAJ5Rz8DU9ETNX5V8i4v4kx2Ruic +Cm4f+r70GetafWRv8eMX4gua91Or3hKHir8TgmrbsGnN6kmQIO+khstR aSykWASmueZtVx1Rpbndc2B1FNL2w/+JdH2KclLYDJH1ZvNGPtaW/O/H8 E=; Authentication-Results: esa1.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: ZzyOP/FQWeaVFS2+bnyM/30umDnoi1SJO3xpblwGzLyuHQW+Ojbj6/KwFP8dNHU7TuxYME0yzK 9CYxYQnXlRCoGfvf4S31CzNXZKQp0nDcLJ/0WHEuCYnSgzOY1KJRJ2Rg/pgJHrr4Z7IMLUMnS2 OKH3xeUB2tULtoTr0ry1j+fHJJ4x4vNDmZaPIa4UuMuwKxf3rqIYyHRi9hkHdJv8edy2NNbkG8 OKlwsV8Hr56BGTTv3fLLzl7G41pW03FlyLsmxoVWCLhzRFSqJaglOy0i9DU9JYnIjscvduaoS7 +jY= X-SBRS: 5.1 X-MesageID: 43954245 X-Ironport-Server: esa1.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:Y69OrKo8o7U7lY6P+EqWbLcaV5oReYIsimQD101hICG8cqSj9v xG+85rrSMc6QxhIU3I9urwW5VoLUmyyXcx2/h0AV7AZniBhILLFvAB0WKK+VSJcEeSmtK1l5 0QFJSWYOeAdmSS5vyb3ODXKbgdKaG8gcWVuds= X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43954245" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 06/17] tools/ocaml/xenstored: add support for binary format Date: Tue, 11 May 2021 19:05:19 +0100 Message-ID: X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) oxenstored already had support for loading a partial dump from a text forma= t. Add support for the binary format too. We no longer dump the text format, but we support loading the text format f= or backwards compatibility purposes. (a version of oxenstored supporting live-update with the old text format ha= s been released as part of the security series) Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/xenstored/perms.ml | 2 + tools/ocaml/xenstored/xenstored.ml | 202 ++++++++++++++++++++++++----- 2 files changed, 174 insertions(+), 30 deletions(-) diff --git a/tools/ocaml/xenstored/perms.ml b/tools/ocaml/xenstored/perms.ml index e8a16221f8..61c1c60083 100644 --- a/tools/ocaml/xenstored/perms.ml +++ b/tools/ocaml/xenstored/perms.ml @@ -69,6 +69,8 @@ let remove_domid ~domid perm =3D =20 let default0 =3D create 0 NONE [] =20 +let acls t =3D (t.owner, t.other) :: t.acl + let perm_of_string s =3D let ty =3D permty_of_char s.[0] and id =3D int_of_string (String.sub s 1 (String.length s - 1)) in diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xen= stored.ml index ae2eab498a..2aa0dbc0e1 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -141,7 +141,8 @@ exception Bad_format of string =20 let dump_format_header =3D "$xenstored-dump-format" =20 -let from_channel_f chan global_f socket_f domain_f watch_f store_f =3D +(* for backwards compatibility with already released live-update *) +let from_channel_f_compat chan global_f socket_f domain_f watch_f store_f = =3D let unhexify s =3D Utils.unhexify s in let getpath s =3D let u =3D Utils.unhexify s in @@ -186,7 +187,7 @@ let from_channel_f chan global_f socket_f domain_f watc= h_f store_f =3D done; info "Completed loading xenstore dump" =20 -let from_channel store cons doms chan =3D +let from_channel_compat ~live store cons doms chan =3D (* don't let the permission get on our way, full perm ! *) let op =3D Store.get_ops store Perms.Connection.full_rights in let rwro =3D ref (None) in @@ -226,43 +227,183 @@ let from_channel store cons doms chan =3D op.Store.write path value; op.Store.setperms path perms in - from_channel_f chan global_f socket_f domain_f watch_f store_f; + from_channel_f_compat chan global_f socket_f domain_f watch_f store_f; !rwro =20 -let from_file store cons doms file =3D - info "Loading xenstore dump from %s" file; - let channel =3D open_in file in - finally (fun () -> from_channel store doms cons channel) +module LR =3D Disk.LiveRecord + +let from_channel_f_bin chan on_global_data on_connection_data on_watch_dat= a on_transaction_data on_node_data =3D + Disk.BinaryIn.read_header chan; + let quit =3D ref false in + let on_end () =3D quit :=3D true in + let errors =3D ref 0 in + while not !quit + do + try + LR.read_record chan ~on_end ~on_global_data ~on_connection_data ~on_wat= ch_data ~on_transaction_data ~on_node_data + with exn -> + let bt =3D Printexc.get_backtrace () in + incr errors; + Logging.warn "xenstored" "restoring: ignoring faulty record (exception:= %s): %s" (Printexc.to_string exn) bt + done; + info "Completed loading xenstore dump"; + !errors + + +let from_channel_bin ~live store cons doms chan =3D + (* don't let the permission get on our way, full perm ! *) + let maintx =3D Transaction.make ~internal:true Transaction.none store in + let fullperm =3D Perms.Connection.full_rights in + let fds =3D ref None in + let allcons =3D Hashtbl.create 1021 in + let contxid_to_op =3D Hashtbl.create 1021 in + let global_f ~rw_sock =3D + (* file descriptors are only valid on a live-reload, a cold restart won'= t have them *) + if live then + fds :=3D Some rw_sock + in + let domain_f ~conid ~conn ~in_data ~out_data ~out_resp_len =3D + let con =3D match conn with + | LR.Domain { LR.id =3D 0; _ } -> + (* Dom0 is precreated *) + Connections.find_domain cons 0 + | LR.Domain d -> + debug "Recreating domain %d, port %d" d.id d.remote_port;=20 + (* FIXME: gnttab *) + Domains.create doms d.id 0n d.remote_port + |> Connections.add_domain cons; + Connections.find_domain cons d.id + | LR.Socket fd -> + debug "Recreating open socket"; + (* TODO: rw/ro flag *) + Connections.add_anonymous cons fd; + Connections.find cons fd + in + Hashtbl.add allcons conid con + in + let watch_f ~conid ~wpath ~token =3D + let con =3D Hashtbl.find allcons conid in + ignore (Connections.add_watch cons con wpath token); + () + in + let transaction_f ~conid ~txid =3D + let con =3D Hashtbl.find allcons conid in + con.Connection.next_tid <- txid; + let id =3D Connection.start_transaction con store in + assert (id =3D txid); + let txn =3D Connection.get_transaction con txid in + Hashtbl.add contxid_to_op (conid, txid) txn + in + let store_f ~txaccess ~perms ~path ~value =3D + let txn, op =3D match txaccess with + | None -> maintx, LR.W + | Some (conid, txid, op) -> + let (txn, _) as r =3D Hashtbl.find contxid_to_op (conid, txid), op in + (* make sure this doesn't commit, even as RO *) + Transaction.mark_failed txn; + r + in + let get_con id =3D + if id < 0 then Connections.find cons (Utils.FD.of_int (-id)) + else Connections.find_domain cons id + in + let watch_f id path token =3D + ignore (Connections.add_watch cons (get_con id) path token) + in + let path =3D Store.Path.of_string path in + try match op with + | LR.R -> + Logging.debug "xenstored" "TR %s %S" (Store.Path.to_string path) value; + (* these are values read by the tx, potentially + no write access here. Make the tree match. *) + Transaction.write txn fullperm path value;=20 + Transaction.setperms txn fullperm path perms; + | LR.W | LR.RW -> + Logging.debug "xenstored" "TW %d %s %S" (Transaction.get_id txn) (Stor= e.Path.to_string path) value; + (* We started with empty tree, create parents. + All the implicit mkdirs from the original tx should be explicit alr= eady for quota purposes. + *) + Process.create_implicit_path txn fullperm path; + Transaction.write txn fullperm path value;=20 + Transaction.setperms txn fullperm path perms; + Logging.debug "xenstored" "TWdone %s %S" (Store.Path.to_string path) v= alue; + | LR.Del -> + Logging.debug "xenstored" "TDel %s " (Store.Path.to_string path); + Transaction.rm txn fullperm path + with Not_found|Define.Doesnt_exist|Define.Lookup_Doesnt_exist _ -> () + in + (* make sure we got a quota entry for Dom0, so that setperms on / doesn't= cause quota to be off-by-one *) + Transaction.mkdir maintx fullperm (Store.Path.of_string "/local"); + let errors =3D from_channel_f_bin chan global_f domain_f watch_f transact= ion_f store_f in + (* do not fire any watches, but this makes a tx RO *) +(* Transaction.clear_wops maintx; *) + let errors =3D if not @@ Transaction.commit ~con:"live-update" maintx the= n begin + Logging.warn "xenstored" "live-update: failed to commit main transaction= "; + errors + 1 + end else errors + in + !fds, errors + +let from_channel =3D from_channel_bin (* TODO: detect and accept text form= at *) + +let from_file ~live store cons doms file =3D + let channel =3D open_in_bin file in + finally (fun () -> from_channel_bin ~live store doms cons channel) (fun () -> close_in channel) =20 -let to_channel store cons rw chan =3D - let hexify s =3D Utils.hexify s in +let to_channel rw_sock store cons chan =3D + let t =3D Disk.BinaryOut.write_header chan in =20 - fprintf chan "%s\n" dump_format_header; - let fdopt =3D function None -> -1 | Some fd -> - (* systemd and utils.ml sets it close on exec *) - Unix.clear_close_on_exec fd; - Utils.FD.to_int fd in - fprintf chan "global,%d\n" (fdopt rw); - - (* dump connections related to domains: domid, mfn, eventchn port/ socket= s, and watches *) - Connections.iter cons (fun con -> Connection.dump con chan); + (match rw_sock with + | Some rw_sock -> + LR.write_global_data t ~rw_sock + | _ -> ()); =20 (* dump the store *) Store.dump_fct store (fun path node -> - let name, perms, value =3D Store.Node.unpack node in - let fullpath =3D Store.Path.to_string (Store.Path.of_path_and_name path = name) in - let permstr =3D Perms.Node.to_string perms in - fprintf chan "store,%s,%s,%s\n" (hexify fullpath) (hexify permstr) (hexi= fy value) + Transaction.write_node t None path node ); + + (* dump connections related to domains and sockets; domid, mfn, eventchn = port, watches *) + Connections.iter cons (fun con -> Connection.dump con store t); + + LR.write_end t; flush chan; () =20 +let validate_f ch =3D + let conids =3D Hashtbl.create 1021 in + let txids =3D Hashtbl.create 1021 in + let global_f ~rw_sock =3D () in + let domain_f ~conid ~conn ~in_data ~out_data ~out_resp_len =3D + Hashtbl.add conids conid () + in + let watch_f ~conid ~wpath ~token =3D + Hashtbl.find conids conid + in + let transaction_f ~conid ~txid =3D + Hashtbl.find conids conid; + Hashtbl.add txids (conid, txid) () + in=20 + let store_f ~txaccess ~perms ~path ~value =3D + match txaccess with + | None -> () + | Some (conid, txid, _) -> + Hashtbl.find conids conid; + Hashtbl.find txids (conid, txid) + in + let errors =3D from_channel_f_bin ch global_f domain_f watch_f transactio= n_f store_f in + if errors > 0 then + failwith (Printf.sprintf "Failed to re-read dump: %d errors" errors) =20 -let to_file store cons fds file =3D - let channel =3D open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] 0o6= 00 file in - finally (fun () -> to_channel store cons fds channel) - (fun () -> close_out channel) +let to_file fds store cons file =3D + let channel =3D open_out_gen [ Open_wronly; Open_creat; Open_trunc; Open_= binary ] 0o600 file in + finally (fun () -> to_channel fds store cons channel) + (fun () -> close_out channel); + let channel =3D open_in_bin file in + finally (fun () -> validate_f channel) + (fun () -> close_in channel) +=09 end =20 let main () =3D @@ -329,8 +470,9 @@ let main () =3D =20 let rw_sock =3D if cf.restart && Sys.file_exists Disk.xs_daemon_database then ( - let rwro =3D DB.from_file store domains cons Disk.xs_daemon_database in - info "Live reload: database loaded"; + Connections.add_domain cons (Domains.create0 domains); + let rwro, errors =3D DB.from_file ~live:cf.live_reload store domains con= s Disk.xs_daemon_database in + info "Live reload: database loaded (%d errors)" errors; Event.bind_dom_exc_virq eventchn; Process.LiveUpdate.completed (); rwro @@ -360,7 +502,7 @@ let main () =3D Sys.set_signal Sys.sigpipe Sys.Signal_ignore; =20 if cf.activate_access_log then begin - let post_rotate () =3D DB.to_file store cons (None) Disk.xs_daemon_datab= ase in + let post_rotate () =3D DB.to_file None store cons Disk.xs_daemon_databas= e in Logging.init_access_log post_rotate end; =20 @@ -521,7 +663,7 @@ let main () =3D live_update :=3D Process.LiveUpdate.should_run cons; if !live_update || !quit then begin (* don't initiate live update if saving state fails *) - DB.to_file store cons (rw_sock) Disk.xs_daemon_database; + DB.to_file rw_sock store cons Disk.xs_daemon_database; quit :=3D true; end with exc -> --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620756456; cv=none; d=zohomail.com; s=zohoarc; b=aUyO731d6j/WjSVZbi3A+wWfOjqdfdIiYF8MJE1ZDvj65zQ3Hb2g7at4+2qPwyMneOuSL0TkkVL+gDWzrlf285taTi7AlvXoOQc7Mi2ZBOrJz5aLV3QYpdaas5+rSlKGtkVtu/49bamgNVknfSlo7DpaZOeUH2EyVkK7UBvnRz8= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620756456; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=3utvrb3NeUVS0Y4ZwE9lUeEpIUJ+0tlwmh9NC8YSv8s=; b=XWSZtJs8Vy5i58onXKlrSuv/AvrV58N1FyDdxlWse0LfloXF9YVR9EStG8LGzKDRUy2vKaQlPQAu52Cc/RI7vyTyWBPYBpskuhJfVcNRwF6SYfT5QvhYHQBHNSFn3E4MpWNYoRno8g83ViOz79OPHJJt54kJXQsvgj+phd9lqsQ= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620756456063108.03405533128898; Tue, 11 May 2021 11:07:36 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125909.237061 (Exim 4.92) (envelope-from ) id 1lgWmv-0003I9-Od; Tue, 11 May 2021 18:07:21 +0000 Received: by outflank-mailman (output) from mailman id 125909.237061; Tue, 11 May 2021 18:07:21 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmv-0003Ge-Kz; Tue, 11 May 2021 18:07:21 +0000 Received: by outflank-mailman (input) for mailman id 125909; Tue, 11 May 2021 18:07:20 +0000 Received: from all-amaz-eas1.inumbo.com ([34.197.232.57] helo=us1-amaz-eas2.inumbo.com) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmu-0001nY-DX for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:07:20 +0000 Received: from esa4.hc3370-68.iphmx.com (unknown [216.71.155.144]) by us1-amaz-eas2.inumbo.com (Halon) with ESMTPS id 6f8c4a83-831a-40ed-8f89-f3d2965861df; Tue, 11 May 2021 18:07:10 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 6f8c4a83-831a-40ed-8f89-f3d2965861df DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620756430; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=p0W19jtbXsU+HwGFf/dzsvYLrPw4HfB2Wm1ke3VJSTU=; b=dQMd3S3Sh1uwjZz11L+p0WZJChMX7GaGF7J6k85HWSKjfLzhEFGL5iRL Yo2pTQXXwISgXE6xH9onF5WBFRWYXD/O05R2T/mMB08JTlo4PKp92qirt kR5CB9AWLI4Mm1J6taOI84LMctdfsxRnGVQuOSk2h0nTTgEepL4D5dMTO 4=; Authentication-Results: esa4.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: kFob7Ev9G9Y0/Z94owD+Jbmq1srgk7MQRmvTxVjkheEbgfYfIYGrsES29esGjpru6VOo6Ms2Fj hnpvqhiBExUTY88zyv6g5xoAf2Ub94Y3+Olbbof+howte6Bx1X63++ZmL48iyZq5Eo8ATVkWIT +HrnHtJsz+KmkrHR+F/ShE9BNc5cP1J/6P9zyYSSt+w3QgHlhR0SNjy7MKIKQGdoCS0obasASc 5M1yS0iVLBq+bCSgZr4ujmoj5A7RpVUqrdLvyGRCixyUsy+XEDekU8jYHQ2C4c9FoOeZWXeeor b7Y= X-SBRS: 5.1 X-MesageID: 45101013 X-Ironport-Server: esa4.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:jrcCBa6OcVqvAPVt+QPXwPDXdLJyesId70hD6qhwISY6TiX+rb HWoB17726TtN9/YhEdcLy7VJVoBEmskKKdgrNhWotKPjOW21dARbsKheCJrgEIWReOktK1vZ 0QC5SWY+eQMbEVt6nHCXGDYrQd/OU= X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="45101013" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 07/17] tools/ocaml/xenstored: validate config file before live update Date: Tue, 11 May 2021 19:05:20 +0100 Message-ID: X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) The configuration file can contain typos or various errors that could preve= nt live update from succeeding (e.g. a flag only valid on a different version). Unknown entries in the config file would be ignored on startup normally, add a strict --config-test that live-update can use to check that the confi= g file is valid *for the new binary*. Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/xenstored/parse_arg.ml | 4 ++++ tools/ocaml/xenstored/process.ml | 2 +- tools/ocaml/xenstored/xenstored.ml | 9 +++++++-- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/tools/ocaml/xenstored/parse_arg.ml b/tools/ocaml/xenstored/par= se_arg.ml index 965cb9ebeb..588970825f 100644 --- a/tools/ocaml/xenstored/parse_arg.ml +++ b/tools/ocaml/xenstored/parse_arg.ml @@ -26,6 +26,7 @@ type config =3D restart: bool; live_reload: bool; disable_socket: bool; + config_test: bool; } =20 let do_argv () =3D @@ -38,6 +39,7 @@ let do_argv () =3D and restart =3D ref false and live_reload =3D ref false and disable_socket =3D ref false + and config_test =3D ref false in =20 let speclist =3D @@ -55,6 +57,7 @@ let do_argv () =3D ("-T", Arg.Set_string tracefile, ""); (* for compatibility *) ("--restart", Arg.Set restart, "Read database on starting"); ("--live", Arg.Set live_reload, "Read live dump on startup"); + ("--config-test", Arg.Set config_test, "Test validity of config file"); ("--disable-socket", Arg.Unit (fun () -> disable_socket :=3D true), "D= isable socket"); ] in let usage_msg =3D "usage : xenstored [--config-file ] [--no-dom= ain-init] [--help] [--no-fork] [--reraise-top-level] [--restart] [--disable= -socket]" in @@ -70,4 +73,5 @@ let do_argv () =3D restart =3D !restart; live_reload =3D !live_reload; disable_socket =3D !disable_socket; + config_test =3D !config_test; } diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/proce= ss.ml index 27790d4a5c..d573c88685 100644 --- a/tools/ocaml/xenstored/process.ml +++ b/tools/ocaml/xenstored/process.ml @@ -121,7 +121,7 @@ let launch_exn t =3D =20 let validate_exn t =3D (* --help must be last to check validity of earlier arguments *) - let t' =3D {t with cmdline=3D t.cmdline @ ["--help"]} in + let t' =3D {t with cmdline=3D t.cmdline @ ["--config-test"]} in let cmd =3D string_of_t t' in debug "Executing %s" cmd ; match Unix.fork () with diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xen= stored.ml index 2aa0dbc0e1..34e706910e 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -88,7 +88,7 @@ let default_pidfile =3D Paths.xen_run_dir ^ "/xenstored.p= id" =20 let ring_scan_interval =3D ref 20 =20 -let parse_config filename =3D +let parse_config ?(strict=3Dfalse) filename =3D let pidfile =3D ref default_pidfile in let options =3D [ ("merge-activate", Config.Set_bool Transaction.do_coalesce); @@ -126,11 +126,12 @@ let parse_config filename =3D ("xenstored-port", Config.Set_string Domains.xenstored_port); ] in begin try Config.read filename options (fun _ _ -> raise Not_found) with - | Config.Error err -> List.iter (fun (k, e) -> + | Config.Error err as e -> List.iter (fun (k, e) -> match e with | "unknown key" -> eprintf "config: unknown key %s\n" k | _ -> eprintf "config: %s: %s\n" k e ) err; + if strict then raise e | Sys_error m -> eprintf "error: config: %s\n" m; end; !pidfile @@ -408,6 +409,10 @@ end =20 let main () =3D let cf =3D do_argv () in + if cf.config_test then begin + let _pidfile:string =3D parse_config ~strict:true (config_filename cf) = in + exit 0 + end; let pidfile =3D if Sys.file_exists (config_filename cf) then parse_config (config_filename cf) --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620756453; cv=none; d=zohomail.com; s=zohoarc; b=Dl1KHFqrTuH3OrC31lrQrDGMt6SoYNuT0JO+MmlCSLVWPkhD9RRgIjYHri8VN49cywUEU/sfxK02ao46HMU5sfNJouyeKiCHuhzM7DiQVTEthS8pUAq87DB/72ykrB10kPY/zk0pZRNU7hZXolqlYwXUclMarVpiHVyPjCZkzKc= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620756453; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=M6Om0zik6wsFaJKSuF7n0cGUF5K5yBhQTMlCUuOcgxU=; b=AEEyFOQqhoFHugpth+zaNaJksL7P5igKAE1+j04w89iExIVpR076QmfrAHDABcMBKLDg6GyTa2crnZbK1VJJYXCvwq51nOTRxWicnMjmCozfZbXptxPYehc89/VhI7d4AY4LZtIrbk4rzN5zXbCxS6quen8LFyTp/qB3JWLd/7M= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620756453048408.96187827572953; Tue, 11 May 2021 11:07:33 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125902.237025 (Exim 4.92) (envelope-from ) id 1lgWmm-00026S-8H; Tue, 11 May 2021 18:07:12 +0000 Received: by outflank-mailman (output) from mailman id 125902.237025; Tue, 11 May 2021 18:07:12 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmm-00026F-3b; Tue, 11 May 2021 18:07:12 +0000 Received: by outflank-mailman (input) for mailman id 125902; Tue, 11 May 2021 18:07:10 +0000 Received: from all-amaz-eas1.inumbo.com ([34.197.232.57] helo=us1-amaz-eas2.inumbo.com) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmk-0001nY-Ej for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:07:10 +0000 Received: from esa4.hc3370-68.iphmx.com (unknown [216.71.155.144]) by us1-amaz-eas2.inumbo.com (Halon) with ESMTPS id f6ea6f30-41ac-4d6b-8f96-044bd00ac273; Tue, 11 May 2021 18:07:07 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: f6ea6f30-41ac-4d6b-8f96-044bd00ac273 DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620756427; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=7RVILLnjZIWgrnPBH52virpLPiH5emkE0QnosYt8EPU=; b=TKAvB5HF3vTRtiVKe2bIvqSPf0WnQwumqf6Hswy6V553XaUKNenbZjy8 H4FBtYmY1fDJ8HXqD6EKlnUphSagHP6+FJTifZrFI62AJLJUNrAuf2mWK o8+Jli/CleY4dmQAYneCqrhONIaTdWuYaHG2N8Kybwg+6e5CHUkQwCAJ2 c=; Authentication-Results: esa4.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: LOuE82vKbi49458eLw7TL0Ke43U6+ZNj/8Bqz/NrLuYslddHdwtEr9X2Jjrf/Kf3vLPTLc/vcV VSw/S1egbUjyZhq/UIFA0seJ8U+xmVH9wzjBAY+85JFcU1gfaGSwRdgQitwXgfvLsmeSoc6a5O oonX0QBAkMQOf/OsfTDWRRALN+mTeCMn8eppPeSCKQVdfa8VAVsNWJKWzb3g+1VyO3cmZIhfq3 PKouk2YEZW4RkXOyth9FFXylEVhbBjvMdcXzJz0vTPT63x2KPYzxTfAPrSsncAEV442IOcINMg 2tM= X-SBRS: 5.1 X-MesageID: 45101007 X-Ironport-Server: esa4.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:4ccXnqyt8H0/fsNrTgiqKrPwFr1zdoMgy1knxilNoRw8SK2lfq eV7YwmPH7P+U8ssR4b6LO90cW7Lk80sKQFhbX5Xo3SOjUO2lHYTr2KhLGKq1aLdkHDH6xmpM BdmsBFeabN5DNB7foSjjPXLz9Z+qjjzJyV X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="45101007" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 08/17] Add structured fuzzing unit test Date: Tue, 11 May 2021 19:05:21 +0100 Message-ID: X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) Based on ideas from qcstm, implemented using Crowbar. Quickcheck-style property tests that uses AFL for quickly exploring various values that trigger bugs in the code. This is structured/guided fuzzing: we read an arbitrary random number, and use it to generate some valid looking xenstore trees and commands. There are 2 instances of xenstored: one that runs the live update command, and one that ignores it. Live-update should be a no-op wrt to xenstored state: this is our quicheck property. When any mismatch is identified it prints the input (tree+xenstore commands), and a diff of the output: the internal xenstore tree state + quotas. afl-cmin can be used to further minimize the testcase. Crowbar (AFL persistent mode Quickcheck integration) is used due to speed: this very easily gets us a multi-core parallelizable test. Currently the Transaction tests fail, which is why live updates with active transactions are rejected. These tests are commented out. There is also some incomplete code here that attempts to find functional bugs in xenstored by interpeting xenstore commands in a simpler way and comparing states. This will build the fuzzer and run it single core for sanity test: make container-fuzz-sanity-test This will run it multicore (requires all dependencies installed on the host, including ocaml-bun, the multi-core AFL runner): make dune-oxenstored-fuzz 'make check' will also run the fuzzer but with input supplied by OCaml's random number generator, and for a very small number of iterations (few thousand). This doesn't require any external tools (no AFL, bun). On failure it prints a base64 encoding of the fuzzer state that can be used to reproduce the failure instantly, which is very useful for debugging: one can iterate on the failed fuzzer state until it is fixed, and then run the fuzzer again to find next failure. The unit tests here require OCaml 4.06, but the rest of the codebase doesn't (yet). See https://lore.kernel.org/xen-devel/cbb2742191e9c1303fdfd95feef4d829ecf33= a0d.camel@citrix.com/ for previous discussion of OCaml version. Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/Makefile | 19 + tools/ocaml/xenstored/process.ml | 12 +- tools/ocaml/xenstored/store.ml | 1 + tools/ocaml/xenstored/test/dune | 12 + tools/ocaml/xenstored/test/generator.ml | 189 +++++ tools/ocaml/xenstored/test/model.ml | 253 ++++++ tools/ocaml/xenstored/test/old/arbitrary.ml | 261 +++++++ tools/ocaml/xenstored/test/old/gen_paths.ml | 66 ++ .../xenstored/test/old/xenstored_test.ml | 527 +++++++++++++ tools/ocaml/xenstored/test/pathtree.ml | 40 + tools/ocaml/xenstored/test/testable.ml | 379 +++++++++ tools/ocaml/xenstored/test/types.ml | 437 +++++++++++ tools/ocaml/xenstored/test/xenstored_test.ml | 149 +++- tools/ocaml/xenstored/test/xs_protocol.ml | 733 ++++++++++++++++++ tools/ocaml/xenstored/transaction.ml | 119 ++- 15 files changed, 3188 insertions(+), 9 deletions(-) create mode 100644 tools/ocaml/xenstored/test/generator.ml create mode 100644 tools/ocaml/xenstored/test/model.ml create mode 100644 tools/ocaml/xenstored/test/old/arbitrary.ml create mode 100644 tools/ocaml/xenstored/test/old/gen_paths.ml create mode 100644 tools/ocaml/xenstored/test/old/xenstored_test.ml create mode 100644 tools/ocaml/xenstored/test/pathtree.ml create mode 100644 tools/ocaml/xenstored/test/testable.ml create mode 100644 tools/ocaml/xenstored/test/types.ml create mode 100644 tools/ocaml/xenstored/test/xs_protocol.ml diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile index 53dd0a0f0d..de375820a3 100644 --- a/tools/ocaml/Makefile +++ b/tools/ocaml/Makefile @@ -67,3 +67,22 @@ dune-syntax-check: dune-pre .PHONY: build-oxenstored-dune dune-build-oxenstored: dune-pre LD_LIBRARY_PATH=3D$(LIBRARY_PATH) LIBRARY_PATH=3D$(LIBRARY_PATH) C_INCLUD= E_PATH=3D$(C_INCLUDE_PATH) dune build --profile=3Drelease @all + +.PHONY: oxenstored-fuzz1 oxenstored-fuzz +dune-oxenstored-fuzz: dune-pre + # --force is needed, otherwise it would cache a successful run + sh -c '. /etc/profile && C_INCLUDE_PATH=3D$(C_INCLUDE_PATH) dune build --= profile=3Drelease --no-buffer --force @fuzz' + +dune-oxenstored-fuzz1: dune-pre + sh -c '. /etc/profile && C_INCLUDE_PATH=3D$(C_INCLUDE_PATH) dune build --= profile=3Drelease --no-buffer --force @fuzz1' + +.PHONY: container-fuzz +container-fuzz-sanity-test: + dune clean + podman build -t oxenstored-fuzz . + # if UID is 0 then we get EPERM on setrlimit from inside the container + # use containerize script which ensures that uid is not 0 + # (podman/docker run would get us a uid of 0) + # Only do a sanity test with 1 core, actually doing fuzzing inside a cont= ainer is a bad idea + # due to FUSE overlayfs overhead + CONTAINER=3Doxenstored-fuzz CONTAINER_NO_PULL=3D1 DOCKER_CMD=3Dpodman ../= ../automation/scripts/containerize make -C tools/ocaml dune-oxenstored-fuzz1 diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/proce= ss.ml index d573c88685..13b7153536 100644 --- a/tools/ocaml/xenstored/process.ml +++ b/tools/ocaml/xenstored/process.ml @@ -169,7 +169,7 @@ let parse_live_update args =3D ] (fun x -> raise (Arg.Bad x)) "live-update -s" ; - debug "Live update process queued" ; + (* debug "Live update process queued" ; *) {!state with deadline =3D Unix.gettimeofday () +. float !timeout ; force=3D !force; pending=3D true}) | _ -> @@ -449,6 +449,8 @@ let transaction_replay c t doms cons =3D (fun () -> try Logging.start_transaction ~con ~tid; + if t.must_fail then + raise Transaction_again; List.iter (perform_exn ~wlog:true replay_t) (Transaction.get_operation= s t); (* May throw EAGAIN *) =20 Logging.end_transaction ~con ~tid; @@ -550,7 +552,7 @@ let do_introduce con t domains cons data =3D | _ -> raise Invalid_Cmd_Args; in let dom =3D - if Domains.exist domains domid then + if Domains.exist domains domid then begin let edom =3D Domains.find domains domid in if (Domain.get_mfn edom) =3D mfn && (Connections.find_domain cons domid= ) !=3D con then begin (* Use XS_INTRODUCE for recreating the xenbus event-channel. *) @@ -558,12 +560,16 @@ let do_introduce con t domains cons data =3D Domain.bind_interdomain edom; end; edom + end else try let ndom =3D Domains.create domains domid mfn port in Connections.add_domain cons ndom; Connections.fire_spec_watches (Transaction.get_root t) cons Store.Path.= introduce_domain; ndom - with _ -> raise Invalid_Cmd_Args + with e -> + let bt =3D Printexc.get_backtrace () in + Logging.debug "process" "do_introduce: %s (%s)" (Printexc.to_string e)= bt; + raise Invalid_Cmd_Args in if (Domain.get_remote_port dom) <> port || (Domain.get_mfn dom) <> mfn th= en raise Domain_not_match diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml index 20e67b1427..85ca3daae9 100644 --- a/tools/ocaml/xenstored/store.ml +++ b/tools/ocaml/xenstored/store.ml @@ -133,6 +133,7 @@ let of_path_and_name path name =3D | _ -> path @ [name] =20 let create path connection_path =3D + Logging.debug "store" "Path.create %S %S" path connection_path; of_string (Utils.path_validate path connection_path) =20 let to_string t =3D diff --git a/tools/ocaml/xenstored/test/dune b/tools/ocaml/xenstored/test/d= une index 2a3eb2b7df..cd62926be9 100644 --- a/tools/ocaml/xenstored/test/dune +++ b/tools/ocaml/xenstored/test/dune @@ -9,3 +9,15 @@ (flags (:standard -w -52)) ;;(action (run %{test} -v --seed 364172147)) (libraries unix xen.bus xen.mmap xenstubs crowbar xen.store fmt fmt.tty)) + +(rule +(alias fuzz1) +(deps xenstored_test.exe) +(action (run bun -svv ./xenstored_test.exe)) +) + +(rule +(alias fuzz) +(deps xenstored_test.exe) +(action (run bun --no-kill ./xenstored_test.exe)) +) diff --git a/tools/ocaml/xenstored/test/generator.ml b/tools/ocaml/xenstore= d/test/generator.ml new file mode 100644 index 0000000000..6f7dc374f8 --- /dev/null +++ b/tools/ocaml/xenstored/test/generator.ml @@ -0,0 +1,189 @@ +module type S =3D sig + type cmd + + type state + + val init_state : state + + val next_state : cmd -> state -> state + + val precond : cmd -> state -> bool +end + +module IntSet =3D Set.Make (Int) +module IntMap =3D Map.Make (Int) + +module Pickable (K : sig + include Map.OrderedType + + include Hashtbl.HashedType with type t :=3D t +end) =3D +struct + (* allow picking a random value from a changing map keys. + Store a random value (hash of key) as first element of key, + then use find_first to pick an item related to the random element if = any. + This should be more efficient than converting to a list and using Lis= t.nth to pick + *) + module Key =3D struct + type t =3D int * K.t + + let of_key k =3D (K.hash k, k) + + let compare (h, k) (h', k') =3D + match Int.compare h h' with 0 -> K.compare k k' | r -> r + end + + module M =3D Map.Make (Key) + + type 'a t =3D 'a M.t + + let empty =3D M.empty + + let singleton k v =3D M.singleton (Key.of_key k) v + + let add k v m =3D M.add (Key.of_key k) v m + + let find_opt k m =3D M.find_opt (Key.of_key k) m + + let mem k m =3D M.mem (Key.of_key k) m + + let remove k m =3D M.remove (Key.of_key k) m + + let merge f m m' =3D M.merge f m m' + + let is_empty =3D M.is_empty + + let update k f m =3D M.update (Key.of_key k) f m + + let choose rnd m =3D + (* function needs to be monotonic, so the hash has to be part of the k= ey *) + let gte (keyhash, _) =3D Int.compare keyhash rnd >=3D 0 in + match M.find_first_opt gte m with + | Some ((_, k), _) -> + k + | None -> + snd @@ fst @@ M.min_binding m +end + +module PickablePath =3D Pickable (struct + type t =3D string + + let hash =3D Hashtbl.hash + + let compare =3D String.compare + + let equal =3D String.equal +end) + +module PickableInt =3D Pickable (struct + include Int + + let hash =3D Hashtbl.hash +end) + +module PathObserver =3D struct + type state =3D + { seen: unit PickablePath.t + ; dom_txs: unit PickableInt.t PickableInt.t + ; next_tid: int } + + let choose_path t rnd =3D PickablePath.choose rnd t.seen + + let choose_domid t rnd =3D PickableInt.choose rnd t.dom_txs + + let choose_txid_opt t domid rnd =3D + match PickableInt.find_opt domid t.dom_txs with + | None -> + 0 + | Some txs -> + if PickableInt.is_empty txs then 0 else PickableInt.choose rnd txs + + let new_domid domid =3D PickableInt.singleton domid PickableInt.empty + + let both _ _ _ =3D Some () + + let merge_txs _ s s' =3D + let s =3D Option.value ~default:PickableInt.empty s in + let s' =3D Option.value ~default:PickableInt.empty s' in + Some (PickableInt.merge both s s') + + let init_state =3D + {seen=3D PickablePath.singleton "/" (); dom_txs=3D new_domid 0; next_t= id=3D 1} + + let with_path path t =3D {t with seen=3D PickablePath.add path () t.seen} + + let split0 str =3D + match Process.split (Some 2) '\000' str with + | [x; y] -> + (x, y) + | _ -> + invalid_arg str + + let next_state (domid, cmd) t =3D + let open Xenbus.Xb in + match cmd with + | {Xenbus.Packet.ty=3D Transaction_start; _} -> + let update =3D function + | None -> + None + | Some txs -> + Some (PickableInt.add t.next_tid () txs) + in + { t with + dom_txs=3D PickableInt.update domid update t.dom_txs + ; next_tid=3D t.next_tid + 1 } + | { Xenbus.Packet.ty=3D + Op.( + ( Rm + | Read + | Directory + | Getperms + | Setperms + | Unwatch + | Reset_watches + | Getdomainpath + | Isintroduced + | Set_target + | Debug )) + ; _ } -> + t + | {Xenbus.Packet.ty=3D Op.(Watchevent | Error | Resume | Invalid); _} = -> + assert false + | {Xenbus.Packet.ty=3D Op.Transaction_end; tid; _} -> + let update =3D function + | None -> + None + | Some txs -> + Some (PickableInt.remove tid txs) + in + {t with dom_txs=3D PickableInt.update domid update t.dom_txs} + | {Xenbus.Packet.ty=3D Op.(Write | Mkdir | Watch); data} -> + let path, _ =3D split0 data in + with_path path t + | {Xenbus.Packet.ty=3D Introduce; data} -> + let domidstr, _ =3D split0 data in + let domid' =3D int_of_string domidstr in + if domid =3D 0 then + { t with + dom_txs=3D PickableInt.merge merge_txs t.dom_txs (new_domid do= mid') } + else t + | {Xenbus.Packet.ty=3D Release; data} -> + let domidstr, _ =3D split0 data in + let domid =3D int_of_string domidstr in + {t with dom_txs=3D PickableInt.remove domid t.dom_txs} + + let precond (domid, cmd) t =3D + ( match PickableInt.find_opt domid t.dom_txs with + | None -> + false + | Some txs -> + let tid =3D cmd.Xenbus.Packet.tid in + tid =3D 0 || PickableInt.mem tid txs ) + && Testable.Command.precond cmd t + + let pp =3D + let open Fmt in + Dump.record + [ Dump.field "domid" fst Fmt.int + ; Dump.field "cmd" snd Testable.Command.pp_dump ] +end diff --git a/tools/ocaml/xenstored/test/model.ml b/tools/ocaml/xenstored/te= st/model.ml new file mode 100644 index 0000000000..4b5ae462fb --- /dev/null +++ b/tools/ocaml/xenstored/test/model.ml @@ -0,0 +1,253 @@ +open Xs_protocol + +(* Conventions: +Aim for correctness, use simplest data structure that unambigously represe= nts state. + +E.g.: +* a list when duplicates are allowed, order matters and the empty list is = a valid value +* a set when elements appearing multiple time have the same semantic meani= ng as them appearing once, +and the order is unspecified or sorted +* a map when a single key is mapped to a single value, and order is unspec= ified or sorted + +When we must retain the original order for queries, but semantically it do= esn't matter +then store both a canonical representation and the original order. + +*) + +let rec string_for_all_from s f pos =3D + pos =3D String.length s || (f s.[pos] && (string_for_all_from s f @@ (po= s + 1))) + +type error =3D [`Msg of string] + +module Path : sig + (** a valid xenstore path *) + type t + + val root : t + + val of_string : string -> t option + (** [of_string path] parses [path]. + @return [None] if the path is syntactically not valid *) + + val to_string : t -> string + (** [to_string path] converts path to string. *) + + (** [is_child parent child] returns true if [child] is a child of [paren= t]. + A path is considered to be a child of itself *) + val is_child : t -> t -> bool +end =3D struct + type t =3D string list + + let is_valid_char =3D function + | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '-' | '/' | '_' | '@' -> + true + | _ -> + false + + let root =3D [""] + + let nonempty s =3D String.length s > 0 + + let of_string s =3D + let n =3D String.length s in + if + n > 0 (* empty path is not permitted *) + && n < 1024 + (* paths cannot exceed 1024 chars, FIXME: relative vs absolute *) + && string_for_all_from s is_valid_char 0 + then + match String.split_on_char '/' s with + | [] -> + assert false + | [""; ""] -> + Some root + | _ :: tl as path -> + if List.for_all nonempty tl then Some path else None + else None + + let to_string =3D String.concat "/" + + let rec is_child p c =3D + match (p, c) with + | [], [] -> + true (* a path is a child of itself *) + | [], _ -> + true + | phd :: ptl, chd :: ctl when phd =3D chd -> + is_child ptl ctl + | _ -> + false +end + +module PathMap =3D Map.Make (String) +module DomidSet =3D Set.Make (Int) +module DomidMap =3D Map.Make (Int) + +let preserve_order =3D ref true + +module CanonicalACL =3D struct + module RW =3D struct + type t =3D {read: bool; write: bool} + + let of_perm =3D function + | ACL.NONE -> + {read=3D false; write=3D false} + | ACL.WRITE -> + {read=3D false; write=3D true} + | ACL.READ -> + {read=3D true; write=3D false} + | ACL.RDWR -> + {read=3D true; write=3D true} + + let to_perm =3D function + | {read=3D false; write=3D false} -> + ACL.NONE + | {read=3D false; write=3D true} -> + ACL.WRITE + | {read=3D true; write=3D false} -> + ACL.READ + | {read=3D true; write=3D true} -> + ACL.RDWR + + let full =3D {read=3D true; write=3D true} + end + + module RWMap =3D struct + type t =3D {fallback: RW.t; map: RW.t DomidMap.t} + + let lookup t domid =3D + (* other=3DRDWR can be overriden by explicitly revoking + permissions for a domain, so a read=3Dfalse,write=3Dfalse + in the DomidMap is not necessarily redundant + *) + DomidMap.find_opt domid t.map |> Option.value ~default:t.fallback + + let create fallback owner =3D + (* owner always has full permissions, and cannot be overriden *) + {fallback; map=3D DomidMap.singleton owner RW.full} + + let override t (domid, perm) =3D + let rw =3D RW.of_perm perm in + (* first entry wins, see perms.ml, also entries that are same as the= fallback are + not necessarily redundant: (b1,b2,r2) means that domid 2 has rdwr, + but if we remove the seemingly redundant `b2` entry then the over= ride would make it + just read which would be wrong. *) + if DomidMap.mem domid t.map then t + else {t with map=3D DomidMap.add domid rw t.map} + end + + type t =3D {original: ACL.t; owner: ACL.domid; acl: RWMap.t} + + let can_read t domid =3D (RWMap.lookup t.acl domid).read + + let can_write t domid =3D (RWMap.lookup t.acl domid).write + + let owner t =3D t.owner + + let of_acl original =3D + let fallback =3D RW.of_perm original.ACL.other in + let owner =3D original.ACL.owner in + let acl =3D + let init =3D RWMap.create fallback owner in + List.fold_left RWMap.override init original.ACL.acl + in + {original; owner; acl} + + let to_acl t =3D + if !preserve_order then t.original + else + ACL. + { owner=3D t.owner + ; other=3D RW.to_perm t.acl.fallback + ; acl=3D t.acl.map |> DomidMap.map RW.to_perm |> DomidMap.bindings= } +end + +module Store =3D struct + type node =3D {value: string; children: string list; acl: CanonicalACL.t} + + type t =3D {paths: node PathMap.t} + + let create () =3D {paths=3D PathMap.empty} + + let parent x =3D failwith "TODO" + + let add t key value =3D + let paths =3D PathMap.add key value t.paths in + {paths} + + let remove t key =3D + let paths =3D PathMap.remove key t.paths in + {paths} +end + +type t =3D Store.t + +let create () =3D Store.create () + +let reply_enoent =3D Response.Error "ENOENT" + +let reply_eexist =3D Response.Error "EEXIST" + +let with_node_read t path f =3D + ( t + , match PathMap.find_opt path t.paths with + | None -> + reply_enoent + | Some n -> + f n ) + +(* TODO: perm check *) +let perform_path t domid path =3D function + | Request.Read -> + with_node_read t path @@ fun n -> Response.Read n.value + | Request.Directory -> + with_node_read t path @@ fun n -> Response.Directory n.children + | Request.Directory_part _ -> + (t, Response.Error "ENOTSUP") + | Request.Getperms -> + with_node_read t path @@ fun n -> Response.Getperms n.acl + | Request.Write value -> ( + (* TODO: implicit mkdir *) + match PathMap.find_opt path t.paths with + | Some _ -> + (t, reply_eexist) + | None -> + let acl =3D ACL.{owner=3D domid; other=3D NONE; acl=3D []} in + let n =3D {value; children=3D []; acl} in + ({t with paths=3D PathMap.add path n t.paths}, Response.Write) ) + | Request.Setperms acl -> ( + match PathMap.find_opt path t.paths with + | Some _ -> + (t, reply_enoent) + | None -> + let update_node =3D function + | None -> + None + | Some n -> + Some {n with acl} + in + ( {t with paths=3D PathMap.update path update_node t.paths} + , Response.Setperms ) ) + | Request.Mkdir -> ( + (* TODO: implicit mkdir *) + match PathMap.find_opt path t.paths with + | Some _ -> + (t, reply_eexist) + | None -> + let acl =3D ACL.{owner=3D domid; other=3D NONE; acl=3D []} in + let n =3D {value=3D ""; children=3D []; acl} in + ({t with paths=3D PathMap.add path n t.paths}, Response.Mkdir) ) + | Request.Rm -> ( + match PathMap.find_opt path t.paths with + | None -> + (t, reply_enoent) + | Some _ -> + ({t with paths=3D PathMap.remove path t.paths}, Response.Rm) ) + +let perform t domid =3D function + | Request.PathOp (path, op) -> + perform_path t domid path op + | Request.Getdomainpath domid -> + (t, Response.Getdomainpath (Printf.sprintf "/local/domain/%d" domid)) + | _ -> + failwith "TODO" diff --git a/tools/ocaml/xenstored/test/old/arbitrary.ml b/tools/ocaml/xens= tored/test/old/arbitrary.ml new file mode 100644 index 0000000000..6b0bf9864a --- /dev/null +++ b/tools/ocaml/xenstored/test/old/arbitrary.ml @@ -0,0 +1,261 @@ +open QCheck + +(* See https://github.com/gasche/random-generator/blob/51351c16b587a1c4216= d158e847dcfa6db15f009/random_generator.mli#L275-L325 + for background on fueled generators for recursive data structures. + The difference here is that we build an N-ary tree, not a binary tree a= s in the example. + So we need to spread the fuel among elements of a list of random size. +*) + +(** [spread fuel] creates an array of a random size, and spreads fuel amon= g array elements. + Each array slot uses up at least 1 fuel itself. + For example the full list of possible arrays with [4] fuel is: + {[ [[|3|]; [|0; 2|]; [|1; 1|]; [|2; 0|]; [|0; 0; 0; 0|]] ]} +*) +let spread =3D function + | 0 -> + Gen.return [||] + | n when n < 0 -> + invalid_arg "negative fuel" + | n -> + Gen.( + 1 -- n + >>=3D fun per_element -> + (* We got n fuel to divide up, such that most elements have [per_e= lement] fuel. + Round up the number of elements *) + let m =3D (n + per_element - 1) / per_element in + (* each element uses up at least one fuel, this has to be subtract= ed before propagation *) + let a =3D Array.make m (per_element - 1) in + (* handle remainder *) + a.(0) <- n - (per_element * (m - 1)) - 1 ; + assert (Array.fold_left ( + ) m a =3D n) ; + (* ensure that remainder is in a random position *) + Gen.shuffle_a a >|=3D fun () -> a) + +(** [spread_l fuel sized_element] spreads [fuel] among list elements, + where each list element is created using [sized_element]. + [sized_element] needs to create an element of exactly the requested si= ze + (which may be a recursive element, that calls [spread_l] in turn). + Each list element consumes 1 fuel implicitly and sized_element is call= ed with decreased fuel. + *) +let spread_l fuel (sized_elem : 'a Gen.sized) =3D + Gen.( + spread fuel + >>=3D fun a -> + a |> Array.map sized_elem |> Gen.flatten_a |> Gen.map Array.to_list) + +module Tree =3D struct + (* For better shrinking put the (recursive) list first *) + type 'a t =3D Nodes of ('a t * 'a) list + + (** [empty] the empty tree (of size 1) *) + let empty =3D Nodes [] + + (** [nodes subtree] tree constructor *) + let nodes children =3D Nodes children + + (** [tree elem_gen] generates a random tree, with elements generated by = [elem_gen] *) + let tree elem =3D + Gen.sized @@ Gen.fix + @@ fun self fuel -> + (* self is the generator for a subtree *) + let node fuel =3D Gen.(pair (self fuel) elem) in + (* using spread_l ensures that fuel decreases by at least 1, thus ensu= ring termination *) + Gen.map nodes @@ spread_l fuel node + + (** [zero _] is a default implementation for [small] *) + let zero _ =3D 0 + + (** [small elem_size tree] returns the count of nodes in the tree and th= e sum of element sizes + as determined by [elem_size] *) + let rec small ?(elem_size =3D zero) (Nodes tree) =3D + List.fold_left + (fun acc (subtree, elem) -> + acc + elem_size elem + small ~elem_size subtree) + 1 tree + + (** [shrink ?elem tree] returns a list of potentially smaller trees base= d on [tree]. + *) + let shrink ?(elem =3D Shrink.nil) =3D + (* Shrinking needs to generate smaller trees (as determined by [small]= ), + QCheck will keep iterating until it finds a smaller tree that still= reproduces the bug. + It will then invoke the shrinker again on the smaller tree to attem= pt to shrink it further. + Once the tree shape cannot be shrunk further individual node elemen= ts will be shrunk. + *) + let rec tree (Nodes t) =3D + (* first try to shrink the subtree to a leaf, + and if that doesn't work then recursively shrink the subtree + *) + Iter.append (Iter.return empty) + @@ Iter.map nodes + @@ Shrink.list ~shrink:(Shrink.pair tree elem) t + in + tree + + (** [make arb] creates a tree generator with elements generated by [arb]. + The tree has a shrinker and size defined. + *) + let make arb =3D + let gen =3D tree @@ gen arb in + QCheck.make + ~small:(small ?elem_size:arb.small) + ~shrink:(shrink ?elem:arb.shrink) gen + + (** [paths_of_tree ~join tree] return all paths through the tree, + with path elements joined using [join] *) + let paths_of_tree ~join t =3D + let rec paths_of_subtree (paths, path) (Nodes nodes) =3D + ListLabels.fold_left nodes ~init:paths ~f:(fun paths (tree, elem) -> + let path =3D elem :: path in + paths_of_subtree (join (List.rev path) :: paths, path) tree) + in + paths_of_subtree ([], []) t + + let paths join arb =3D + make arb + (* we need to retain the tree, so that the shrinking is done on the tr= ee, + and not on the paths *) + |> map_keep_input (paths_of_tree ~join) +end + +module Case =3D struct + type ('a, 'b) t =3D + { case_tag: string + ; orig: 'a QCheck.arbitrary + ; map: 'a -> 'b + ; shrink: 'a -> 'b Iter.t + ; print: 'a Print.t + ; small: 'a -> int } + + (** [make arb f] defines a new variant case with constructor arguments + generated by [arb] and constructor [f]. *) + let make case_tag orig map =3D + let shrink a =3D + match orig.QCheck.shrink with + | None -> + Iter.empty + | Some s -> + Iter.map map @@ s a + in + let small a =3D match orig.QCheck.small with None -> 0 | Some s -> s a= in + let print a =3D match orig.QCheck.print with None -> "_" | Some p -> p= a in + {case_tag; orig; map; shrink; small; print} + + type 'a call =3D + { tag: string + ; shrink_lazy: 'a Iter.t Lazy.t + ; small_lazy: int Lazy.t + ; print: string Lazy.t } + + (** [call tag case args] used by the implementation of [rev] to build a = shrinker/small of appropriate type *) + let call t a =3D + { tag=3D t.case_tag + ; shrink_lazy=3D lazy (t.shrink a) + ; small_lazy=3D lazy (t.small a) + ; print=3D lazy (t.print a) } + + (** [to_sum case] converts all variant cases to the same type so they ca= n be put into a list *) + let to_sum t =3D Gen.map t.map @@ QCheck.gen t.orig +end + +(** [sum ~print ~rev cases] defines an arbitrary for a sum type consisting= of [cases] + variant case generators. [print] converts the sum type to a string. + [rev] matches on the sum type and should invoke [Case.call = ]. + + E.g. + {| + type t =3D A of int | B of float + + let case_a =3D Case.make "A" int (fun i -> A i) + + let case_b =3D Case.make "B" float (fun f -> B f) + + let rev t =3D + match t with A i -> Case.call case_a i | B g -> Case.call case_b g + + let x =3D + sum + ~print:(fun _ -> failwith "TODO") + [Case.to_sum case_a; Case.to_sum case_b] + |} + *) +let sum ~rev lst =3D + let shrink b =3D Lazy.force (rev b).Case.shrink_lazy in + let small b =3D Lazy.force (rev b).Case.small_lazy in + let collect b =3D (rev b).Case.tag in + let print b =3D let r =3D rev b in r.Case.tag ^ " " ^ Lazy.force r.print= in + QCheck.make ~shrink ~small ~collect ~print (Gen.oneof lst) + +(* +let mk_packet op to_string arb =3D + Case.make arb (fun x -> Xenbus.Packet.create 0 0 op (to_string x)) + +let read_packet =3D + mk_packet Xenbus.Xb.Op.Read Store.Path.to_string (list path_element) + +let write_packet =3D + mk_packet Xenbus.Xb.Op.Write + (fun (x, y) -> Store.Path.to_string x ^ "\x00" ^ y) + (pair (list path_element) binary) + +let packet =3D + sum ~print:Xenbus.Packet.to_string + [Case.to_sum read_packet; Case.to_sum write_packet] +*) + +(** [binary] is a generator of strings containing \x00 characters. *) +let binary =3D + (* increase frequency of '\x00' to 10%, otherwise it'd be ~1/256 *) + string_gen (Gen.frequency [(10, Gen.return '\x00'); (90, Gen.char)]) + |> set_print String.escaped + +(** [path_chars] valid path characters according to Xenstore protocol. *) +let path_chars =3D + List.init 256 Char.chr + |> List.filter Store.Path.char_is_valid + |> Array.of_list |> Gen.oneofa + +(** [path_element] a valid path element *) +let path_element =3D + string_gen_of_size Gen.small_int path_chars + +type tree =3D string Tree.t + +let paths =3D Tree.paths Store.Path.to_string path_element + +let with_validate p =3D + map_same_type + @@ fun v -> + (* reject it in a way known to QCheck: precondition failed, + instead of testcase failed *) + assume @@ p v ; + v + +(** [non_nul string_arb] rejects strings generated by [string_arb] that co= ntain '\x00'. *) +let non_nul =3D with_validate @@ fun s -> not (String.contains s '\x00') + +(** [plus arb] generates a list of 1 or more elements generated by [arb] *) +let plus arb =3D list_of_size Gen.(map succ small_int) arb + +(** [star arb] generates a list of 0 or more elements generated by [arb] *) +let star arb =3D list_of_size Gen.small_int arb + +let reserved =3D + string_of_size Gen.(frequency [(90, Gen.return 0); (10, Gen.small_int)]) + +(** According to xenstore protocol this could go up to 65535, but an actua= l domid + shouldn't go above this value *) +let domid_first_reserved =3D 0x7FF0 + +(** [new_domid] generates DomU domids *) +let new_domid =3D 1 -- domid_first_reserved + +let permty =3D + let open Perms in + oneofl [READ; WRITE; RDWR; NONE] + +let perms domid =3D + map + (fun (domid, other, acls) -> Perms.Node.create domid other acls) + ~rev:(fun n -> + (Perms.Node.get_owner n, Perms.Node.get_other n, Perms.Node.get_acl = n)) + @@ triple domid permty (small_list (pair domid permty)) diff --git a/tools/ocaml/xenstored/test/old/gen_paths.ml b/tools/ocaml/xens= tored/test/old/gen_paths.ml new file mode 100644 index 0000000000..b50c5b7cad --- /dev/null +++ b/tools/ocaml/xenstored/test/old/gen_paths.ml @@ -0,0 +1,66 @@ +open QCheck +open Store + +type tree =3D Leaf | Nodes of (string * tree) list + +let nodes children =3D Nodes children +let gen_tree =3D QCheck.Gen.(sized @@ fix + (fun self n -> + let children =3D frequency [1, pure 0; 2, int_bound n] >>=3D fun m -> + match m with + | 0 -> pure [] + | _ -> list_repeat m (pair string (self (n/m))) + in + frequency + [ 1, pure Leaf + ; 2, map nodes children + ] + )) + +let rec paths_of_tree (acc, path) =3D function +| Leaf -> acc +| Nodes l -> + List.fold_left (fun acc (k, children) -> + let path =3D k :: path in + paths_of_tree (Store.Path.to_string (List.rev path) :: acc, path) chil= dren + ) acc l + +let gen_paths_choices =3D + Gen.map (fun tree -> + tree |> paths_of_tree ([], []) |> Array.of_list + ) gen_tree + +(*let arb_name =3D Gen.small_string + +let arb_permty =3D let open Perms in oneofl [ READ; WRITE; RDWR; NONE ] + +let arb_domid =3D oneofl [ 0; 1; 0x7FEF] + +let arb_perms =3D + map (fun (domid, other, acls) -> Perms.Node.create domid other acls) + ~rev:(fun n -> Perms.Node.get_owner n, Perms.Node.get_other n, Perms.No= de.get_acl n) + @@ triple arb_domid arb_permty (small_list (pair arb_domid arb_permty))= *) + +let arb_name =3D Gen.small_string +let arb_value =3D Gen.small_string + +let node_of name value children =3D + List.fold_left (fun c acc -> Node.add_child acc c) + (Node.create name Perms.Node.default0 value ) children + +let g =3D QCheck.Gen.(sized @@ fix + (fun self n -> + frequency [1, pure 0; 2, int_bound n] >>=3D fun m -> + let children =3D match m with + | 0 -> pure [] + | _ -> list_repeat m (self (n/m)) + in + map3 node_of arb_name arb_value children + )) + +let paths_of_tree t =3D + let paths =3D ref [] in + Store.traversal t (fun path node -> + paths :=3D (Store.Path.of_path_and_name path (Node.get_name node) |> S= tore.Path.to_string) :: !paths + ); + !paths diff --git a/tools/ocaml/xenstored/test/old/xenstored_test.ml b/tools/ocaml= /xenstored/test/old/xenstored_test.ml new file mode 100644 index 0000000000..84cfc45d4f --- /dev/null +++ b/tools/ocaml/xenstored/test/old/xenstored_test.ml @@ -0,0 +1,527 @@ +open Stdext +open QCheck +open Arbitrary + +let () =3D + (* Logging.access_log_nb_files :=3D 1 ; + Logging.access_log_transaction_ops :=3D true ; + Logging.access_log_special_ops :=3D true ; + Logging.access_log_destination :=3D File "/tmp/log" ; + Logging.init_access_log ignore ; + Logging.set_xenstored_log_destination "/dev/stderr"; + Logging.init_xenstored_log (); *) + Domains.xenstored_port :=3D "xenstored-port" ; + let f =3D open_out !Domains.xenstored_port in + Printf.fprintf f "%d" 1 ; + close_out f ; + Domains.xenstored_kva :=3D "/dev/zero" + +module Command =3D struct + type value =3D string + + let value =3D binary + + type token =3D string + + type txid =3D int + + type domid =3D Xenctrl.domid + + type t =3D + | Read of Store.Path.t + | Write of Store.Path.t * value + | Mkdir of Store.Path.t + | Rm of Store.Path.t + | Directory of Store.Path.t + (* | Directory_part not implemented *) + | Get_perms of Store.Path.t + | Set_perms of Store.Path.t * Perms.Node.t + | Watch of Store.Path.t * token + | Unwatch of Store.Path.t * token + | Reset_watches + | Transaction_start + | Transaction_end of bool + | Introduce of domid * nativeint * int + | Release of int + | Get_domain_path of domid + | Is_domain_introduced of domid + | Set_target of domid * domid + | LiveUpdate + + type state =3D + { store: Store.t + ; doms: Domains.domains + ; cons: Connections.t + ; domids: int array } + + let path =3D list path_element + + let token =3D printable_string + + let domid state =3D oneofa ~print:Print.int state.domids + + let cmd state =3D + let domid =3D domid state in + let cmd_read =3D Case.make "READ" path (fun path -> Read path) in + let cmd_write =3D + Case.make "WRITE" (pair path value) (fun (path, value) -> + Write (path, value)) + in + let cmd_mkdir =3D Case.make "MKDIR" path (fun path -> Mkdir path) in + let cmd_rm =3D Case.make "RM" path (fun path -> Rm path) in + let cmd_directory =3D + Case.make "DIRECTORY" path (fun path -> Directory path) + in + let cmd_get_perms =3D + Case.make "GET_PERMS" path (fun path -> Get_perms path) + in + let cmd_set_perms =3D + Case.make "SET_PERMS" + (pair path (perms domid)) + (fun (path, perms) -> Set_perms (path, perms)) + in + let cmd_watch =3D + Case.make "WATCH" (pair path token) (fun (path, token) -> + Watch (path, token)) + in + let cmd_unwatch =3D + Case.make "UNWATCH" (pair path token) (fun (path, token) -> + Unwatch (path, token)) + in + let cmd_reset_watches =3D + Case.make "RESET_WATCHES" unit (fun () -> Reset_watches) + in + let cmd_tx_start =3D + Case.make "TRANSACTION_START" unit (fun () -> Transaction_start) + in + let cmd_tx_end =3D + Case.make "TRANSACTION_END" bool (fun commit -> Transaction_end comm= it) + in + let cmd_introduce =3D + Case.make "INTRODUCE" (triple domid int int) (fun (domid, gfn, port)= -> + Introduce (domid, Nativeint.of_int gfn, port)) + in + let cmd_release =3D Case.make "RELEASE" domid (fun domid -> Release do= mid) in + let cmd_get_domain_path =3D + Case.make "GET_DOMAIN_PATH" domid (fun domid -> Get_domain_path domi= d) + in + let cmd_is_domain_introduced =3D + Case.make "IS_DOMAIN_INTRODUCED" domid (fun domid -> + Is_domain_introduced domid) + in + let cmd_set_target =3D + Case.make "SET_TARGET" (pair domid domid) (fun (domid, tdomid) -> + Set_target (domid, tdomid)) + in + let cmd_live_update =3D + Case.make "CONTROL live-update" unit (fun () -> LiveUpdate) + in + let rev =3D function + | Read a -> + Case.call cmd_read a + | Write (p, v) -> + Case.call cmd_write (p, v) + | Mkdir a -> + Case.call cmd_mkdir a + | Rm a -> + Case.call cmd_rm a + | Directory a -> + Case.call cmd_directory a + | Get_perms a -> + Case.call cmd_get_perms a + | Set_perms (p, v) -> + Case.call cmd_set_perms (p, v) + | Watch (p, t) -> + Case.call cmd_watch (p, t) + | Unwatch (p, t) -> + Case.call cmd_unwatch (p, t) + | Reset_watches -> + Case.call cmd_reset_watches () + | Transaction_start -> + Case.call cmd_tx_start () + | Transaction_end a -> + Case.call cmd_tx_end a + | Introduce (d, g, p) -> + Case.call cmd_introduce (d, Nativeint.to_int g, p) + | Release a -> + Case.call cmd_release a + | Get_domain_path a -> + Case.call cmd_get_domain_path a + | Is_domain_introduced a -> + Case.call cmd_is_domain_introduced a + | Set_target (d, t) -> + Case.call cmd_set_target (d, t) + | LiveUpdate -> + Case.call cmd_live_update () + in + let open Case in + sum ~rev + [ to_sum cmd_read + ; to_sum cmd_write + ; to_sum cmd_mkdir + ; to_sum cmd_rm + ; to_sum cmd_directory + ; to_sum cmd_get_perms + ; to_sum cmd_set_perms + ; to_sum cmd_watch + ; to_sum cmd_unwatch + ; to_sum cmd_reset_watches + ; to_sum cmd_tx_start + ; to_sum cmd_tx_end + ; to_sum cmd_introduce + ; to_sum cmd_release + ; to_sum cmd_get_domain_path + ; to_sum cmd_is_domain_introduced + ; to_sum cmd_set_target + ; to_sum cmd_live_update ] + + let run tid =3D + let open Xenstore.Queueop in + function + | Read p -> + read tid Store.Path.(to_string p) + | Write (p, v) -> + write tid Store.Path.(to_string p) v + | Mkdir p -> + mkdir tid Store.Path.(to_string p) + | Rm p -> + rm tid Store.Path.(to_string p) + | Directory p -> + directory tid Store.Path.(to_string p) + | Get_perms p -> + getperms tid Store.Path.(to_string p) + | Set_perms (p, v) -> + setperms tid Store.Path.(to_string p) Perms.Node.(to_string v) + | Watch (p, t) -> + watch Store.Path.(to_string p) t + | Unwatch (p, t) -> + unwatch Store.Path.(to_string p) t + | Reset_watches -> + let open Xenbus in + fun con -> Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Reset_watches = "") + | Transaction_start -> + transaction_start + | Transaction_end c -> + transaction_end tid c + | Release d -> + release d + | Get_domain_path d -> + getdomainpath d + | Is_domain_introduced d -> + let open Xenbus in + fun con -> + Xb.queue con + (Xb.Packet.create 0 0 Xb.Op.Isintroduced (string_of_int d)) + | Set_target (d, t) -> + let open Xenbus in + fun con -> + Xb.queue con + (Xb.Packet.create 0 0 Xb.Op.Isintroduced + (String.concat "\x00" [string_of_int d; string_of_int t])) + | LiveUpdate -> + debug ["live-update"; "-s"] + | Introduce (d, g, p) -> + introduce d g p +end + +module Spec =3D struct + type cmd =3D New | Cmd of Command.domid * int option * Command.t + + type state =3D + { xb: Xenbus.Xb.t + ; cnt: int + ; cmdstate: Command.state ref option + ; failure: (exn * string) option } + + type sut =3D state ref + + let doms =3D Domains.init (Event.init ()) ignore + + let dom0 =3D Domains.create0 doms + + let new_state () =3D + let cons =3D Connections.create () in + Connections.add_domain cons dom0 ; + let store =3D Store.create () in + let con =3D Perms.Connection.create 0 in + Store.mkdir store con ["tool"] ; + {Command.store; doms; cons; domids=3D [|0|]} + + let print =3D function + | New -> + "NEW" + | Cmd (d, t, c) -> + let s =3D new_state () in + let cmd =3D Command.cmd s in + (Option.get (triple (Command.domid s) (option int) cmd).print) (d,= t, c) + + let shrink =3D function + | New -> + Iter.empty + | Cmd (d, t, c) -> + let s =3D new_state () in + let cmd =3D Command.cmd s in + Iter.map (fun (d, t, c) -> Cmd (d, t, c)) + @@ (Option.get (triple (Command.domid s) (option int) cmd).shrink) + (d, t, c) + + let arb_cmd state =3D + ( match state.cmdstate with + | None -> + always New + | Some s -> + let cmd =3D Command.cmd !s in + QCheck.map + (fun (d, t, c) -> Cmd (d, t, c)) + ~rev:(fun (Cmd (d, t, c)) -> (d, t, c)) + @@ triple (Command.domid !s) (option int) cmd ) + |> set_print print |> set_shrink shrink + + (* |> set_collect (fun (_, _, c) -> (Option.get cmd.QCheck.collect) c= )*) + + let init_state =3D + {cnt=3D 0; xb=3D Xenbus.Xb.open_fd Unix.stdout; cmdstate=3D None; fail= ure=3D None} + + let precond cmd s =3D + match (cmd, s.cmdstate) with + | New, None -> + true + | New, _ -> + false + | Cmd _, None -> + false + | Cmd (_, _, Command.Release 0), _ -> + false + | _ -> + true + + let next_state cmd state =3D + { ( try + assume (precond cmd state) ; + match cmd with + | New -> + {state with cmdstate=3D Some (ref @@ new_state ())} + | Cmd (domid, tid, cmd) -> + let tid =3D match tid with None -> 0 | Some id -> 1 + id in + Command.run tid cmd state.xb ; + let s =3D !(Option.get state.cmdstate) in + let con =3D Connections.find_domain s.Command.cons domid in + Queue.clear con.xb.pkt_out ; + let run_packet packet =3D + let tid, rid, ty, data =3D Xenbus.Xb.Packet.unpack packet = in + let req =3D {Packet.tid; Packet.rid; Packet.ty; Packet.dat= a} in + Process.process_packet ~store:s.Command.store + ~cons:s.Command.cons ~doms:s.Command.doms ~con ~req ; + Process.write_access_log ~ty ~tid + ~con:(Connection.get_domstr con) + ~data ; + let packet =3D Connection.peek_output con in + let tid, _rid, ty, data =3D Xenbus.Xb.Packet.unpack packet= in + Process.write_answer_log ~ty ~tid + ~con:(Connection.get_domstr con) + ~data + in + Queue.iter run_packet state.xb.pkt_out ; + Queue.clear state.xb.pkt_out ; + state + with e -> + let bt =3D Printexc.get_backtrace () in + {state with failure=3D Some (e, bt)} ) + with + cnt=3D state.cnt + 1 } + + let init_sut () =3D ref init_state + + let cleanup _ =3D () + + module P =3D struct + type t =3D string list + + let compare =3D compare + end + + module PathMap =3D Map.Make (P) + + module DomidMap =3D Map.Make (struct + type t =3D Xenctrl.domid + + let compare =3D compare + end) + + module IntMap =3D Map.Make (struct + type t =3D int + + let compare =3D compare + end) + + module FDMap =3D Map.Make (struct + type t =3D Unix.file_descr + + let compare =3D compare + end) + + let map_of_store s =3D + let m =3D ref PathMap.empty in + Store.dump_fct s (fun path node -> m :=3D PathMap.add path node !m) ; + !m + + let node_equiv n n' =3D + Perms.equiv (Store.Node.get_perms n) (Store.Node.get_perms n') + && Store.Node.get_name n =3D Store.Node.get_name n' + && Store.Node.get_value n =3D Store.Node.get_value n' + + let store_root_equiv s s' =3D + if not (PathMap.equal node_equiv (map_of_store s) (map_of_store s')) t= hen + let b =3D Store.dump_store_buf s.root in + let b' =3D Store.dump_store_buf s'.root in + Test.fail_reportf "Store trees are not equivalent:\n %s\n <>\n %s" + (Buffer.contents b) (Buffer.contents b') + else true + + let map_of_domid_table tbl =3D Hashtbl.fold DomidMap.add tbl DomidMap.em= pty + + let map_of_quota q =3D map_of_domid_table q.Quota.cur + + let store_quota_equiv root root' q q' =3D + let _ =3D + DomidMap.merge + (fun domid q q' -> + let q =3D Option.value ~default:(-1) q in + let q' =3D Option.value ~default:(-1) q' in + if q <> q' then + let b =3D Store.dump_store_buf root in + let b' =3D Store.dump_store_buf root' in + Test.fail_reportf "quota mismatch on %d: %d <> %d\n%s\n%s\n" d= omid q + q' (Buffer.contents b) (Buffer.contents b') + else Some q) + (map_of_quota q) (map_of_quota q') + in + true + + let store_equiv s s' =3D + store_root_equiv s s' + && store_quota_equiv s.root s'.root (Store.get_quota s) (Store.get_quo= ta s') + + let map_of_domains d =3D map_of_domid_table d.Domains.table + + let domain_equiv d d' =3D + Domain.get_id d =3D Domain.get_id d' + && Domain.get_remote_port d =3D Domain.get_remote_port d' + + let domains_equiv d d' =3D + DomidMap.equal domain_equiv (map_of_domains d) (map_of_domains d') + + let map_of_fd_table tbl =3D Hashtbl.fold FDMap.add tbl FDMap.empty + + let map_of_int_table tbl =3D Hashtbl.fold IntMap.add tbl IntMap.empty + + let list_of_queue q =3D Queue.fold (fun acc e -> e :: acc) [] q + + let connection_equiv c c' =3D + let l =3D list_of_queue c.Connection.xb.pkt_out in + let l' =3D list_of_queue c'.Connection.xb.pkt_out in + if List.length l <> List.length l' || List.exists2 ( <> ) l l' then ( + let print_packets l =3D + l + |> List.rev_map (fun p -> + let tid, rid, ty, data =3D Xenbus.Packet.unpack p in + let tystr =3D Xenbus.Xb.Op.to_string ty in + Printf.sprintf "tid=3D%d, rid=3D%d, ty=3D%s, data=3D%s" tid= rid tystr + (String.escaped data)) + |> String.concat "\n" + in + let r =3D print_packets l in + let r' =3D print_packets l' in + Test.fail_reportf "Replies not equal:\n%s\n <>\n %s" r r' ) + else + let n =3D Connection.number_of_transactions c in + let n' =3D Connection.number_of_transactions c' in + if n <> n' then Test.fail_reportf "TX count mismatch: %d <> %d" n n' + else true + + let connections_equiv c c' =3D + FDMap.equal connection_equiv + (map_of_fd_table c.Connections.anonymous) + (map_of_fd_table c'.Connections.anonymous) + && IntMap.equal connection_equiv + (map_of_int_table c.Connections.domains) + (map_of_int_table c'.Connections.domains) + + let dump_load s =3D + let tmp =3D Filename.temp_file "xenstored" "qcheck.dump" in + finally + (fun () -> + let fds =3D {Xenstored.DB.rw_sock=3D None; ro_sock=3D None} in + Xenstored.DB.to_file fds !s.Command.store !s.Command.cons tmp ; + s :=3D new_state () ; + let _fds', errors =3D + Xenstored.DB.from_file ~live:true !s.Command.store !s.Command.do= ms + !s.Command.cons tmp + in + if errors > 0 then + Test.fail_reportf "Errors during live update: %d" errors) + (fun () -> Sys.remove tmp) + + let run_cmd cmd state sut =3D + ( match state.failure with + | None -> + true + | Some (e, bt) -> + Test.fail_reportf "Exception %s, backtrace: %s" (Printexc.to_strin= g e) + bt ) + && + match cmd with + | New -> + sut :=3D next_state cmd !sut ; + true + | Cmd (0, _, Command.LiveUpdate) -> + let s =3D !sut.cmdstate in + let store1 =3D Store.copy !(Option.get s).store in + let doms1 =3D !(Option.get s).doms in + dump_load (Option.get s) ; + (* reply is expected not to be equivalent, since after live update= we got an empty reply queue, + so don't compare connections + *) + store_equiv store1 !(Option.get s).store + && domains_equiv doms1 !(Option.get s).doms + | Cmd(_, _, cmd') -> ( + (* TODO: also got same reply, and check for equivalence on the act= ual Live Update *) + sut :=3D next_state cmd !sut ; + let ids =3D Hashtbl.create 47 in + Connections.iter !(Option.get state.cmdstate).cons (fun con -> + Hashtbl.add ids (Connection.get_id con) con.next_tid) ; + let state =3D next_state cmd state in + match (!sut.failure, state.cmdstate, !sut.cmdstate) with + | None, Some s, Some s' -> + let r =3D cmd' =3D Command.Transaction_start (* txid can chang= e *) ||=20 + connections_equiv !s.cons !s'.cons in + Connections.iter !(Option.get state.cmdstate).cons (fun con -> + let tid =3D Hashtbl.find ids (Connection.get_id con) in + if con.next_tid <> tid then ( + let (_ : bool) =3D Connection.end_transaction con tid No= ne in + () ; + con.next_tid <- tid )) ; + r + | None, None, None -> + true + | None, None, _ -> + Test.fail_report "state uninit" + | None, _, None -> + Test.fail_report "sut uninit" + | Some (e, bt), _, _ -> + Test.fail_reportf "Exception %s, backtrace: %s" + (Printexc.to_string e) bt ) +end + +module States =3D QCSTM.Make (Spec) + +(* && watches_equiv c c' *) + +let test =3D States.agree_test ~count:100 ~name:"live-update" + +let test =3D + Test.make ~name:"live-update" ~count:100 + (States.arb_cmds Spec.init_state) + States.agree_prop + +let () =3D QCheck_base_runner.run_tests_main [test] diff --git a/tools/ocaml/xenstored/test/pathtree.ml b/tools/ocaml/xenstored= /test/pathtree.ml new file mode 100644 index 0000000000..50cbb0302d --- /dev/null +++ b/tools/ocaml/xenstored/test/pathtree.ml @@ -0,0 +1,40 @@ +module M =3D Map.Make(String) +type 'a t =3D { data: 'a; children: 'a t M.t } + +type 'a tree =3D 'a t +let of_data data =3D { data; children =3D M.empty } + +let update key f t =3D { t with children =3D M.update key f t.children } +let set t data =3D { t with data } + +module Cursor =3D struct + type 'a t =3D { tree: 'a tree; up: ('a t * M.key) option } + + let of_tree tree =3D { tree; up =3D None } + + let create parent key tree =3D { tree; up =3D Some (parent, key) } + + let down cur k =3D + M.find_opt k cur.tree.children |> Option.map @@ create cur k + + let down_implicit_create ~implicit cur k =3D + match down cur k with + | Some r -> r + | None -> cur.tree.data |> implicit |> of_data |> create cur k + + let rec to_tree t =3D match t.up with + | None -> t.tree + | Some (parent, key) -> + to_tree { parent with tree =3D update key (fun _ -> Some t.tree) p= arent.tree } + + let set cur data =3D { cur with tree =3D set cur.tree data } + let get cur =3D cur.tree.data + + let rm_child cur key =3D { cur with tree =3D update key (fun _ -> None) = cur.tree} + + (* TODO: down with implicit create *) +end + + + +let rec map f t =3D { data =3D f t.data; children =3D M.map (map f) t.chil= dren } diff --git a/tools/ocaml/xenstored/test/testable.ml b/tools/ocaml/xenstored= /test/testable.ml new file mode 100644 index 0000000000..2fa749fbb3 --- /dev/null +++ b/tools/ocaml/xenstored/test/testable.ml @@ -0,0 +1,379 @@ +let is_output_devnull =3D Unix.stat "/dev/null" =3D Unix.fstat Unix.stdout + +let () =3D + if not is_output_devnull then ( + Printexc.record_backtrace true ; + Fmt_tty.setup_std_outputs () ; + try + let cols =3D + let ch =3D Unix.open_process_in "tput cols" in + Stdext.finally + (fun () -> input_line ch |> int_of_string) + (fun () -> Unix.close_process_in ch) + in + Format.set_margin cols + with _ -> () ) + +let devnull () =3D Unix.openfile "/dev/null" [] 0 + +let xb =3D Xenbus.Xb.open_fd (devnull ()) + +module Command =3D struct + type path =3D Store.Path.t + + type value =3D string + + type token =3D string + + type domid =3D int + + type t =3D Xenbus.Packet.t + + open Xenstore.Queueop + + let cmd f =3D + Queue.clear xb.pkt_out ; + let () =3D f xb in + let p =3D Xenbus.Xb.peek_output xb in + Queue.clear xb.pkt_out ; p + + let pathcmd f pathgen tid state =3D cmd @@ f tid @@ pathgen state + + let cmd_read gen tid state =3D pathcmd read gen tid state + + let cmd_write pathgen v tid state =3D cmd @@ write tid (pathgen state) v + + let cmd_mkdir g t s =3D pathcmd mkdir g t s + + let cmd_rm g t s =3D pathcmd rm g t s + + let cmd_directory g t s =3D pathcmd directory g t s + + let cmd_getperms g t s =3D pathcmd getperms g t s + + let cmd_setperms pathgen vgen tid state =3D + cmd @@ setperms tid (pathgen state) (Perms.Node.to_string @@ vgen stat= e) + + let cmd_watch pathgen token _ state =3D cmd @@ watch (pathgen state) tok= en + + let cmd_unwatch pathgen token _ state =3D cmd @@ unwatch (pathgen state)= token + + let cmd_reset_watches tid _state =3D + let open Xenbus in + cmd + @@ fun con -> + Xenbus.Xb.queue con + (Xenbus.Xb.Packet.create 0 0 Xenbus.Xb.Op.Reset_watches "") + + let cmd_transaction_start _ _ =3D cmd @@ transaction_start + + let cmd_transaction_end commit tid _ =3D cmd @@ transaction_end tid comm= it + + let domcmd f idgen _ state =3D cmd @@ f @@ idgen state + + let cmd_release idgen state =3D domcmd release idgen state + + let cmd_getdomainpath i s =3D domcmd getdomainpath i s + + let cmd_isintroduced i t s =3D + domcmd + (fun d con -> + let open Xenbus in + Xenbus.Xb.queue con + (Xenbus.Xb.Packet.create 0 0 Xenbus.Xb.Op.Isintroduced + (string_of_int d))) + i t s + + let cmd_set_target idgen1 idgen2 _ state =3D + let d =3D idgen1 state in + let t =3D idgen2 state in + cmd + @@ fun con -> + Xenbus.Xb.queue con + (Xenbus.Xb.Packet.create 0 0 Xenbus.Xb.Op.Isintroduced + (String.concat "\x00" [string_of_int d; string_of_int t])) + + let cmd_liveupdate _ _ =3D cmd @@ debug ["live-update"; "-s"] + + let cmd_introduce id port _ state =3D cmd @@ introduce id 0n port + + let pp_dump =3D Types.pp_dump_packet + + let precond cmd _state =3D + match cmd with + | {Xenbus.Packet.ty=3D Xenbus.Xb.Op.Release; data=3D "0\000"} -> + false + (* can't release Dom0 in the tests, or we crash due to shared dom0= backend *) + | {ty=3D Xenbus.Xb.Op.Rm; data=3D ""} -> + (* this is expected to cause inconsistencies on pre-created paths = like /local *) + false + | _ -> + true +end + +let with_logger ~on_exn f =3D + if is_output_devnull then f () + else + let old =3D (!Logging.xenstored_logger, !Logging.access_logger) in + let logs =3D ref [] in + let write ?(level =3D Logging.Debug) s =3D + let msg =3D Printf.sprintf "%s %s" (Logging.string_of_level level) s= in + logs :=3D msg :: !logs + in + let logger =3D + Some {Logging.stop=3D ignore; restart=3D ignore; rotate=3D ignore; w= rite} + in + Logging.xenstored_logger :=3D logger ; + Logging.access_logger :=3D logger ; + Stdext.finally + (fun () -> + try f () + with e -> + let bt =3D Printexc.get_raw_backtrace () in + on_exn e bt (List.rev !logs)) + (fun () -> + Logging.xenstored_logger :=3D fst old ; + Logging.access_logger :=3D snd old) + +type t =3D + { store: Store.t + ; cons: Connections.t + ; doms: Domains.domains + ; mutable anon: Unix.file_descr option + ; live_update: bool + ; txidtbl: (int, int) Hashtbl.t } + +let () =3D + Logging.xenstored_log_level :=3D Logging.Debug ; + Logging.access_log_special_ops :=3D true ; + Logging.access_log_transaction_ops :=3D true ; + let name, f =3D Filename.open_temp_file "xenstored" "port" in + Domains.xenstored_port :=3D name ; + Stdext.finally (fun () -> Printf.fprintf f "%d" 1) (fun () -> close_out = f) ; + Domains.xenstored_kva :=3D "/dev/zero" ; + (* entries from a typical oxenstored.conf *) + Transaction.do_coalesce :=3D true ; + Perms.activate :=3D true ; + Quota.activate :=3D true ; + Quota.maxent :=3D 8192 ; + Quota.maxsize :=3D 2048 ; + Define.maxwatch :=3D 512 ; + Define.maxtransaction :=3D 10 ; + Define.maxrequests :=3D 1024 + +(* we MUST NOT release dom0, or we crash, + this is shared between multiple tests, because + it keeps an FD open, and we want to avoid EMFILE +*) + +let create ?(live_update =3D false) () =3D + let store =3D Store.create () in + let cons =3D Connections.create () in + let doms =3D Domains.init (Event.init ()) ignore in + let dom0 =3D Domains.create0 doms in + let txidtbl =3D Hashtbl.create 47 in + Connections.add_domain cons dom0 ; + {store; cons; doms; anon=3D None; live_update; txidtbl} + +let cleanup t =3D Connections.iter t.cons Connection.close + +let init t =3D + let local =3D Store.Path.of_string "/local" in + let con =3D Perms.Connection.create 0 in + Store.mkdir t.store con local ; + (* Store.mkdir t.store con (Store.Path.of_string "/tool") ;*) + let fd =3D devnull () in + t.anon <- Some fd ; + Connections.add_anonymous t.cons fd + +let dump_load s =3D + let tmp =3D Filename.temp_file "xenstored" "qcheck.dump" in + Stdext.finally + (fun () -> + Xenstored.DB.to_file None s.store s.cons tmp ; + let s' =3D create () in + (* preserve FD *) + s'.anon <- s.anon ; + s.anon <- None ; + let _fds', errors =3D + Xenstored.DB.from_file ~live:true s'.store s'.doms s'.cons tmp + in + if errors > 0 then + failwith (Printf.sprintf "Errors during live update: %d" errors) ; + s') + (fun () -> Sys.remove tmp) + +let is_live_update =3D function + | {Xenbus.Packet.ty=3D Xenbus.Xb.Op.Debug; data=3D "live-update\000-s\00= 0"} -> + true + | _ -> + false + +let is_tx_start p =3D p.Xenbus.Packet.ty =3D Xenbus.Xb.Op.Transaction_start + +let with_tmpfile prefix write f =3D + let name, ch =3D Filename.open_temp_file prefix ".txt" in + Stdext.finally + (fun () -> + Stdext.finally (fun () -> write ch) (fun () -> close_out ch) ; + f name) + (fun () -> Sys.remove name) + +let with_pp_to_file prefix pp x f =3D + let write ch =3D + let ppf =3D Format.formatter_of_out_channel ch in + Format.pp_set_margin ppf @@ Format.get_margin () ; + pp ppf x ; + Fmt.flush ppf () + in + with_tmpfile prefix write f + +let run_cmd_get_output ?(ok_codes =3D [0]) cmd =3D + let cmd =3D Array.of_list cmd in + let ch =3D Unix.open_process_args_in cmd.(0) cmd in + Stdext.finally + (fun () -> + let lines =3D ref [] in + try + while true do + lines :=3D input_line ch :: !lines + done ; + assert false + with End_of_file -> List.rev !lines |> String.concat "\n") + (fun () -> + match Unix.close_process_in ch with + | Unix.WEXITED code when List.mem code ok_codes -> + () + | status -> + Crowbar.failf "%a %a" (Fmt.array Fmt.string) cmd + Types.pp_process_status status) + +let call_diff x y =3D + let ok_codes =3D [0; 1] in + run_cmd_get_output ~ok_codes + [ "/usr/bin/git" + ; "diff" + ; "-U10000" (* we want to see the entire state, where possible *) + ; "--no-index" + ; ( "--word-diff=3D" + ^ if Fmt.style_renderer Fmt.stdout =3D `Ansi_tty then "color" else "= plain" + ) + ; "--color-moved=3Ddimmed-zebra" + ; x + ; y ] + +let check_eq_exn prefix ~pp ~eq x y =3D + if not @@ eq x y then + if is_output_devnull then failwith "different" + else + with_pp_to_file "expected" pp x + @@ fun xfile -> + with_pp_to_file "actual" pp y + @@ fun yfile -> + failwith + @@ Printf.sprintf "%s agrement: %s" prefix (call_diff xfile yfile) + +let run next_tid t (domid, cmd) =3D + let con =3D + match domid with + | 0 -> + Connections.find !t.cons (Option.get !t.anon) + | id -> + Connections.find_domain !t.cons domid + in + (* clear out any watch events, TODO: don't *) + Connections.iter !t.cons (fun con -> Queue.clear con.xb.pkt_out) ; + (* TODO: use the global live update state that processing the command se= ts, but remember to reset it *) + if is_live_update cmd then + if !t.live_update then ( + let t0 =3D !t in + let t' =3D dump_load t0 in + Connections.iter t'.cons (fun con -> + Connection.iter_transactions con + @@ fun _ tx -> + (* if tx.Transaction.operations <> [] then TODO: only if we d= ump snapshot state + correctly *) + Transaction.mark_failed tx) ; + Logging.info "store" "store: %s" (Fmt.to_to_string Types.pp_dump_sto= re t'.store); + Logging.info "store" "store: %s" (Fmt.to_to_string Types.pp_dump_sto= re t0.store); + check_eq_exn "store" ~pp:Types.pp_dump_store ~eq:Types.equal_store + t0.store t'.store ; + (* TODO: now we have a disagreement here... so we can't test this un= til TX state is restored *) + (*check_eq_exn "connections" ~pp:Types.pp_dump_connections + ~eq:Types.equal_connections t0.cons t'.cons ;*) + check_eq_exn "domains" ~pp:Types.pp_dump_domains ~eq:Types.equal_dom= ains + t0.doms t'.doms ; + (* avoid double close on anonymous conn *) + Connections.iter_domains t0.cons Connection.close ; + t :=3D {t' with txidtbl=3D !t.txidtbl} ) + else begin + Logging.debug "testable" "BEFORE TXMARK"; + Connections.iter !t.cons (fun con -> + Connection.iter_transactions con + @@ fun txid tx -> + Logging.debug "testable" "marking to fail %d" txid;=20 + (* if tx.Transaction.operations <> [] then see above TODO *) + Transaction.mark_failed tx)=20 + end; + let run_packet packet =3D + let tid, rid, ty, data =3D Xenbus.Xb.Packet.unpack packet in + Logging.debug "testable" "tid: %d" tid ; + let tid =3D if tid <> 0 then Hashtbl.find !t.txidtbl tid else tid in + let req : Packet.request =3D + {Packet.tid; Packet.rid; Packet.ty; Packet.data} + in + Process.process_packet ~store:!t.store ~cons:!t.cons ~doms:!t.doms ~co= n ~req ; + Process.write_access_log ~ty ~tid ~con:(Connection.get_domstr con) ~da= ta ; + let packet =3D Connection.peek_output con in + if ty =3D Xenbus.Xb.Op.Transaction_start then ( + Logging.debug "testable" "Adding mapping for tid %d" next_tid ; + Hashtbl.add !t.txidtbl next_tid (con.Connection.next_tid - 1) ) ; + let tid, _rid, ty, data =3D Xenbus.Xb.Packet.unpack packet in + Process.write_answer_log ~ty ~tid ~con:(Connection.get_domstr con) ~da= ta + in + (* TODO: also a Nodes command with multiple packets *) + run_packet cmd ; (* TODO: act on and clear watches? *) + con + +let is_tx_marked_fail con p =3D + let tid =3D p.Xenbus.Packet.tid in + if tid =3D 0 then false + else begin + let r =3D try (Connection.get_transaction con tid).must_fail + with Not_found -> false in + Logging.info "testable" "TXI %d: %b" tid r; + r + end + +let run2 next_tid t t' (domid, cmd) =3D + let con =3D run next_tid t (domid, cmd) in + let con' =3D run next_tid t' (domid, cmd) in + (* TODO: ignore txid mismatches on transactions *) + if not @@ (is_tx_start cmd || is_tx_marked_fail con cmd) then + (* TODO: ignore disagreements when transactions are marked as failed *) + check_eq_exn "reply packets" ~pp:Types.pp_dump_xb ~eq:Types.equal_xb_p= kts + con.xb con'.xb ; + Queue.clear con'.xb.pkt_out ; + Queue.clear con.xb.pkt_out + +module type S =3D sig + type cmd + + type state + + type sut + + val init_state : state + + val next_state : cmd -> state -> state + + val init_sut : unit -> sut + + val cleanup : sut -> unit + + val run_cmd : cmd -> state -> sut -> bool + + val precond : cmd -> state -> bool + + val pp : cmd Fmt.t +end diff --git a/tools/ocaml/xenstored/test/types.ml b/tools/ocaml/xenstored/te= st/types.ml new file mode 100644 index 0000000000..f46d20b245 --- /dev/null +++ b/tools/ocaml/xenstored/test/types.ml @@ -0,0 +1,437 @@ +(* + * Copyright (C) Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +let domid_first_reserved =3D 0x7FF0 + +type 'a eq =3D 'a -> 'a -> bool + +let hashtable_equal (eq : 'a eq) h h' =3D + Hashtbl.length h =3D Hashtbl.length h' + && Hashtbl.fold + (fun k v acc -> + acc + && match Hashtbl.find_opt h' k with Some x -> eq v x | None -> fa= lse) + h true + +let list_equal (eq : 'a eq) l l' =3D + try List.for_all2 eq l l' with Invalid_argument _ -> false + +let queue_equal eq q q' =3D + Queue.length q =3D Queue.length q' + && + let list_of_queue q =3D Queue.fold (fun acc e -> e :: acc) [] q in + list_equal eq (list_of_queue q) (list_of_queue q') + +let pp_process_status ppf =3D function + | Unix.WEXITED code -> + Fmt.pf ppf "exited with code %d" code + | Unix.WSIGNALED osig -> + Fmt.pf ppf "killed by signal %a" Fmt.Dump.signal osig + | Unix.WSTOPPED osig -> + Fmt.pf ppf "stopped by signal %a" Fmt.Dump.signal osig + +let pp_dump_ref dump =3D + Fmt.using ( ! ) Fmt.(dump |> Fmt.braces |> prefix (const string "ref")) + +let pp_file_descr =3D Fmt.using Disk.FD.to_int Fmt.int + +module Quota =3D struct + open Quota + + let pp_dump =3D + let open Fmt in + Dump.record + [ Dump.field "maxent" (fun q -> q.maxent) int + ; Dump.field "maxsize" (fun q -> q.maxsize) int + ; Dump.field "cur" (fun q -> q.cur) @@ Dump.hashtbl int int ] + + let drop_dom0 h =3D + (* Quota is ignored for Dom0 and will be wrong in some situations: + - when domains die any nodes owned by them get inherited by Dom0 + - the root node is owned by Dom0, if its ownership is changed Dom0'= s quota will be off-by-one + Since Dom0's quota is not actually used, just drop it when comparing + *) + let h' =3D Hashtbl.copy h in + Hashtbl.remove h' 0; + h' + + let equal q q' =3D + q.maxent =3D q'.maxent && q.maxsize =3D q'.maxsize + && hashtable_equal Int.equal (drop_dom0 q.cur) (drop_dom0 q'.cur) +end +let pp_dump_quota =3D Quota.pp_dump +let equal_quota =3D Quota.equal + +module Store =3D struct + open Store + + module Node =3D struct + open Node + + let pp_dump ppf t =3D + let buf =3D dump_store_buf t in + Fmt.lines ppf (Buffer.contents buf) + + let rec equal n n' =3D + Symbol.equal n.name n'.name + && Perms.equiv n.perms n'.perms + && String.equal n.value n'.value + && SymbolMap.equal equal n.children n'.children + end + + module Path =3D struct + open Path + + let pp_dump =3D Fmt.using to_string Fmt.string + + let equal p p' =3D list_equal String.equal p p' + + let hash (p : t) =3D Hashtbl.hash p + + let compare (p : t) (p' : t) =3D compare p p' + end + + let pp_dump =3D + let open Fmt in + (* only print relevant fields, expected to stay same during live-updat= e. *) + Dump.record + [ Dump.field "stat_transaction_coalesce" + (fun t -> t.stat_transaction_coalesce) + int + ; Dump.field "stat_transaction_abort" + (fun t -> t.stat_transaction_coalesce) + int + ; Dump.field "store" (fun t -> t.root) Node.pp_dump + ; Dump.field "quota" (fun t -> t.quota) Quota.pp_dump ] + + let equal s s' =3D + (* ignore stats *) + Node.equal s.root s'.root && Quota.equal s.quota s'.quota +end + +let pp_dump_store =3D Store.pp_dump +let equal_store =3D Store.equal + +module Xb =3D struct + open Xenbus.Xb + + module Op =3D struct + open Xenbus.Op + + let pp_dump =3D Fmt.of_to_string to_string + + let equal (op : t) (op' : t) =3D op =3D op' + end + + module Packet =3D struct + open Xenbus.Packet + + let pp_dump =3D + let open Fmt in + Dump.record + [ Dump.field "tid" get_tid int + ; Dump.field "rid" get_rid int + ; Dump.field "ty" get_ty Op.pp_dump + ; Dump.field "data" get_data Dump.string ] + + let equal (p : t) (p' : t) =3D + (* ignore TXID, it can be different after a live-update *) + p.rid =3D p'.rid && p.ty =3D p'.ty && p.data =3D p'.data + end + + module Partial =3D struct + open Xenbus.Partial + + let pp_dump =3D + let open Fmt in + Dump.record + [ Dump.field "tid" (fun p -> p.tid) int + ; Dump.field "rid" (fun p -> p.rid) int + ; Dump.field "ty" (fun p -> p.ty) Op.pp_dump + ; Dump.field "len" (fun p -> p.len) int + ; Dump.field "buf" (fun p -> p.buf) Fmt.buffer ] + + let equal p p' =3D + p.tid =3D p'.tid && p.rid =3D p'.rid && p.ty =3D p'.ty + && Buffer.contents p.buf =3D Buffer.contents p'.buf + end + + let pp_dump_partial_buf ppf =3D function + | HaveHdr pkt -> + Fmt.pf ppf "HaveHdr %a" Partial.pp_dump pkt + | NoHdr (i, b) -> + Fmt.pf ppf "NoHdr(%d, %S)" i (Bytes.to_string b) + + let equal_partial_buf buf buf' =3D + match (buf, buf') with + | HaveHdr pkt, HaveHdr pkt' -> + Partial.equal pkt pkt' + | NoHdr (i, b), NoHdr (i', b') -> + i =3D i' && b =3D b' + | HaveHdr _, NoHdr _ | NoHdr _, HaveHdr _ -> + false + + let pp_backend ppf =3D function + | Fd {fd} -> + Fmt.prefix (Fmt.const Fmt.string "Fd ") pp_file_descr ppf fd + | Xenmmap _ -> + Fmt.const Fmt.string "Xenmmap _" ppf () + + let equal_backend b b' =3D + match (b, b') with + | Fd fd, Fd fd' -> + fd =3D fd' + | Xenmmap _, Xenmmap _ -> + true (* can't extract the FD to compare *) + | Fd _, Xenmmap _ | Xenmmap _, Fd _ -> + false + + let pp_dump =3D + let open Fmt in + Dump.record + [ Dump.field "backend" (fun x -> x.backend) pp_backend + ; Dump.field "pkt_in" (fun x -> x.pkt_in) @@ Dump.queue Packet.pp_du= mp + ; Dump.field "pkt_out" (fun x -> x.pkt_out) @@ Dump.queue Packet.pp_= dump + ; Dump.field "partial_in" (fun x -> x.partial_in) pp_dump_partial_buf + ; Dump.field "partial_out" (fun x -> x.partial_out) Dump.string ] + + let equal_pkts xb xb' =3D + let queue_eq =3D queue_equal Packet.equal in + queue_eq xb.pkt_in xb'.pkt_in + && queue_eq xb.pkt_out xb'.pkt_out + && xb.partial_in =3D xb'.partial_in + && xb.partial_out =3D xb'.partial_out + + let equal xb xb' =3D equal_backend xb.backend xb'.backend && equal_pkts = xb xb' +end + +let pp_dump_packet =3D Xb.Packet.pp_dump +let pp_dump_xb =3D Xb.pp_dump +let equal_xb =3D Xb.equal +let equal_xb_pkts =3D Xb.equal_pkts + +module Packet =3D struct + open Packet + + let pp_dump_request =3D + let open Fmt in + Dump.record + [ Dump.field "tid" (fun t -> t.tid) int + ; Dump.field "rid" (fun t -> t.rid) int + ; Dump.field "ty" (fun t -> t.ty) Xb.Op.pp_dump + ; Dump.field "data" (fun t -> t.data) Dump.string ] + + let equal_req r r' =3D + r.tid =3D r'.tid && r.rid =3D r'.rid && r.ty =3D r'.ty && r.data =3D r= '.data + + let pp_dump_response ppf =3D function + | Reply str -> + Fmt.pf ppf "Reply %S" str + | Error str -> + Fmt.pf ppf "Error %S" str + | Ack _ -> + Fmt.string ppf "Ack" + + let equal_response =3D response_equal +end + +module Transaction =3D struct + open Transaction + + let pp_dump_ty ppf =3D function + | Transaction.No -> + Fmt.string ppf "No" + | Full (id, orig, canonical) -> + Fmt.pf ppf "Full @[(%d, %a, %a)@]" id Store.pp_dump orig Store.pp_= dump + canonical + + let equal_ty t t' =3D + match (t, t') with + | Transaction.No, Transaction.No -> + true + | Transaction.Full _, Transaction.Full _ -> + (* We expect the trees not to be identical, so we ignore any diffe= rences here. + The reply comparison tests will find any mismatches in observab= le transaction state + *) + true + | Transaction.No, Transaction.Full _ | Transaction.Full _, Transaction= .No -> + false + + let equal_pathop (op, path) (op', path') =3D + op =3D op' && Store.Path.equal path path' + + let pp_dump_op =3D Fmt.pair Packet.pp_dump_request Packet.pp_dump_respon= se + + let equal_op (req, reply) (req', reply') =3D + Packet.equal_req req req' && Packet.equal_response reply reply' + + let pp_dump =3D + let open Fmt in + let open Transaction in + Dump.record + [ Dump.field "ty" (fun t -> t.ty) pp_dump_ty + ; Dump.field "start_count" (fun t -> t.start_count) int64 + ; Dump.field "store" (fun t -> t.store) Store.pp_dump + ; Dump.field "quota" (fun t -> t.quota) Quota.pp_dump + ; Dump.field "must_fail" (fun t -> t.must_fail) Fmt.bool + ; Dump.field "paths" (fun t -> t.paths) + @@ Dump.list (pair Xb.Op.pp_dump Store.Path.pp_dump) + ; Dump.field "operations" (fun t -> t.operations) + @@ list (pair Packet.pp_dump_request Packet.pp_dump_response) + ; Dump.field "read_lowpath" (fun t -> t.read_lowpath) + @@ option Store.Path.pp_dump + ; Dump.field "write_lowpath" (fun t -> t.write_lowpath) + @@ option Store.Path.pp_dump ] + + let equal t t' =3D + equal_ty t.ty t'.ty + (* ignored: quota at start of transaction, not relevant + && Quota.equal t.quota t'.quota *) + (*&& list_equal equal_pathop t.paths t'.paths *) + (*&& list_equal equal_op t.operations t'.operations*) + && t.must_fail =3D t'.must_fail + (* ignore lowpath, impossible to recreate from limited migration info = *) + (*&& Option.equal Store.Path.equal t.read_lowpath t'.read_lowpath + && Option.equal Store.Path.equal t.write_lowpath t'.write_lowpath *) +end + +module Connection =3D struct + open Connection + + let pp_dump_watch =3D + let open Fmt in + Dump.record + [ Dump.field "token" (fun w -> w.token) Dump.string + ; Dump.field "path" (fun w -> w.path) Dump.string + ; Dump.field "base" (fun w -> w.base) Dump.string + ; Dump.field "is_relative" (fun w -> w.is_relative) Fmt.bool ] + + let pp_dump =3D + let open Fmt in + Dump.record + [ Dump.field "xb" (fun c -> c.xb) Xb.pp_dump + ; Dump.field "transactions" (fun c -> c.transactions) + @@ Dump.hashtbl int Transaction.pp_dump + ; Dump.field "next_tid" (fun t -> t.next_tid) int + ; Dump.field "nb_watches" (fun c -> c.nb_watches) int + ; Dump.field "anonid" (fun c -> c.anonid) int + ; Dump.field "watches" (fun c -> c.watches) + @@ Dump.hashtbl Dump.string (Dump.list pp_dump_watch) + ; Dump.field "perm" (fun c -> c.perm) + @@ Fmt.using Perms.Connection.to_string Fmt.string ] + + let equal c c' =3D + let watch_equal w w' =3D + (* avoid recursion, these must be physically equal *) + w.con =3D=3D c && w'.con =3D=3D c' && w.token =3D w'.token && w.path= =3D w'.path + && w.base =3D w'.base + && w.is_relative =3D w'.is_relative + in + Xb.equal c.xb c'.xb + && hashtable_equal Transaction.equal c.transactions c'.transactions + (* next_tid ignored, not preserved *) + && hashtable_equal (list_equal watch_equal) c.watches c'.watches + && c.nb_watches =3D c'.nb_watches + (* anonid ignored, not preserved *) + (* && c.anonid =3D c'.anonid *) && c.perm =3D c'.perm + + let equal_watch w w' =3D + equal w.con w'.con && w.token =3D w'.token && w.path =3D w'.path + && w.base =3D w'.base + && w.is_relative =3D w'.is_relative +end + +module Trie =3D struct + open Trie + + let pp_dump dump_elt =3D + Fmt.Dump.iter_bindings Trie.iter (Fmt.any "trie") Fmt.string + Fmt.(option dump_elt) + + let plus1 _ _ acc =3D acc + 1 + + let length t =3D fold plus1 t 0 + + (* Trie.iter doesn't give full path so we can't compare the paths/values= exactly. + They will be compared as part of the individual connections + *) + let equal _eq t t' =3D length t =3D length t' +end + +module Connections =3D struct + open Connections + + let pp_dump =3D + let open Fmt in + Dump.record + [ Dump.field "anonymous" (fun t -> t.anonymous) + @@ Dump.hashtbl Fmt.(any "") Connection.pp_dump + ; Dump.field "domains" (fun t -> t.domains) + @@ Dump.hashtbl Fmt.int Connection.pp_dump + ; Dump.field "ports" (fun t -> t.ports) + @@ Dump.hashtbl + (Fmt.using Xeneventchn.to_int Fmt.int) + Connection.pp_dump + ; Dump.field "watches" (fun t -> t.watches) + @@ Trie.pp_dump (Dump.list Connection.pp_dump_watch) ] + + let equal c c' =3D + hashtable_equal Connection.equal c.anonymous c'.anonymous + && hashtable_equal Connection.equal c.domains c'.domains + (* TODO: local port changes for now *) + (*&& hashtable_equal Connection.equal c.ports c'.ports *) + && Trie.equal (list_equal Connection.equal_watch) c.watches c'.watches +end + +let pp_dump_connections =3D Connections.pp_dump +let equal_connections =3D Connections.equal + +module Domain =3D struct + open Domain + + let pp_dump =3D + let open Fmt in + Dump.record + [ Dump.field "id" Domain.get_id int + ; Dump.field "remote_port" Domain.get_remote_port int + ; Dump.field "bad_client" Domain.is_bad_domain bool + ; Dump.field "io_credit" Domain.get_io_credit int + ; Dump.field "conflict_credit" (fun t -> t.conflict_credit) float + ; Dump.field "caused_conflicts" (fun t -> t.caused_conflicts) int64 ] + + (* ignore stats fields *) + let equal t t' =3D t.id =3D t'.id && t.remote_port =3D t'.remote_port +end + +module Domains =3D struct + open Domains + + let pp_dump =3D + let open Fmt in + Dump.record + [ Dump.field "table" (fun t -> t.table) + @@ Dump.hashtbl Fmt.int Domain.pp_dump + ; Dump.field "doms_conflict_paused" (fun t -> t.doms_conflict_paused) + @@ Dump.queue (pp_dump_ref @@ Dump.option Domain.pp_dump) + ; Dump.field "doms_with_conflict_penalty" (fun t -> + t.doms_with_conflict_penalty) + @@ Dump.queue (pp_dump_ref @@ Dump.option Domain.pp_dump) + ; Dump.field "n_paused" (fun t -> t.n_paused) int + ; Dump.field "n_penalised" (fun t -> t.n_penalised) int ] + + (* ignore statistic fields *) + let equal t t' =3D hashtable_equal Domain.equal t.table t'.table +end +let pp_dump_domains =3D Domains.pp_dump +let equal_domains =3D Domains.equal diff --git a/tools/ocaml/xenstored/test/xenstored_test.ml b/tools/ocaml/xen= stored/test/xenstored_test.ml index e86b68e867..acf3209087 100644 --- a/tools/ocaml/xenstored/test/xenstored_test.ml +++ b/tools/ocaml/xenstored/test/xenstored_test.ml @@ -1,2 +1,147 @@ -open Xenstored -let () =3D () +open Testable +open Generator +module Cb =3D Crowbar + +let random_path =3D Cb.list Cb.bytes + +let value =3D Cb.bytes + +let token =3D Cb.bytes + +let permty =3D + [Perms.READ; Perms.WRITE; Perms.RDWR; Perms.NONE] + |> List.map Cb.const |> Cb.choose + +let new_domid =3D Cb.range ~min:1 Types.domid_first_reserved + +let port =3D Cb.range 0xFFFF_FFFF (*uint32_t*) + +let arb_cmd =3D + let open Command in + let path =3D + Cb.choose + [ Cb.map [Cb.int] (fun rnd state -> PathObserver.choose_path state r= nd) + ; Cb.map [random_path] (fun x _ -> Store.Path.to_string x) ] + in + let domid =3D + Cb.map [Cb.int] (fun rnd state -> PathObserver.choose_domid state rnd) + in + let perms =3D + Cb.map [domid; permty; Cb.pair domid permty |> Cb.list] + @@ fun idgen owner other state -> + let other =3D List.map (fun (idgen, ty) -> (idgen state, ty)) other in + Perms.Node.create (idgen state) owner other + in + let guard' ~f gen state =3D + let v =3D gen state in + Cb.guard (f v) ; + v + in + let cmd =3D + let open Testable.Command in + Cb.choose + [ Cb.map [path] cmd_read + ; Cb.map [path; value] cmd_write + ; Cb.map [path] cmd_mkdir + ; Cb.map [path] (fun p -> cmd_rm @@ guard' ~f:(fun p -> p <> "/") p) + ; Cb.map [path] cmd_directory + ; Cb.map [path] cmd_getperms + ; Cb.map [path; perms] cmd_setperms + ; Cb.map [path; token] cmd_watch + ; Cb.map [path; token] cmd_unwatch + ; Cb.const cmd_reset_watches + ; Cb.const cmd_transaction_start + ; Cb.map [Cb.bool] cmd_transaction_end + ; Cb.map [new_domid; port] cmd_introduce + ; Cb.map [domid] (fun idgen -> + cmd_release @@ guard' ~f:(fun id -> id <> 0) idgen) + ; Cb.map [domid] cmd_getdomainpath + ; Cb.map [domid] cmd_isintroduced + ; Cb.map [domid; domid] cmd_set_target + ; Cb.const cmd_liveupdate ] + in + Cb.map [domid; Cb.int; cmd] (fun this rnd cmd state -> + let this =3D this state in + let txid =3D PathObserver.choose_txid_opt state this rnd in + let cmd =3D cmd txid state in + (this, cmd)) + +(* based on QCSTM *) +module Make (Spec : sig + include Testable.S + + val arb_cmd : (state -> cmd) Crowbar.gen +end) =3D +struct + let arb_cmds =3D + Crowbar.with_printer (Fmt.Dump.list Spec.pp) + @@ Crowbar.map [Crowbar.list1 Spec.arb_cmd] (fun cmdgens -> + let cmds, _ =3D + List.fold_left + (fun (cmds, s) f -> + let cmd =3D f s in + Crowbar.check (Spec.precond cmd s) ; + (cmd :: cmds, Spec.next_state cmd s)) + ([], Spec.init_state) cmdgens + in + List.rev cmds) + + let interp_agree sut cs =3D + List.fold_left + (fun s cmd -> + Crowbar.check + ( try Spec.run_cmd cmd s sut + with Failure msg -> Crowbar.failf "%a" Fmt.lines msg ) ; + Spec.next_state cmd s) + Spec.init_state cs + + let agree_prop cs =3D + let on_exn e bt logs =3D + List.iter prerr_endline logs ; + Printexc.raise_with_backtrace e bt + in + Testable.with_logger ~on_exn (fun () -> + let sut =3D Spec.init_sut () in + Stdext.finally (fun () ->=20 + let (_ : Spec.state) =3D interp_agree sut cs in ()) + (fun () ->=20 + Spec.cleanup sut)) + + let agree_test ~name =3D Crowbar.add_test ~name [arb_cmds] agree_prop +end + +module LU =3D Make (struct + include PathObserver + + type cmd =3D int * Testable.Command.t + + type sut =3D Testable.t ref * Testable.t ref + + let arb_cmd =3D arb_cmd + + let init_sut () =3D + let sut1 =3D Testable.create () in + Testable.init sut1 ; + let sut2 =3D Testable.create ~live_update:true () in + Testable.init sut2 ; + let sut1 =3D ref sut1 in + let sut2 =3D ref sut2 in + (sut1, sut2) + + let cleanup (sut1, sut2) =3D + Testable.cleanup !sut1 ; Testable.cleanup !sut2 + + let run_cmd cmd state (sut1, sut2) =3D + Testable.run2 state.next_tid sut1 sut2 cmd ; + true +end) + +let () =3D + (* Crowbar runs at_exit, and after bisect's coverage dumper, + registering an at_exit here would run *before* Crowbar starts, + hence the nested at_exit which puts the bisect dumper in the proper p= lace + to dump coverage *after* crowbar is finished. + *) + (* at_exit (fun () -> at_exit Bisect.Runtime.write_coverage_data);*) + print_endline ""; + LU.agree_test ~name:"live-update-agree"; diff --git a/tools/ocaml/xenstored/test/xs_protocol.ml b/tools/ocaml/xensto= red/test/xs_protocol.ml new file mode 100644 index 0000000000..b5da2aff34 --- /dev/null +++ b/tools/ocaml/xenstored/test/xs_protocol.ml @@ -0,0 +1,733 @@ +(* + * Copyright (C) Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +let ( |> ) f g =3D g f +let ( ++ ) f g x =3D f (g x) + +module Op =3D struct + type t =3D + | Debug | Directory | Read | Getperms + | Watch | Unwatch | Transaction_start + | Transaction_end | Introduce | Release + | Getdomainpath | Write | Mkdir | Rm + | Setperms | Watchevent | Error | Isintroduced + | Resume | Set_target + | Reset_watches | Directory_part + + let to_int32 =3D function + | Debug -> 0l + | Directory -> 1l + | Read -> 2l + | Getperms -> 3l + | Watch -> 4l + | Unwatch -> 5l + | Transaction_start -> 6l + | Transaction_end -> 7l + | Introduce -> 8l + | Release -> 9l + | Getdomainpath -> 10l + | Write -> 11l + | Mkdir -> 12l + | Rm -> 13l + | Setperms -> 14l + | Watchevent -> 15l + | Error -> 16l + | Isintroduced -> 17l + | Resume -> 18l + | Set_target -> 19l + | Reset_watches -> 21l (* 20 is reserved *) + | Directory_part -> 22l + + (* The index of the value in the array is the integer representation used + by the wire protocol. Every element of t exists exactly once in the a= rray. *) + let on_the_wire =3D + let a =3D Array.make 23 None in + ListLabels.iter + ~f:(fun v -> a.(v |> to_int32 |> Int32.to_int) <- Some v) + [ Debug; Directory; Read; Getperms; Watch; Unwatch; Transaction_start + ; Transaction_end; Introduce; Release; Getdomainpath; Write; Mkdir; = Rm + ; Setperms; Watchevent; Error; Isintroduced; Resume; Set_target + ; Reset_watches; Directory_part ] ; + a + + let of_int32 i =3D + let i =3D Int32.to_int i in + if i >=3D 0 && i < Array.length on_the_wire then on_the_wire.(i) else = None + + let to_string =3D function + | Debug -> "debug" + | Directory -> "directory" + | Read -> "read" + | Getperms -> "getperms" + | Watch -> "watch" + | Unwatch -> "unwatch" + | Transaction_start -> "transaction_start" + | Transaction_end -> "transaction_end" + | Introduce -> "introduce" + | Release -> "release" + | Getdomainpath -> "getdomainpath" + | Write -> "write" + | Mkdir -> "mkdir" + | Rm -> "rm" + | Setperms -> "setperms" + | Watchevent -> "watchevent" + | Error -> "error" + | Isintroduced -> "isintroduced" + | Resume -> "resume" + | Set_target -> "set_target" + | Reset_watches -> "reset_watches" + | Directory_part -> "directory_part" +end + +let split_string ?limit:(limit=3Dmax_int) c s =3D + let len =3D String.length s in + let next_c from =3D + try + Some (String.index_from s from c) + with + | Not_found -> None + in + let decr n =3D max 0 (n-1) in + let rec loop n from acc =3D + match decr n, next_c from with + | 0, _ + | _, None -> + (* No further instances of c, or we've reached limit *) + String.sub s from (len - from) :: acc + | n', Some idx -> + let a =3D String.sub s from (idx - from) in + (loop[@tailcall]) n' (idx + 1) (a :: acc) + in loop limit 0 [] |> List.rev + + +module ACL =3D struct + type perm =3D + | NONE + | READ + | WRITE + | RDWR + + let char_of_perm =3D function + | READ -> 'r' + | WRITE -> 'w' + | RDWR -> 'b' + | NONE -> 'n' + + let perm_of_char =3D function + | 'r' -> Some READ + | 'w' -> Some WRITE + | 'b' -> Some RDWR + | 'n' -> Some NONE + | _ -> None + + type domid =3D int + + type t =3D { + owner: domid; (** domain which "owns", has full access *) + other: perm; (** default permissions for all others... *) + acl: (domid * perm) list; (** ... unless overridden in the ACL *) + } + + let to_string perms =3D + let string_of_perm (id, perm) =3D Printf.sprintf "%c%u" (char_of_perm = perm) id in + String.concat "\000" (List.map string_of_perm ((perms.owner,perms.othe= r) :: perms.acl)) + + let of_string s =3D + (* A perm is stored as 'domid' *) + let perm_of_char_exn x =3D match (perm_of_char x) with Some y -> y | N= one -> raise Not_found in + try + let perm_of_string s =3D + if String.length s < 2 + then invalid_arg (Printf.sprintf "Permission string too short: '%s= '" s); + int_of_string (String.sub s 1 (String.length s - 1)), perm_of_char= _exn s.[0] in + let l =3D List.map perm_of_string (split_string '\000' s) in + match l with + | (owner, other) :: l -> Some { owner =3D owner; other =3D other; ac= l =3D l } + | [] -> Some { owner =3D 0; other =3D NONE; acl =3D [] } + with _ -> + None +end + +type t =3D { + tid: int32; + rid: int32; + ty: Op.t; + len: int; + data: Buffer.t; +} + +let sizeof_header =3D 16 +let get_header_ty v =3D Cstruct.LE.get_uint32 v 0 +let set_header_ty v x =3D Cstruct.LE.set_uint32 v 0 x +let get_header_rid v =3D Cstruct.LE.get_uint32 v 4 +let set_header_rid v x =3D Cstruct.LE.set_uint32 v 4 x +let get_header_tid v =3D Cstruct.LE.get_uint32 v 8 +let set_header_tid v x =3D Cstruct.LE.set_uint32 v 8 x +let get_header_len v =3D Cstruct.LE.get_uint32 v 12 +let set_header_len v x =3D Cstruct.LE.set_uint32 v 12 x + +let to_bytes pkt =3D + let header =3D Cstruct.create sizeof_header in + let len =3D Int32.of_int (Buffer.length pkt.data) in + let ty =3D Op.to_int32 pkt.ty in + set_header_ty header ty; + set_header_rid header pkt.rid; + set_header_tid header pkt.tid; + set_header_len header len; + let result =3D Buffer.create 64 in + Buffer.add_bytes result (Cstruct.to_bytes header); + Buffer.add_buffer result pkt.data; + Buffer.to_bytes result + +let get_tid pkt =3D pkt.tid +let get_ty pkt =3D pkt.ty +let get_data pkt =3D + if pkt.len > 0 && Buffer.nth pkt.data (pkt.len - 1) =3D '\000' then + Buffer.sub pkt.data 0 (pkt.len - 1) + else + Buffer.contents pkt.data +let get_rid pkt =3D pkt.rid + +module Parser =3D struct + (** Incrementally parse packets *) + + let header_size =3D 16 + + let xenstore_payload_max =3D 4096 (* xen/include/public/io/xs_wire.h *) + + let allow_oversize_packets =3D ref true + + type state =3D + | Unknown_operation of int32 + | Parser_failed of string + | Need_more_data of int + | Packet of t + + type parse =3D + | ReadingHeader of int * bytes + | ReadingBody of t + | Finished of state + + let start () =3D ReadingHeader (0, Bytes.make header_size '\000') + + let state =3D function + | ReadingHeader(got_already, _) -> Need_more_data (header_size - got_a= lready) + | ReadingBody pkt -> Need_more_data (pkt.len - (Buffer.length pkt.data= )) + | Finished r -> r + + let parse_header str =3D + let header =3D Cstruct.create sizeof_header in + Cstruct.blit_from_string str 0 header 0 sizeof_header; + let ty =3D get_header_ty header in + let rid =3D get_header_rid header in + let tid =3D get_header_tid header in + let len =3D get_header_len header in + + let len =3D Int32.to_int len in + (* A packet which is bigger than xenstore_payload_max is illegal. + This will leave the guest connection is a bad state and will + be hard to recover from without restarting the connection + (ie rebooting the guest) *) + let len =3D if !allow_oversize_packets then len else max 0 (min xensto= re_payload_max len) in + + begin match Op.of_int32 ty with + | Some ty -> + let t =3D { + tid =3D tid; + rid =3D rid; + ty =3D ty; + len =3D len; + data =3D Buffer.create len; + } in + if len =3D 0 + then Finished (Packet t) + else ReadingBody t + | None -> Finished (Unknown_operation ty) + end + + let input state (bytes : string) =3D + match state with + | ReadingHeader(got_already, (str : bytes)) -> + Bytes.blit_string bytes 0 str got_already (String.length bytes); + let got_already =3D got_already + (String.length bytes) in + if got_already < header_size + then ReadingHeader(got_already, str) + else parse_header (Bytes.to_string str) + | ReadingBody x -> + Buffer.add_string x.data bytes; + let needed =3D x.len - (Buffer.length x.data) in + if needed > 0 + then ReadingBody x + else Finished (Packet x) + | Finished f -> Finished f +end + +(* Should we switch to an explicit stream abstraction here? *) +module type IO =3D sig + type 'a t + val return: 'a -> 'a t + val ( >>=3D ): 'a t -> ('a -> 'b t) -> 'b t + + type channel + val read: channel -> bytes -> int -> int -> int t + val write: channel -> bytes -> int -> int -> unit t +end + +exception Unknown_xenstore_operation of int32 +exception Response_parser_failed of string +exception EOF + +type ('a, 'b) result =3D + | Ok of 'a + | Exception of 'b + +module PacketStream =3D functor(IO: IO) -> struct + let ( >>=3D ) =3D IO.( >>=3D ) + let return =3D IO.return + + type stream =3D { + channel: IO.channel; + mutable incoming_pkt: Parser.parse; (* incrementally parses the next p= acket *) + } + + let make t =3D { + channel =3D t; + incoming_pkt =3D Parser.start (); + } + + (* [recv client] returns a single Packet, or fails *) + let rec recv t =3D + let open Parser in match Parser.state t.incoming_pkt with + | Packet pkt -> + t.incoming_pkt <- start (); + return (Ok pkt) + | Need_more_data x -> + let buf =3D Bytes.make x '\000' in + IO.read t.channel buf 0 x + >>=3D (function + | 0 -> return (Exception EOF) + | n -> + let fragment =3D Bytes.sub_string buf 0 n in + t.incoming_pkt <- input t.incoming_pkt fragment; + recv t) + | Unknown_operation x -> return (Exception (Unknown_xenstore_operation= x)) + | Parser_failed x -> return (Exception (Response_parser_failed x)) + + (* [send client pkt] sends [pkt] and returns (), or fails *) + let send t request =3D + let req =3D to_bytes request in + IO.write t.channel req 0 (Bytes.length req) +end + +module Token =3D struct + type t =3D string + + (** [to_user_string x] returns the user-supplied part of the watch token= *) + let to_user_string x =3D Scanf.sscanf x "%d:%s" (fun _ x -> x) + + let to_debug_string x =3D x + + let of_string x =3D x + let to_string x =3D x +end + +let data_concat ls =3D (String.concat "\000" ls) ^ "\000" + +let create tid rid ty data =3D + let len =3D String.length data in + let b =3D Buffer.create len in + Buffer.add_string b data; + { + tid =3D tid; + rid =3D rid; + ty =3D ty; + len =3D len; + data =3D b; + } + +module Response =3D struct + + type payload =3D + | Read of string + | Directory of string list + | Getperms of ACL.t + | Getdomainpath of string + | Transaction_start of int32 + | Write + | Mkdir + | Rm + | Setperms + | Watch + | Unwatch + | Transaction_end + | Debug of string list + | Introduce + | Resume + | Release + | Set_target + | Reset_watches + | Directory_part of int * string list + | Isintroduced of bool + | Error of string + | Watchevent of string * string + + let prettyprint_payload =3D + let open Printf in function + | Read x -> sprintf "Read %s" x + | Directory xs -> sprintf "Directory [ %s ]" (String.concat "; " xs) + | Getperms acl -> sprintf "Getperms %s" (ACL.to_string acl) + | Getdomainpath p -> sprintf "Getdomainpath %s" p + | Transaction_start x -> sprintf "Transaction_start %ld" x + | Write -> "Write" + | Mkdir -> "Mkdir" + | Rm -> "Rm" + | Setperms -> "Setperms" + | Watch -> "Watch" + | Unwatch -> "Unwatch" + | Transaction_end -> "Transaction_end" + | Debug xs -> sprintf "Debug [ %s ]" (String.concat "; " xs) + | Introduce -> "Introduce" + | Resume -> "Resume" + | Release -> "Release" + | Set_target -> "Set_target" + | Reset_watches -> "Reset_watches" + | Directory_part (gencnt, xs) -> + sprintf "Directory_part #%d [ %s ]" gencnt (String.concat "; " x= s) + | Isintroduced x -> sprintf "Isintroduced %b" x + | Error x -> sprintf "Error %s" x + | Watchevent (x, y) -> sprintf "Watchevent %s %s" x y + + let ty_of_payload =3D function + | Read _ -> Op.Read + | Directory _ -> Op.Directory + | Getperms _ -> Op.Getperms + | Getdomainpath _ -> Op.Getdomainpath + | Transaction_start _ -> Op.Transaction_start + | Debug _ -> Op.Debug + | Isintroduced _ -> Op.Isintroduced + | Watchevent (_, _) -> Op.Watchevent + | Error _ -> Op.Error + | Write -> Op.Write + | Mkdir -> Op.Mkdir + | Rm -> Op.Rm + | Setperms -> Op.Setperms + | Watch -> Op.Watch + | Unwatch -> Op.Unwatch + | Transaction_end -> Op.Transaction_end + | Introduce -> Op.Introduce + | Resume -> Op.Resume + | Release -> Op.Release + | Set_target -> Op.Set_target + | Reset_watches -> Op.Reset_watches + | Directory_part _ -> Op.Directory_part + + let ok =3D "OK\000" + + let data_of_payload =3D function + | Read x -> x + | Directory ls -> if ls =3D [] then "" else data_concat ls + | Getperms perms -> data_concat [ ACL.to_string perms ] + | Getdomainpath x -> data_concat [ x ] + | Transaction_start tid -> data_concat [ Int32.to_string tid ] + | Debug items -> data_concat items + | Isintroduced b -> data_concat [ if b then "T" else "F" ] + | Watchevent (path, token) -> data_concat [ path; token ] + | Error x -> data_concat [ x ] + | _ -> ok + + let print x tid rid =3D + create tid rid (ty_of_payload x) (data_of_payload x) +end + +module Request =3D struct + + type path_op =3D + | Read + | Directory + | Directory_part of int + | Getperms + | Write of string + | Mkdir + | Rm + | Setperms of ACL.t + + type payload =3D + | PathOp of string * path_op + | Getdomainpath of int + | Transaction_start + | Watch of string * string + | Unwatch of string * string + | Transaction_end of bool + | Debug of string list + | Introduce of int * Nativeint.t * int + | Resume of int + | Release of int + | Set_target of int * int + | Reset_watches + | Isintroduced of int + | Error of string + | Watchevent of string + + open Printf + + let prettyprint_pathop x =3D function + | Read -> sprintf "Read %s" x + | Directory -> sprintf "Directory %s" x + | Directory_part off -> sprintf "Directory %s @%d" x off + | Getperms -> sprintf "Getperms %s" x + | Write v -> sprintf "Write %s %s" x v + | Mkdir -> sprintf "Mkdir %s" x + | Rm -> sprintf "Rm %s" x + | Setperms acl -> sprintf "Setperms %s %s" x (ACL.to_string acl) + + let prettyprint_payload =3D function + | PathOp (path, op) -> prettyprint_pathop path op + | Getdomainpath x -> sprintf "Getdomainpath %d" x + | Transaction_start -> "Transaction_start" + | Watch (x, y) -> sprintf "Watch %s %s" x y + | Unwatch (x, y) -> sprintf "Unwatch %s %s" x y + | Transaction_end x -> sprintf "Transaction_end %b" x + | Debug xs -> sprintf "Debug [ %s ]" (String.concat "; " xs) + | Introduce (x, n, y) -> sprintf "Introduce %d %nu %d" x n y + | Resume x -> sprintf "Resume %d" x + | Release x -> sprintf "Release %d" x + | Set_target (x, y) -> sprintf "Set_target %d %d" x y + | Reset_watches -> "Reset_watches" + | Isintroduced x -> sprintf "Isintroduced %d" x + | Error x -> sprintf "Error %s" x + | Watchevent x -> sprintf "Watchevent %s" x + + exception Parse_failure + + let strings data =3D split_string '\000' data + + let one_string data =3D + let args =3D split_string ~limit:2 '\000' data in + match args with + | x :: [] -> x + | _ -> + raise Parse_failure + + let two_strings data =3D + let args =3D split_string ~limit:2 '\000' data in + match args with + | a :: b :: [] -> a, b + | a :: [] -> a, "" (* terminating NULL removed by get_data *) + | _ -> + raise Parse_failure + + let acl x =3D match ACL.of_string x with + | Some x -> x + | None -> + raise Parse_failure + + let domid s =3D + let v =3D ref 0 in + let is_digit c =3D c >=3D '0' && c <=3D '9' in + let len =3D String.length s in + let i =3D ref 0 in + while !i < len && not (is_digit s.[!i]) do incr i done; + while !i < len && is_digit s.[!i] + do + let x =3D (Char.code s.[!i]) - (Char.code '0') in + v :=3D !v * 10 + x; + incr i + done; + !v + + let bool =3D function + | "F" -> false + | "T" -> true + | _ -> + raise Parse_failure + + let parse_exn request =3D + let data =3D get_data request in + match get_ty request with + | Op.Read -> PathOp (data |> one_string, Read) + | Op.Directory -> PathOp (data |> one_string, Directory) + | Op.Getperms -> PathOp (data |> one_string, Getperms) + | Op.Getdomainpath -> Getdomainpath (data |> one_string |> domid) + | Op.Transaction_start -> Transaction_start + | Op.Write -> + let path, value =3D two_strings data in + PathOp (path, Write value) + | Op.Mkdir -> PathOp (data |> one_string, Mkdir) + | Op.Rm -> PathOp (data |> one_string, Rm) + | Op.Setperms -> + let path, perms =3D two_strings data in + let perms =3D acl perms in + PathOp(path, Setperms perms) + | Op.Watch -> + let path, token =3D two_strings data in + Watch(path, token) + | Op.Unwatch -> + let path, token =3D two_strings data in + Unwatch(path, token) + | Op.Transaction_end -> Transaction_end(data |> one_string |> bool) + | Op.Debug -> Debug (strings data) + | Op.Introduce -> + begin match strings data with + | d :: mfn :: port :: _ -> + let d =3D domid d in + let mfn =3D Nativeint.of_string mfn in + let port =3D int_of_string port in + Introduce (d, mfn, port) + | _ -> + raise Parse_failure + end + | Op.Resume -> Resume (data |> one_string |> domid) + | Op.Release -> Release (data |> one_string |> domid) + | Op.Set_target -> + let mine, yours =3D two_strings data in + let mine =3D domid mine and yours =3D domid yours in + Set_target(mine, yours) + | Op.Reset_watches -> Reset_watches + | Op.Directory_part -> + let path, offstr =3D two_strings data in + PathOp (path, Directory_part (int_of_string offstr)) + | Op.Isintroduced -> Isintroduced (data |> one_string |> domid) + | Op.Error -> Error(data |> one_string) + | Op.Watchevent -> Watchevent(data |> one_string) + + let parse request =3D + try + Some (parse_exn request) + with _ -> None + + let prettyprint request =3D + Printf.sprintf "tid =3D %ld; rid =3D %ld; payload =3D %s" + (get_tid request) (get_rid request) + (match parse request with + | None -> "None" + | Some x -> "Some " ^ (prettyprint_payload x)) + + let ty_of_payload =3D function + | PathOp(_, Directory) -> Op.Directory + | PathOp(_, Read) -> Op.Read + | PathOp(_, Getperms) -> Op.Getperms + | Debug _ -> Op.Debug + | Watch (_, _) -> Op.Watch + | Unwatch (_, _) -> Op.Unwatch + | Transaction_start -> Op.Transaction_start + | Transaction_end _ -> Op.Transaction_end + | Introduce(_, _, _) -> Op.Introduce + | Release _ -> Op.Release + | Resume _ -> Op.Resume + | Getdomainpath _ -> Op.Getdomainpath + | PathOp(_, Write _) -> Op.Write + | PathOp(_, Mkdir) -> Op.Mkdir + | PathOp(_, Rm) -> Op.Rm + | PathOp(_, Setperms _) -> Op.Setperms + | Set_target (_, _) -> Op.Set_target + | Reset_watches -> Op.Reset_watches + | PathOp(_, Directory_part _) -> Op.Directory_part + | Isintroduced _ -> Op.Isintroduced + | Error _ -> Op.Error + | Watchevent _ -> Op.Watchevent + + let transactional_of_payload =3D function + | PathOp(_, _) + | Transaction_end _ -> true + | _ -> false + + let data_of_payload =3D function + | PathOp(path, Write value) -> + path ^ "\000" ^ value (* no NULL at the end *) + | PathOp(path, Setperms perms) -> + data_concat [ path; ACL.to_string perms ] + | PathOp(path, _) -> data_concat [ path ] + | Debug commands -> data_concat commands + | Watch (path, token) + | Unwatch (path, token) -> data_concat [ path; token ] + | Transaction_start -> data_concat [] + | Transaction_end commit -> data_concat [ if commit then "T" else "F" ] + | Introduce(domid, mfn, port) -> + data_concat [ + Printf.sprintf "%u" domid; + Printf.sprintf "%nu" mfn; + string_of_int port; + ] + | Release domid + | Resume domid + | Getdomainpath domid + | Isintroduced domid -> + data_concat [ Printf.sprintf "%u" domid; ] + | Reset_watches -> data_concat [] + | Set_target (mine, yours) -> + data_concat [ Printf.sprintf "%u" mine; Printf.sprintf "%u" yours; ] + | Error _ -> + failwith "Unimplemented: data_of_payload (Error)" + | Watchevent _ -> + failwith "Unimplemented: data_of_payload (Watchevent)" + + let print x tid rid =3D + create + (if transactional_of_payload x then tid else 0l) + rid + (ty_of_payload x) + (data_of_payload x) +end + +module Unmarshal =3D struct + let some x =3D Some x + let int_of_string_opt x =3D try Some(int_of_string x) with _ -> None + let int32_of_string_opt x =3D try Some(Int32.of_string x) with _ -> None + let unit_of_string_opt x =3D if x =3D "" then Some () else None + let ok x =3D if x =3D "OK" then Some () else None + + let string =3D some ++ get_data + let list =3D some ++ split_string '\000' ++ get_data + let acl =3D ACL.of_string ++ get_data + let int =3D int_of_string_opt ++ get_data + let int32 =3D int32_of_string_opt ++ get_data + let unit =3D unit_of_string_opt ++ get_data + let ok =3D ok ++ get_data +end + +exception Enoent of string +exception Eagain +exception Eexist +exception Invalid +exception Error of string + +let response hint sent received f =3D match get_ty sent, get_ty received w= ith + | _, Op.Error -> + begin match get_data received with + | "ENOENT" -> raise (Enoent hint) + | "EAGAIN" -> raise Eagain + | "EINVAL" -> raise Invalid + | "EEXIST" -> raise Eexist + | s -> raise (Error s) + end + | x, y when x =3D y -> + begin match f received with + | None -> raise (Error (Printf.sprintf "failed to parse response (hi= nt:%s) (payload:%s)" hint (get_data received))) + | Some z -> z + end + | x, y -> + raise (Error (Printf.sprintf "unexpected packet: expected %s; got %s" = (Op.to_string x) (Op.to_string y))) + +type address =3D + | Unix of string + | Domain of int + +let string_of_address =3D function + | Unix x -> x + | Domain x -> string_of_int x + +let domain_of_address =3D function + | Unix _ -> 0 + | Domain x -> x + diff --git a/tools/ocaml/xenstored/transaction.ml b/tools/ocaml/xenstored/t= ransaction.ml index 17b1bdf2ea..0466b04ae3 100644 --- a/tools/ocaml/xenstored/transaction.ml +++ b/tools/ocaml/xenstored/transaction.ml @@ -82,6 +82,7 @@ type t =3D { start_count: int64; store: Store.t; (* This is the store that we change in write operations. = *) quota: Quota.t; + mutable must_fail: bool; oldroot: Store.Node.t; mutable paths: (Xenbus.Xb.Op.operation * Store.Path.t) list; mutable operations: (Packet.request * Packet.response) list; @@ -89,7 +90,7 @@ type t =3D { mutable write_lowpath: Store.Path.t option; } let get_id t =3D match t.ty with No -> none | Full (id, _, _) -> id - +let mark_failed t =3D t.must_fail <- true let counter =3D ref 0L let failed_commits =3D ref 0L let failed_commits_no_culprit =3D ref 0L @@ -117,6 +118,8 @@ let trim_short_running_transactions txn =3D keep !short_running_txns =20 +let invalid_op =3D Xenbus.Xb.Op.Invalid, [] + let make ?(internal=3Dfalse) id store =3D let ty =3D if id =3D none then No else Full(id, Store.copy store, store) = in let txn =3D { @@ -129,6 +132,7 @@ let make ?(internal=3Dfalse) id store =3D operations =3D []; read_lowpath =3D None; write_lowpath =3D None; + must_fail =3D false; } in if id <> none && not internal then ( let now =3D Unix.gettimeofday () in @@ -139,10 +143,11 @@ let make ?(internal=3Dfalse) id store =3D let get_store t =3D t.store let get_paths t =3D t.paths =20 +let is_read_only t =3D t.paths =3D [] && not t.must_fail let get_root t =3D Store.get_root t.store =20 -let is_read_only t =3D t.paths =3D [] let add_wop t ty path =3D t.paths <- (ty, path) :: t.paths +let clear_wops t =3D t.paths <- [] let add_operation ~perm t request response =3D if !Define.maxrequests >=3D 0 && not (Perms.Connection.is_dom0 perm) @@ -151,7 +156,9 @@ let add_operation ~perm t request response =3D t.operations <- (request, response) :: t.operations let get_operations t =3D List.rev t.operations let set_read_lowpath t path =3D t.read_lowpath <- get_lowest path t.read_l= owpath -let set_write_lowpath t path =3D t.write_lowpath <- get_lowest path t.writ= e_lowpath +let set_write_lowpath t path =3D + Logging.debug "transaction" "set_writelowpath (%d) %s" (get_id t) (Stor= e.Path.to_string path); + t.write_lowpath <- get_lowest path t.write_lowpath =20 let path_exists t path =3D Store.path_exists t.store path =20 @@ -200,7 +207,7 @@ let commit ~con t =3D let has_commited =3D match t.ty with | No -> true - | Full (_id, oldstore, cstore) -> (* "cstore" meaning current canon= ical store *) + | Full (id, oldstore, cstore) -> (* "cstore" meaning current canoni= cal store *) let commit_partial oldroot cstore store =3D (* get the lowest path of the query and verify that it hasn't been modified by others transactions. *) @@ -240,11 +247,16 @@ let commit ~con t =3D (* we try a partial commit if possible *) commit_partial oldroot cstore store in + if t.must_fail then begin + Logging.info "transaction" "Transaction %d was marked to fail (by live-= update)" id; + false + end else if !test_eagain && Random.int 3 =3D 0 then false else try_commit (Store.get_root oldstore) cstore t.store in + Logging.info "transaction" "has_commited: %b" has_commited; if has_commited && has_write_ops then Disk.write t.store; if not has_commited @@ -252,3 +264,102 @@ let commit ~con t =3D else if not !has_coalesced then Logging.commit ~tid:(get_id t) ~con; has_commited + +module LR =3D Disk.LiveRecord + +(* here instead of Store.ml to avoid dependency cycle *) +let write_node ch txidaccess path node =3D + let value =3D Store.Node.get_value node in + let perms =3D Store.Node.get_perms node in + let path =3D Store.Path.of_path_and_name path (Symbol.to_string node.Stor= e.Node.name) |> Store.Path.to_string in + LR.write_node_data ch ~txidaccess ~path ~value ~perms + +let split limit c s =3D + let limit =3D match limit with None -> 8 | Some x -> x in + String.split ~limit c s +=09 +exception Invalid_Cmd_Args +let split_one_path data conpath =3D + let args =3D split (Some 2) '\000' data in + match args with + | path :: "" :: [] -> Store.Path.create path conpath + | _ -> raise Invalid_Cmd_Args +=09 +let dump base conpath ~conid txn ch =3D + (* TODO: implicit paths need to be converted to explicit *) + let txid =3D get_id txn in + LR.write_transaction_data ch ~conid ~txid; + let store =3D get_store txn in + let write_node_mkdir path =3D + let perms, value =3D match Store.get_node store path with + | None -> Perms.Node.default0, "" (* need to dump mkdir anyway even if l= ater deleted due to implicit path creation *) + | Some node -> Store.Node.get_perms node, Store.Node.get_value node (* n= ot always "", e.g. on EEXIST *) in + LR.write_node_data ch ~txidaccess:(Some (conid, txid, LR.W)) ~path:(Stor= e.Path.to_string path) ~value ~perms +in + maybe (fun path -> + (* if there were any reads make sure the tree matches, remove all conten= ts and write out subtree *) + match Store.get_node store path with + | None -> (* we've only read nodes that we ended up deleting, nothing to= do *) () + | Some node -> + write_node ch (Some (conid, txid, LR.Del)) (Store.Path.get_parent path)= node; + let path =3D Store.Path.get_parent path in + Store.traversal node @@ fun path' node -> + write_node ch (Some (conid,txid, LR.R)) (List.append path path') node + ) txn.read_lowpath; + (* we could do something similar for write_lowpath, but that would become=20 + complicated to handle correctly wrt to permissions and quotas if there= are nodes + owned by other domains in the subtree. + *) + let ops =3D get_operations txn in + if ops <> [] then + (* mark that we had some operation, these could be failures, etc. + we want to fail the transaction after a live-update, + unless it is completely a no-op + *) + let perms =3D Store.getperms store Perms.Connection.full_rights [] in + let value =3D Store.get_root store |> Store.Node.get_value in + LR.write_node_data ch ~txidaccess:(Some (conid, txid, LR.R)) ~path:"/" = ~value ~perms; + ListLabels.iter (fun (req, reply) -> + Logging.debug "transaction" "dumpop %s" (Xenbus.Xb.Op.to_string req.Pack= et.ty);=20 + let data =3D req.Packet.data in + let open Xenbus.Xb.Op in + match reply with + | Packet.Error _ -> () + | _ -> + try match req.Packet.ty with +| Debug +| Watch +| Unwatch +| Transaction_start +| Transaction_end +| Introduce +| Release +| Watchevent +| Getdomainpath +| Error +| Isintroduced +| Resume +| Set_target +| Reset_watches +| Invalid +| Directory +| (Read|Getperms) -> () +| (Write|Setperms) -> + (match (split (Some 2) '\000' data) with + | path :: _ :: _ -> + let path =3D Store.Path.create path conpath in + if req.Packet.ty =3D Write then + write_node_mkdir (Store.Path.get_parent path);(* implicit mkdir *) + (match Store.get_node store path with + | None -> () + | Some node -> + write_node ch (Some (conid, txid, LR.W)) (Store.Path.get_parent path) nod= e) + | _ -> raise Invalid_Cmd_Args) +| Mkdir -> + let path =3D split_one_path data conpath in + write_node_mkdir path; +| Rm -> + let path =3D split_one_path data conpath |> Store.Path.to_string in + LR.write_node_data ch ~txidaccess:(Some (conid, txid, LR.Del)) ~path ~val= ue:"" ~perms:Perms.Node.default0 + with Invalid_Cmd_Args|Define.Invalid_path|Not_found-> () + ) ops --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620756453; cv=none; d=zohomail.com; s=zohoarc; b=TfsRtrFXcgYkMrI1dC0rdXsS0HGEJoRXSW/tS9Ozr3BkEj0XT6qFOu6aXWSAAojFT64hz45EYSG4sp4ZppsyAfvzpGgJYa3+wM5ToViO0N9j3VgX1N9JgFZb7F/LTUWf3RYvZy98CzbTSO7HCmvSE7PEVj39sXXH5NEmkP7dvt4= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620756453; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=vnirsOVd7bJW3HrhOfU7JvkbVL3BSAkLBc9R1vbp0DY=; b=bBp57XytzxKs1PRTEa/hM9kMQmYpkxDabTc+OYQh4rD7jRI1IprkmTbBVr/5bSjlf0CAEsSOQk29beP4APURb3L2wyVHg+u+T48h0PmexApVT6cMGSkNeLrRIct66EZA0pxL02qFDfAWbj7fqE1Wr5Dyucc/9hChg5iLS1uZw7Q= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620756453451373.3251777457199; Tue, 11 May 2021 11:07:33 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125907.237049 (Exim 4.92) (envelope-from ) id 1lgWmu-0002xd-FC; Tue, 11 May 2021 18:07:20 +0000 Received: by outflank-mailman (output) from mailman id 125907.237049; Tue, 11 May 2021 18:07:20 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWmu-0002xU-AL; Tue, 11 May 2021 18:07:20 +0000 Received: by outflank-mailman (input) for mailman id 125907; Tue, 11 May 2021 18:07:18 +0000 Received: from us1-rack-iad1.inumbo.com ([172.99.69.81]) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWms-0000hb-QD for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:07:18 +0000 Received: from esa1.hc3370-68.iphmx.com (unknown [216.71.145.142]) by us1-rack-iad1.inumbo.com (Halon) with ESMTPS id 9c9be45a-b6e0-44f1-897a-16a30e5de11b; Tue, 11 May 2021 18:07:01 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 9c9be45a-b6e0-44f1-897a-16a30e5de11b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620756421; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=9mD+y4+KHJLl7F5bXUBrPg32mwOSoUG5fSCQwye7W70=; b=XTTUhpB1cJv7Afv+gaIhlJhCj5vOgOyT4wOrjCjerORKIOPUCcbruXg/ /YfGBqJF1/r0D9qrmQFHQnvgIMeVTXB6henp2uwHLmU5DpzeoqDWoT0kX ACp/sa4DOQXRBhGs3RR1mxaJnMrq4YYwDCLGR/GMml0U0tFguu6zT2Bvk c=; Authentication-Results: esa1.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: UQeXyntwYzSztu4nyK19C5cw8sAUrc9eVV6jQWCg2hA7PhP5mCdaPh01FsCzxfVp3vD5RgECo5 1ehNvxozd4YgFyBhI5FbpgUdkld+oA6+Wl94ln5TbMxjzn3j2UdBgWzzHHkDXZ6VEP+L0/EpgC vmRhSN2U6FLqOqkpIcbtaHpwZLNL8u2INqdLPTrjXgF2IFVBNbIx234NbSYcRMWoLyEoLEcBN3 oMLty26irLS1Stusg5Xvd5QffwEyKRqOAmMwairLpbomk2feZbgqDgbRPy8rUwsJDsMLL7/AmS Sy0= X-SBRS: 5.1 X-MesageID: 43954257 X-Ironport-Server: esa1.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:gs89JaHeYqgY8YuOpLqE0seALOsnbusQ8zAXP0AYc31om6uj5r iTdZUgpGbJYVkqKRIdcLy7V5VoBEmskaKdgrNhW4tKPjOW2ldARbsKheCJrlHd8m/Fh4lgPM 9bAtND4bbLbWSS4/yV3ODBKadE/OW6 X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43954257" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 09/17] tools/ocaml: use common macros for manipulating mmap_interface Date: Tue, 11 May 2021 19:05:22 +0100 Message-ID: <744b98946062028be059435fbe2b9ccc2009e1e8.1620755942.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) Also expose these macros in a header file that can be reused by the upcoming grant table code. Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/libs/mmap/mmap_stubs.h | 7 +++++++ tools/ocaml/libs/mmap/xenmmap_stubs.c | 2 -- tools/ocaml/libs/xb/xs_ring_stubs.c | 14 +++++--------- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/tools/ocaml/libs/mmap/mmap_stubs.h b/tools/ocaml/libs/mmap/mma= p_stubs.h index 65e4239890..816ba6a724 100644 --- a/tools/ocaml/libs/mmap/mmap_stubs.h +++ b/tools/ocaml/libs/mmap/mmap_stubs.h @@ -30,4 +30,11 @@ struct mmap_interface int len; }; =20 +#ifndef Data_abstract_val +#define Data_abstract_val(v) ((void*) Op_val(v)) +#endif + +#define Intf_val(a) ((struct mmap_interface *) Data_abstract_val(a)) +#define Intf_data_val(a) (Intf_val(a)->addr) + #endif diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c b/tools/ocaml/libs/mmap/= xenmmap_stubs.c index e2ce088e25..b811990a89 100644 --- a/tools/ocaml/libs/mmap/xenmmap_stubs.c +++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c @@ -28,8 +28,6 @@ #include #include =20 -#define Intf_val(a) ((struct mmap_interface *) a) - static int mmap_interface_init(struct mmap_interface *intf, int fd, int pflag, int mflag, int len, int offset) diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c b/tools/ocaml/libs/xb/xs_r= ing_stubs.c index 7a91fdee75..614c6e371d 100644 --- a/tools/ocaml/libs/xb/xs_ring_stubs.c +++ b/tools/ocaml/libs/xb/xs_ring_stubs.c @@ -35,8 +35,6 @@ #include #include "mmap_stubs.h" =20 -#define GET_C_STRUCT(a) ((struct mmap_interface *) a) - /* * Bytes_val has been introduced by Ocaml 4.06.1. So define our own version * if needed. @@ -52,12 +50,11 @@ CAMLprim value ml_interface_read(value ml_interface, CAMLparam3(ml_interface, ml_buffer, ml_len); CAMLlocal1(ml_result); =20 - struct mmap_interface *interface =3D GET_C_STRUCT(ml_interface); unsigned char *buffer =3D Bytes_val(ml_buffer); int len =3D Int_val(ml_len); int result; =20 - struct xenstore_domain_interface *intf =3D interface->addr; + struct xenstore_domain_interface *intf =3D Intf_data_val(ml_interface); XENSTORE_RING_IDX cons, prod; /* offsets only */ int total_data, data; uint32_t connection; @@ -111,12 +108,11 @@ CAMLprim value ml_interface_write(value ml_interface, CAMLparam3(ml_interface, ml_buffer, ml_len); CAMLlocal1(ml_result); =20 - struct mmap_interface *interface =3D GET_C_STRUCT(ml_interface); const unsigned char *buffer =3D Bytes_val(ml_buffer); int len =3D Int_val(ml_len); int result; =20 - struct xenstore_domain_interface *intf =3D interface->addr; + struct xenstore_domain_interface *intf =3D Intf_data_val(ml_interface); XENSTORE_RING_IDX cons, prod; int total_space, space; uint32_t connection; @@ -166,7 +162,7 @@ exit: CAMLprim value ml_interface_set_server_features(value interface, value v) { CAMLparam2(interface, v); - struct xenstore_domain_interface *intf =3D GET_C_STRUCT(interface)->addr; + struct xenstore_domain_interface *intf =3D Intf_data_val(interface); if (intf =3D=3D (void*)MAP_FAILED) caml_failwith("Interface closed"); =20 @@ -178,7 +174,7 @@ CAMLprim value ml_interface_set_server_features(value i= nterface, value v) CAMLprim value ml_interface_get_server_features(value interface) { CAMLparam1(interface); - struct xenstore_domain_interface *intf =3D GET_C_STRUCT(interface)->addr; + struct xenstore_domain_interface *intf =3D Intf_data_val(interface); =20 CAMLreturn(Val_int (intf->server_features)); } @@ -186,7 +182,7 @@ CAMLprim value ml_interface_get_server_features(value i= nterface) CAMLprim value ml_interface_close(value interface) { CAMLparam1(interface); - struct xenstore_domain_interface *intf =3D GET_C_STRUCT(interface)->addr; + struct xenstore_domain_interface *intf =3D Intf_data_val(interface); int i; =20 intf->req_cons =3D intf->req_prod =3D intf->rsp_cons =3D intf->rsp_prod = =3D 0; --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620757213; cv=none; d=zohomail.com; s=zohoarc; b=WgSN7zmO34NYf1iMiMTkOazPV/DXXqlreqA0mPHLkEvkCh+c+7DJYNhrG08wiB1bKXleKI7gOy/HVTLS+wPhynJIyKCJitpbRNveByoIz2Snm5BAz/dmrX0Bcme4cNDsgGauGOCEeXJWviIDBSqCrGaXEHvaIrkvmAJswk/HQcw= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620757213; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=OPCKjBUDyrIo19Tla6TwFLg+5oIxqO9gOJ2a8sRRpLE=; b=cm4XGvSF2+BHT+d3w20V5lYCYI4Ao7I+Q+cfVy7PuPhBZCxm/9yV1FGXmFcN48eSWNkNYl64k93b5ib36hD/R70fg4qfW4LGYkGO1XCy+c7p0yVpuO1FsfpvuOn6mo1FTLINagrlisz2Eennp/Rd6ktVxwbQMSHbu9iVaV+j78U= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620757213398108.03195581194166; Tue, 11 May 2021 11:20:13 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125965.237144 (Exim 4.92) (envelope-from ) id 1lgWzC-00012t-4D; Tue, 11 May 2021 18:20:02 +0000 Received: by outflank-mailman (output) from mailman id 125965.237144; Tue, 11 May 2021 18:20:02 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWzC-00012K-0V; Tue, 11 May 2021 18:20:02 +0000 Received: by outflank-mailman (input) for mailman id 125965; Tue, 11 May 2021 18:20:01 +0000 Received: from all-amaz-eas1.inumbo.com ([34.197.232.57] helo=us1-amaz-eas2.inumbo.com) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWzB-0007fz-5W for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:20:01 +0000 Received: from esa2.hc3370-68.iphmx.com (unknown [216.71.145.153]) by us1-amaz-eas2.inumbo.com (Halon) with ESMTPS id 44ad55f2-40e0-4b29-b73e-727bf73df6b9; Tue, 11 May 2021 18:19:53 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 44ad55f2-40e0-4b29-b73e-727bf73df6b9 DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620757193; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=wH4ZTnWLfQtQSCRp1fYnZ6Grjr9l6Pd0afiHDgqCHrM=; b=GI+dBNyrMhpKjrIqNEqrrLHSe3SoWGBQpwX7ANSAKpVGcn8VwTlcmEq+ jsvTdMY5gXj3aOWIek1WTxt0oZ5DeczAyXC4e/AjZOqD8itfFk9RBqlV1 C3ii+Nt3HCCLVJxS+LGjsJ5o0Q9OxJOhSXz9MiArhzj0WmfXUz4fvG5yR U=; Authentication-Results: esa2.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: 5dqYvYo9PE6bRcChvJHKFrOgutPz93AFiuEpLzhFm+/o8GJC64ivIpxv1XHEhD6rJzTgW92JBD YUgSM6VQ1YfKywzksLHNpmIoaJMQZRaRM95+yvQLvMWVN/oPwS7l+0HICLYKKOdw05jra/1oDC Y4R0miiMfKxRECU4tfIcMCu82t/6bUVbHmidc5XljLdtiBewFmG2gVH2uuLimICTTpcPrAgehU 1FSk4Xl+JCPWgTeVjgsrGOblx4+ld7XKXWT7RxBZRoTZjScQbSdrBvFZPijKNqhdFZZHkZ+YoC prU= X-SBRS: 5.1 X-MesageID: 43562377 X-Ironport-Server: esa2.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:cDkGHakVqebc6LuaNIr1rdhr2xrpDfLo3DAbv31ZSRFFG/Fw9/ rCoB17726QtN91YhsdcL+7V5VoLUmzyXcX2/hyAV7BZmnbUQKTRekP0WKL+Vbd8kbFh41gPM lbEpSXCLfLfCJHZcSR2njELz73quP3jJxBho3lvghQpRkBUdAF0+/gYDzranGfQmN9dP0EPa vZ3OVrjRy6d08aa8yqb0N1JNQq97Xw5fTbiQdtPW9f1DWz X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43562377" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 10/17] tools/ocaml/libs/mmap: allocate correct number of bytes Date: Tue, 11 May 2021 19:05:23 +0100 Message-ID: X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) OCaml memory allocation functions use words as units, unless explicitly documented otherwise. Thus we were allocating more memory than necessary, caml_alloc should've been called with the parameter '2', but was called with a lot more. To account for future changes in the struct keep using sizeof, but round up and convert to number of words. For OCaml 1 word =3D sizeof(value) The Wsize_bsize macro converts bytes to words. Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/libs/mmap/xenmmap_stubs.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c b/tools/ocaml/libs/mmap/= xenmmap_stubs.c index b811990a89..4d09c5a6e6 100644 --- a/tools/ocaml/libs/mmap/xenmmap_stubs.c +++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c @@ -28,6 +28,8 @@ #include #include =20 +#define Wsize_bsize_round(n) (Wsize_bsize( (n) + sizeof(value) - 1 )) + static int mmap_interface_init(struct mmap_interface *intf, int fd, int pflag, int mflag, int len, int offset) @@ -57,7 +59,7 @@ CAMLprim value stub_mmap_init(value fd, value pflag, valu= e mflag, default: caml_invalid_argument("maptype"); } =20 - result =3D caml_alloc(sizeof(struct mmap_interface), Abstract_tag); + result =3D caml_alloc(Wsize_bsize_round(sizeof(struct mmap_interface)), A= bstract_tag); =20 if (mmap_interface_init(Intf_val(result), Int_val(fd), c_pflag, c_mflag, --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620757216; cv=none; d=zohomail.com; s=zohoarc; b=JqleqiQnLKJaKKqUfcyQlSAEsDHFgt+R9Npj47AdMv/f0g19EV6rJAjgP6eIRmw5nXnvw8MuTGh+cBMVUf2Pyxr9NhDn3U9Rm6N1fwTTCBgKcH/3pD7CMeBDTNdv9xjtNBmH179FJvJRpD9WQ1+dCMoYOgNvuiQZgoNUVCrIbMU= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620757216; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=Hxc+itkMS7hePZPcMNujdAgB/+1IISf4KHwqdcsY/aA=; b=mu7/wiUAM063E/hIywuvChHre+PazO1cCP1LRXVftY2KCidm9bFd780aC5bd5Fv4vWXiQooJC1Oy1PuwC3Gyo+cC5tYm/mbRB0h1VdbLpw1YJTzZCvxeOyN2nqf+jYxVwS0Q+k6H2lXch70Oi6D6mTFtgjzcEjMN2kdCzmdjPCg= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620757216865190.3050689330139; Tue, 11 May 2021 11:20:16 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125966.237157 (Exim 4.92) (envelope-from ) id 1lgWzE-0001eh-II; Tue, 11 May 2021 18:20:04 +0000 Received: by outflank-mailman (output) from mailman id 125966.237157; Tue, 11 May 2021 18:20:04 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWzE-0001e4-Dp; Tue, 11 May 2021 18:20:04 +0000 Received: by outflank-mailman (input) for mailman id 125966; Tue, 11 May 2021 18:20:02 +0000 Received: from us1-rack-iad1.inumbo.com ([172.99.69.81]) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWzC-0007g6-Gc for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:20:02 +0000 Received: from esa2.hc3370-68.iphmx.com (unknown [216.71.145.153]) by us1-rack-iad1.inumbo.com (Halon) with ESMTPS id f5946d18-6347-4a01-b85a-ef69397626d8; Tue, 11 May 2021 18:19:52 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: f5946d18-6347-4a01-b85a-ef69397626d8 DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620757192; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=J+9ZxhITGKoBgE2ifCsItTortedaZyt2nhMpStVL/so=; b=XJSfpc+dTIt6Q38wUp8db9vi/yMt1O/ebOIm0kqVeL0XyGdYI764Fsjh ZbkBMWwJhD0u87sto/loF8PF7rEdLgfN4iffGJHiHHoawUukEF1jWg/VO BkaBcKomDqjxQ7c0WolHh70un31yFtwbyggMUth5Xk01n2Iqq8vvzFPWs A=; Authentication-Results: esa2.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: eok2EWv+dnswMwHUxdnkS/1jaZMiXDFa8autCFiLG+96j29z7lRLvcNsXNXK8AE9HMbjLmZ4z4 wVpschl9SdLGmR0x9xpadQRjzhhqdMkTiqRRhcRrBmKoZTH9+EAShUW39qicA0CCB+MkreIDvG /ruM/TdhMJMeTJ4+0Y0EzGZtncOYzvvTFqSF1CDUpXnlkonquSzBgM2af8+NC5Ea7NRQk2cjEj t5EqGT6OdFNIVB7p62PqYuJrPT54JfDRbRjksqBm1dnActV1vMsNtrn0oeYWINvUt3LGJKb2a3 D1Q= X-SBRS: 5.1 X-MesageID: 43562374 X-Ironport-Server: esa2.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:IGpwuaylIAVs6EAzT9IgKrPw6L1zdoMgy1knxilNoHxuH/Bw9v re+cjzsCWftN9/Yh4dcLy7VpVoIkmsl6Kdg7NwAV7KZmCP1FdARLsI0WKI+UyCJ8SRzI9gPa cLSdkFNDXzZ2IK8PoTNmODYqodKNrsytHWuQ/HpU0dKT2D88tbnn9E4gDwKDwQeCB2QaAXOb C7/cR9qz+paR0sH7+G7ilsZZmkmzXT/qiWGCI7Ow== X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43562374" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 11/17] tools/ocaml/libs/mmap: Expose stub_mmap_alloc Date: Tue, 11 May 2021 19:05:24 +0100 Message-ID: X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) This also handles mmap errors better by using the `uerror` helper to raise a proper exception using `errno`. Changed type of `len` from `int` to `size_t`: at construction time we ensure the length is >=3D 0, so we can reflect this by using an unsigned type. The type is unsigned at the C API level, and a negative integer would just get translated to a very large unsigned number otherwise. mmap also takes off_t and size_t, so using int64 would be more generic here, however we only ever use this interface to map rings, so keeping the `int` sizes is fine. OCaml itself only uses `ints` for mapping bigarrays, and int64 for just the offset. Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/libs/mmap/mmap_stubs.h | 4 +++- tools/ocaml/libs/mmap/xenmmap_stubs.c | 31 +++++++++++++++++---------- 2 files changed, 23 insertions(+), 12 deletions(-) diff --git a/tools/ocaml/libs/mmap/mmap_stubs.h b/tools/ocaml/libs/mmap/mma= p_stubs.h index 816ba6a724..3352594e38 100644 --- a/tools/ocaml/libs/mmap/mmap_stubs.h +++ b/tools/ocaml/libs/mmap/mmap_stubs.h @@ -27,7 +27,7 @@ struct mmap_interface { void *addr; - int len; + size_t len; }; =20 #ifndef Data_abstract_val @@ -37,4 +37,6 @@ struct mmap_interface #define Intf_val(a) ((struct mmap_interface *) Data_abstract_val(a)) #define Intf_data_val(a) (Intf_val(a)->addr) =20 +value stub_mmap_alloc(void *addr, size_t len); + #endif diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c b/tools/ocaml/libs/mmap/= xenmmap_stubs.c index 4d09c5a6e6..d7a97c76f5 100644 --- a/tools/ocaml/libs/mmap/xenmmap_stubs.c +++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c @@ -27,16 +27,18 @@ #include #include #include +#include =20 #define Wsize_bsize_round(n) (Wsize_bsize( (n) + sizeof(value) - 1 )) =20 -static int mmap_interface_init(struct mmap_interface *intf, - int fd, int pflag, int mflag, - int len, int offset) +value stub_mmap_alloc(void *addr, size_t len) { - intf->len =3D len; - intf->addr =3D mmap(NULL, len, pflag, mflag, fd, offset); - return (intf->addr =3D=3D MAP_FAILED) ? errno : 0; + CAMLparam0(); + CAMLlocal1(result); + result =3D caml_alloc(Wsize_bsize_round(sizeof(struct mmap_interface)), A= bstract_tag); + Intf_val(result)->addr =3D addr; + Intf_val(result)->len =3D len; + CAMLreturn(result); } =20 CAMLprim value stub_mmap_init(value fd, value pflag, value mflag, @@ -45,6 +47,8 @@ CAMLprim value stub_mmap_init(value fd, value pflag, valu= e mflag, CAMLparam5(fd, pflag, mflag, len, offset); CAMLlocal1(result); int c_pflag, c_mflag; + void* addr; + size_t length; =20 switch (Int_val(pflag)) { case 0: c_pflag =3D PROT_READ; break; @@ -59,12 +63,17 @@ CAMLprim value stub_mmap_init(value fd, value pflag, va= lue mflag, default: caml_invalid_argument("maptype"); } =20 - result =3D caml_alloc(Wsize_bsize_round(sizeof(struct mmap_interface)), A= bstract_tag); + if (Int_val(len) < 0) + caml_invalid_argument("negative size"); + if (Int_val(offset) < 0) + caml_invalid_argument("negative offset"); + length =3D Int_val(len); =20 - if (mmap_interface_init(Intf_val(result), Int_val(fd), - c_pflag, c_mflag, - Int_val(len), Int_val(offset))) - caml_failwith("mmap"); + addr =3D mmap(NULL, length, c_pflag, c_mflag, Int_val(fd), Int_val(offset= )); + if (MAP_FAILED =3D=3D addr) + uerror("mmap", Nothing); + + result =3D stub_mmap_alloc(addr, length); CAMLreturn(result); } =20 --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620757206; cv=none; d=zohomail.com; s=zohoarc; b=f/IX3/APbBrram0B60cf5nhFquKNqwUMtyyrF9yEXbb9g/cTyDlH8qqqRSzXy7fXzYpBhZWBdzDt7WJ0CW9Ttl1bo4kyqJWx7NUZbOJmRdPSdsqb8pROpA6kr6dt7Y+50TVfam9yx70WIuJ5OSUD4wpbm2HzzlqY+KjHKIRkRPw= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620757206; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=atFGF3AqQXko+sLgRqc7RZZC82n2e1nJoPilJ833Wdg=; b=EVrLXHwUyKMOQ0xo48JXI9pF1h4tZYnkO7z4LtNrcVMa1w3mdlyGhbS3NHzV0w/9lpa+dQqd2fAkA+NNE/lU9q1aUJTzppOFSFco3/D+3T+DynXlqhbZAdGla+FPq3/MSH2IsqwIkKN/eADCTYi6pK3s10OLxPH1JRR8zQBVKbQ= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620757206175749.645330737442; Tue, 11 May 2021 11:20:06 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125962.237109 (Exim 4.92) (envelope-from ) id 1lgWz3-0008Hn-TC; Tue, 11 May 2021 18:19:53 +0000 Received: by outflank-mailman (output) from mailman id 125962.237109; Tue, 11 May 2021 18:19:53 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWz3-0008Hc-Pj; Tue, 11 May 2021 18:19:53 +0000 Received: by outflank-mailman (input) for mailman id 125962; Tue, 11 May 2021 18:19:52 +0000 Received: from us1-rack-iad1.inumbo.com ([172.99.69.81]) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWz2-0007g6-GI for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:19:52 +0000 Received: from esa2.hc3370-68.iphmx.com (unknown [216.71.145.153]) by us1-rack-iad1.inumbo.com (Halon) with ESMTPS id 19b3bfa7-5419-49b1-8051-bd5514dfe581; Tue, 11 May 2021 18:19:47 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 19b3bfa7-5419-49b1-8051-bd5514dfe581 DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620757187; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=EoaUpYs9b5JtY9mZ1Jy5aNZ4/ohnkMdircO88bxkg44=; b=CHcTnBQ+gbXHApTpscebxkhpzBSOUA1WUEEhTnbrMVn8fA7Px6OwgTy6 CJXlvR4R0vmzePd3hrxiwsEeAN+FVR9TMtNpODlef+6CwGiTvmjdqOpXQ 0rdtuwvkbZi5XXNHCab4tjr7TPLbNw3eJ6v/5TiOJeZBvhWbQg3qO31J8 0=; Authentication-Results: esa2.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: jXvHeAJvDN1mXXdaAWfqlPHHazwViQ0FtFAp5WTIfOpuEqy+a0KF3Ohxx4UIqAk8EUleoTu5tl NaRTf4EMlBhS6a9UrEyQLomS4Wry7YRe26ICnZ1n3MP+FaDaqd00tixNEsozcWIN57bePj/hax edxjqei4oFFQWlggOIaVjGXhk65Cv4ADXQpot/PjgaArEdGdKc/BdQ0ZoLWxXOTwYyB+AmSWNU bA7dWsMaQJtOWZuXtTDd3+JHwpqYGEwrX6TOKyQYRB70rd9+tD6X9LR5T8hwevckaH4hv/jYQa a7Y= X-SBRS: 5.1 X-MesageID: 43562364 X-Ironport-Server: esa2.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:afEZh6mNz+/LDj4Xj8abPvWYjILpDfIW3DAbv31ZSRFFG/Fxl6 iV/cjzsiWE8Ar5OUtQ4OxoV5PwIk80maQb3WBVB8bHYOCEghrPEGgB1/qB/9SIIUSXnYQxuZ uIMZIOb+EYZWIK9voSizPZLz9P+re6GdiT9ILj80s= X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43562364" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 12/17] tools/ocaml/libs/mmap: mark mmap/munmap as blocking Date: Tue, 11 May 2021 19:05:25 +0100 Message-ID: <294a60be29027d33b0a1d154b7d576237c7dd420.1620755942.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) These functions can potentially take some time, so allow other OCaml code to proceed meanwhile (if any). Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/libs/mmap/xenmmap_stubs.c | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c b/tools/ocaml/libs/mmap/= xenmmap_stubs.c index d7a97c76f5..e8d2d6add5 100644 --- a/tools/ocaml/libs/mmap/xenmmap_stubs.c +++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c @@ -28,6 +28,7 @@ #include #include #include +#include =20 #define Wsize_bsize_round(n) (Wsize_bsize( (n) + sizeof(value) - 1 )) =20 @@ -69,7 +70,9 @@ CAMLprim value stub_mmap_init(value fd, value pflag, valu= e mflag, caml_invalid_argument("negative offset"); length =3D Int_val(len); =20 + caml_enter_blocking_section(); addr =3D mmap(NULL, length, c_pflag, c_mflag, Int_val(fd), Int_val(offset= )); + caml_leave_blocking_section(); if (MAP_FAILED =3D=3D addr) uerror("mmap", Nothing); =20 @@ -80,10 +83,15 @@ CAMLprim value stub_mmap_init(value fd, value pflag, va= lue mflag, CAMLprim value stub_mmap_final(value intf) { CAMLparam1(intf); + struct mmap_interface interface =3D *Intf_val(intf); =20 - if (Intf_val(intf)->addr !=3D MAP_FAILED) - munmap(Intf_val(intf)->addr, Intf_val(intf)->len); + /* mark it as freed, in case munmap below fails, so we don't retry it */ Intf_val(intf)->addr =3D MAP_FAILED; + if (interface.addr !=3D MAP_FAILED) { + caml_enter_blocking_section(); + munmap(interface.addr, interface.len); + caml_leave_blocking_section(); + } =20 CAMLreturn(Val_unit); } --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620757214; cv=none; d=zohomail.com; s=zohoarc; b=bJtrTujelVSCzPgfih7VMGT2HvXPWRDvPEiocVCsHSlicQPspZtUd4I66FPG+LlTzrBTuxn4zNk8gyqt/GSSbhcyaKWpaIz3r6tETor9U7XcYChmDUjxZ/zrugmOJJ9S7N4eTTSxEd2Qf0GcBn2y97GlH7yCEAe9A6UQJdO0Was= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620757214; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=vRpRYHvFNF8kkbcgN5HO0of74rw5DdezDVFKA9klH0Y=; b=jf4b5RvsKV45MaYm6OGCNa2bLX0PkyupH7LOeCG+s8mbTWJ+nvL2olp3qOJ/aMS/sPRENLM76HA3vwtjxPH5QZDY8qIZ73GMDjhRdmm1w4T4qG24QaCsa0yElDWQvge5wnMPp7vHvj6X2T8VZHGo1fRoyi/PsLdwDuBvCW1mLL8= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620757214782932.5984151253682; Tue, 11 May 2021 11:20:14 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125964.237132 (Exim 4.92) (envelope-from ) id 1lgWz9-0000XE-HI; Tue, 11 May 2021 18:19:59 +0000 Received: by outflank-mailman (output) from mailman id 125964.237132; Tue, 11 May 2021 18:19:59 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWz9-0000Wx-C7; Tue, 11 May 2021 18:19:59 +0000 Received: by outflank-mailman (input) for mailman id 125964; Tue, 11 May 2021 18:19:57 +0000 Received: from us1-rack-iad1.inumbo.com ([172.99.69.81]) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWz7-0007g6-Gk for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:19:57 +0000 Received: from esa3.hc3370-68.iphmx.com (unknown [216.71.145.155]) by us1-rack-iad1.inumbo.com (Halon) with ESMTPS id 7fc6e699-2fa5-47e5-895a-4b2c4772b8ec; Tue, 11 May 2021 18:19:51 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 7fc6e699-2fa5-47e5-895a-4b2c4772b8ec DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620757191; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=44hyZ/ZaZ9beZ9T4JdjVPbP63rTAyQBALalI4rEKkk4=; b=dm97E3F89Yp8Q820UOGMinnPdbQPQ4MellCAizbdPabh79ARGeBBctsK bQTAApzBdUwUvTRdIJ5ghiglkIhiz1f28QFm+iVLduldEIwoiMy1grXfJ SaAtyiB3Ny7Sitl72mBNt1NI7b/90oAJNKaAfMp0qyBG0klPrTiGidMCh o=; Authentication-Results: esa3.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: fbrcHgMwOJSde12PXOvnKypdUGN+tM9wSfZye82uYj9Hza/31CRLKi/YN/2NpBIrEBKFYsIn9X 2CQYrY7cNjFS4lAvIpJOpEg9wND4gvg6Ltj9++Kp9wTO3pzidE5QnmoIqM6sNg2CVLQTKYp/Sa Tpg2ZMHRVAMNwEtsG8xfefZZPpotufj1qBRaYXlyamq3Wkc5QUaRNRcAMNR5xffFC6AD0HdbTP fw7yWehjbKCKtOyTAo7FLZuLfoMkL/XyoUThkKGvziwssD4qVugM62lhSbLpucryoMkzwIFMvX bPk= X-SBRS: 5.1 X-MesageID: 43580607 X-Ironport-Server: esa3.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:+jZYZq+keJzTGnCyxNxuk+DiI+orL9Y04lQ7vn2YSXRuE/Bw8P re5MjztCWE8Qr5N0tQ+uxoVJPufZqYz+8Q3WBzB8bFYOCFghrLEGgK1+KLqFeMdxEWtNQtsp uIG5IOc+EYZmIbsS+V2meF+q4bsby6zJw= X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43580607" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 13/17] tools/ocaml/libs/xb: import gnttab stubs from mirage Date: Tue, 11 May 2021 19:05:26 +0100 Message-ID: X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) Upstream URL: https://github.com/mirage/ocaml-gnt Mirage is part of the Xen project and the license is compatible, copyright headers are retained. Changes from upstream: * cut down dependencies: dropped Lwt, replaced Io_page with Xenmmap * only import Gnttab and not Gntshr This is for xenstored's use only which needs a way to grant map the xenstore ring without using xenctrl. The gnt code is added into libs/mmap because it uses mmap_stubs.h. Also this makes it possible to mock out gnttab in the unit tests: replace it with code that just mmaps /dev/zero. For the mocking to work gnt.ml needs to be in a dir other than xenstored/. Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/Makefile | 1 + tools/ocaml/libs/mmap/Makefile | 19 +++-- tools/ocaml/libs/mmap/dune | 10 +++ tools/ocaml/libs/mmap/gnt.ml | 60 ++++++++++++++ tools/ocaml/libs/mmap/gnt.mli | 86 ++++++++++++++++++++ tools/ocaml/libs/mmap/gnttab_stubs.c | 106 +++++++++++++++++++++++++ tools/ocaml/xenstored/Makefile | 1 + tools/ocaml/xenstored/dune | 6 +- tools/ocaml/xenstored/test/gnt.ml | 52 ++++++++++++ tools/ocaml/xenstored/test/testable.ml | 3 +- tools/ocaml/xenstored/xenstored.ml | 10 +-- 11 files changed, 339 insertions(+), 15 deletions(-) create mode 100644 tools/ocaml/libs/mmap/gnt.ml create mode 100644 tools/ocaml/libs/mmap/gnt.mli create mode 100644 tools/ocaml/libs/mmap/gnttab_stubs.c create mode 100644 tools/ocaml/xenstored/test/gnt.ml diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile index de375820a3..1236b0e584 100644 --- a/tools/ocaml/Makefile +++ b/tools/ocaml/Makefile @@ -43,6 +43,7 @@ C_INCLUDE_PATH=3D$(XEN_libxenctrl)/include:$(XEN_libxengn= ttab)/include:$(XEN_libxe # in the parent directory (so it couldn't copy/use Config.mk) .PHONY: dune-pre dune-pre: + $(MAKE) clean $(MAKE) -s -C ../../ build-tools-public-headers $(MAKE) -s -C libs/xs paths.ml $(MAKE) -s -C libs/xc xenctrl_abi_check.h diff --git a/tools/ocaml/libs/mmap/Makefile b/tools/ocaml/libs/mmap/Makefile index df45819df5..ed4903b48a 100644 --- a/tools/ocaml/libs/mmap/Makefile +++ b/tools/ocaml/libs/mmap/Makefile @@ -2,9 +2,7 @@ TOPLEVEL=3D$(CURDIR)/../.. XEN_ROOT=3D$(TOPLEVEL)/../.. include $(TOPLEVEL)/common.make =20 -OBJS =3D xenmmap INTF =3D $(foreach obj, $(OBJS),$(obj).cmi) -LIBS =3D xenmmap.cma xenmmap.cmxa =20 all: $(INTF) $(LIBS) $(PROGRAMS) =20 @@ -12,15 +10,26 @@ bins: $(PROGRAMS) =20 libs: $(LIBS) =20 -xenmmap_OBJS =3D $(OBJS) +# gnt is an internal library, not installed +gnt_OBJS =3D gnt +gnt_C_OBJS =3D gnttab_stubs +gnt_LIBS =3D gnt.cma gnt.cmxa +LIBS_gnt =3D $(LDLIBS_libxengnttab) +CFLAGS +=3D $(CFLAGS_libxengnttab) + +xenmmap_OBJS =3D xenmmap xenmmap_C_OBJS =3D xenmmap_stubs -OCAML_LIBRARY =3D xenmmap +xenmmap_LIBS =3D xenmmap.cma xenmmap.cmxa + +OCAML_LIBRARY =3D xenmmap gnt +OBJS =3D $(xenmmap_OBJS) $(gnt_OBJS) +LIBS =3D $(xenmmap_LIBS) $(gnt_LIBS) =20 .PHONY: install install: $(LIBS) META mkdir -p $(OCAMLDESTDIR) $(OCAMLFIND) remove -destdir $(OCAMLDESTDIR) xenmmap - $(OCAMLFIND) install -destdir $(OCAMLDESTDIR) -ldconf ignore xenmmap META= $(INTF) $(LIBS) *.a *.so *.cmx + $(OCAMLFIND) install -destdir $(OCAMLDESTDIR) -ldconf ignore xenmmap META= *xenmmap*.cmi $(xenmmap_LIBS) *xenmmap*.a *xenmmap*.so *xenmmap*.cmx =20 .PHONY: uninstall uninstall: diff --git a/tools/ocaml/libs/mmap/dune b/tools/ocaml/libs/mmap/dune index a47de44e47..f4c98153c4 100644 --- a/tools/ocaml/libs/mmap/dune +++ b/tools/ocaml/libs/mmap/dune @@ -3,6 +3,16 @@ (language c) (names xenmmap_stubs)) (name xenmmap) + (modules xenmmap) (public_name xen.mmap) (libraries unix) (install_c_headers mmap_stubs)) + +(library + (foreign_stubs + (language c) + (names gnttab_stubs)) + (name xengnt) + (modules gnt) + (wrapped false)=20 + (libraries unix xen.mmap)) diff --git a/tools/ocaml/libs/mmap/gnt.ml b/tools/ocaml/libs/mmap/gnt.ml new file mode 100644 index 0000000000..65f0334b7c --- /dev/null +++ b/tools/ocaml/libs/mmap/gnt.ml @@ -0,0 +1,60 @@ +(* + * Copyright (c) 2010 Anil Madhavapeddy + * Copyright (C) 2012-2014 Citrix 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. + *) + +type gntref =3D int +type domid =3D int + +let console =3D 0 (* public/grant_table.h:GNTTAB_RESERVED_CONSOLE *) +let xenstore =3D 1 (* public/grant_table.h:GNTTAB_RESERVED_XENSTORE *) + +type grant_handle (* handle to a mapped grant *) + +module Gnttab =3D struct + type interface + + external interface_open': unit -> interface =3D "stub_gnttab_interface_o= pen" + + let interface_open () =3D + try + interface_open' () + with e -> + Printf.fprintf stderr "Failed to open grant table device: ENOENT\n"; + Printf.fprintf stderr "Does this system have Xen userspace grant tab= le support?\n"; + Printf.fprintf stderr "On linux try:\n"; + Printf.fprintf stderr " sudo modprobe xen-gntdev\n%!"; + raise e + + external interface_close: interface -> unit =3D "stub_gnttab_interface_c= lose" + + type grant =3D { + domid: domid; + ref: gntref; + } + + module Local_mapping =3D struct + type t =3D Xenmmap.mmap_interface + + let to_pages t =3D t + end + + external unmap_exn : interface -> Local_mapping.t -> unit =3D "stub_gntt= ab_unmap" + + external map_fresh_exn: interface -> gntref -> domid -> bool -> Local_ma= pping.t =3D "stub_gnttab_map_fresh" + + let map_exn interface grant writable =3D + map_fresh_exn interface grant.ref grant.domid writable +end diff --git a/tools/ocaml/libs/mmap/gnt.mli b/tools/ocaml/libs/mmap/gnt.mli new file mode 100644 index 0000000000..302e13b05d --- /dev/null +++ b/tools/ocaml/libs/mmap/gnt.mli @@ -0,0 +1,86 @@ +(* + * Copyright (c) 2010 Anil Madhavapeddy + * Copyright (C) 2012-2014 Citrix Inc + *=20 + * 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. + *) + +(** Allow a local xen domain to read/write memory exported ("granted") + from foreign domains. Safe memory sharing is a building block of all + xen inter-domain communication protocols such as those for virtual + network and disk devices. + + Foreign domains will explicitly "grant" us access to certain memory + regions such as disk buffers. These regions are uniquely identified + by the pair of (foreign domain id, integer reference) which is + passed to us over some existing channel (typically via xenstore keys + or via structures in previously-shared memory region). +*) + +(** {2 Common interface} *) + +type gntref =3D int +(** Type of a grant table index, called a grant reference in + Xen's terminology. *) + +(** {2 Receiving foreign pages} *) + +module Gnttab : sig + type interface + (** A connection to the grant device, needed for mapping/unmapping *) + + val interface_open: unit -> interface + (** Open a connection to the grant device. This must be done before any + calls to map or unmap. *) + + val interface_close: interface -> unit + (** Close a connection to the grant device. Any future calls to map or + unmap will fail. *) + + type grant =3D { + domid: int; + (** foreign domain who is exporting memory *) + ref: gntref; + (** id which identifies the specific export in the foreign domain *) + } + (** A foreign domain must explicitly "grant" us memory and send us the + "reference". The pair of (foreign domain id, reference) uniquely + identifies the block of memory. This pair ("grant") is transmitted + to us out-of-band, usually either via xenstore during device setup or + via a shared memory ring structure. *) + + module Local_mapping : sig + type t + (** Abstract type representing a locally-mapped shared memory page *) + + val to_pages: t -> Xenmmap.mmap_interface + end + + val map_exn : interface -> grant -> bool -> Local_mapping.t + (** [map_exn if grant writable] creates a single mapping from + [grant] that will be writable if [writable] is [true]. *) + + val unmap_exn: interface -> Local_mapping.t -> unit + (** Unmap a single mapping (which may involve multiple grants). Throws a + Failure if unsuccessful. *) +end + +val console: gntref +(** In xen-4.2 and later, the domain builder will allocate one of the + reserved grant table entries and use it to pre-authorise the console + backend domain. *) + +val xenstore: gntref +(** In xen-4.2 and later, the domain builder will allocate one of the + reserved grant table entries and use it to pre-authorise the xenstore + backend domain. *) diff --git a/tools/ocaml/libs/mmap/gnttab_stubs.c b/tools/ocaml/libs/mmap/g= nttab_stubs.c new file mode 100644 index 0000000000..f0b4ab237f --- /dev/null +++ b/tools/ocaml/libs/mmap/gnttab_stubs.c @@ -0,0 +1,106 @@ +/* + * Copyright (C) 2012-2013 Citrix 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 + +/* For PROT_READ | PROT_WRITE */ +#include + +#define CAML_NAME_SPACE +#include +#include +#include +#include +#include +#include + +#include "xengnttab.h" +#include "mmap_stubs.h" + +#ifndef Data_abstract_val +#define Data_abstract_val(v) ((void*) Op_val(v)) +#endif + +#define _G(__g) (*((xengnttab_handle**)Data_abstract_val(__g))) + +CAMLprim value stub_gnttab_interface_open(void) +{ + CAMLparam0(); + CAMLlocal1(result); + xengnttab_handle *xgh; + + xgh =3D xengnttab_open(NULL, 0); + if (xgh =3D=3D NULL) + caml_failwith("Failed to open interface"); + result =3D caml_alloc(1, Abstract_tag); + _G(result) =3D xgh; + + CAMLreturn(result); +} + +CAMLprim value stub_gnttab_interface_close(value xgh) +{ + CAMLparam1(xgh); + + xengnttab_close(_G(xgh)); + + CAMLreturn(Val_unit); +} + +#define _M(__m) ((struct mmap_interface*)Data_abstract_val(__m)) +#define XEN_PAGE_SHIFT 12 + +CAMLprim value stub_gnttab_unmap(value xgh, value array) +{ + CAMLparam2(xgh, array); + int result; + + caml_enter_blocking_section(); + result =3D xengnttab_unmap(_G(xgh), _M(array)->addr, _M(array)->len >> XE= N_PAGE_SHIFT); + caml_leave_blocking_section(); + + if(result!=3D0) { + caml_failwith("Failed to unmap grant"); + } + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_gnttab_map_fresh( + value xgh, + value reference, + value domid, + value writable + ) +{ + CAMLparam4(xgh, reference, domid, writable); + CAMLlocal1(contents); + void *map; + + caml_enter_blocking_section(); + map =3D xengnttab_map_grant_ref(_G(xgh), Int_val(domid), Int_val(referenc= e), + Bool_val(writable)?PROT_READ | PROT_WRITE:PROT_READ); + caml_leave_blocking_section(); + + if(map=3D=3DNULL) { + caml_failwith("Failed to map grant ref"); + } + contents =3D stub_mmap_alloc(map, 1 << XEN_PAGE_SHIFT); + CAMLreturn(contents); +} diff --git a/tools/ocaml/xenstored/Makefile b/tools/ocaml/xenstored/Makefile index 9d2da206d8..689a8fb07d 100644 --- a/tools/ocaml/xenstored/Makefile +++ b/tools/ocaml/xenstored/Makefile @@ -67,6 +67,7 @@ XENSTOREDLIBS =3D \ -ccopt -L -ccopt . systemd.cmxa \ -ccopt -L -ccopt . poll.cmxa \ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/= xenmmap.cmxa \ + -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/= gnt.cmxa \ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn $(OCAML_TOPLEVEL)/libs/e= ventchn/xeneventchn.cmxa \ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc $(OCAML_TOPLEVEL)/libs/xc/xenc= trl.cmxa \ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb $(OCAML_TOPLEVEL)/libs/xb/xenb= us.cmxa \ diff --git a/tools/ocaml/xenstored/dune b/tools/ocaml/xenstored/dune index 714a2ae07e..81a6bf7a4a 100644 --- a/tools/ocaml/xenstored/dune +++ b/tools/ocaml/xenstored/dune @@ -1,17 +1,17 @@ (executable - (modes byte exe) + (modes exe) (name xenstored_main) (modules (:standard \ syslog systemd)) (public_name oxenstored) (package xenstored) (flags (:standard -w -52)) - (libraries unix xen.bus xen.mmap xen.ctrl xen.eventchn xenstubs)) + (libraries unix xen.bus xen.mmap xen.ctrl xen.eventchn xenstubs xengnt)) =20 (library (foreign_stubs (language c) (names syslog_stubs systemd_stubs select_stubs) - (flags (-DHAVE_SYSTEMD))) + (flags (-DHAVE_SYSTEMD -I../libs/mmap/))) (modules syslog systemd) (name xenstubs) (wrapped false) diff --git a/tools/ocaml/xenstored/test/gnt.ml b/tools/ocaml/xenstored/test= /gnt.ml new file mode 100644 index 0000000000..ae71e2aaef --- /dev/null +++ b/tools/ocaml/xenstored/test/gnt.ml @@ -0,0 +1,52 @@ +(* + * Copyright (c) 2010 Anil Madhavapeddy + * Copyright (C) 2012-2014 Citrix 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. + *) + +type gntref =3D int +type domid =3D int + +let console =3D 0 (* public/grant_table.h:GNTTAB_RESERVED_CONSOLE *) +let xenstore =3D 1 (* public/grant_table.h:GNTTAB_RESERVED_XENSTORE *) + +type grant_handle (* handle to a mapped grant *) + +module Gnttab =3D struct + type interface =3D unit + + let interface_open () =3D () + let interface_close () =3D () + + type grant =3D { + domid: domid; + ref: gntref; + } + + let unmap_exn () _ =3D () (* FIXME: leak *) + let devzero =3D Unix.openfile "/dev/zero" [] 0 + let nullmap () =3D Xenmmap.mmap devzero Xenmmap.RDWR Xenmmap.PRIVATE 40= 96 0 + let map_fresh_exn () _ _ _ =3D Xenmmap.to_interface (nullmap()) + + module Local_mapping =3D struct + type t =3D Xenmmap.mmap_interface + + let to_pages interface t =3D + Xenmmap.make t ~unmap:(unmap_exn interface) + end + + let map_exn interface grant writable : Local_mapping.t =3D + map_fresh_exn interface grant.ref grant.domid writable + +end diff --git a/tools/ocaml/xenstored/test/testable.ml b/tools/ocaml/xenstored= /test/testable.ml index 2fa749fbb3..37042356b8 100644 --- a/tools/ocaml/xenstored/test/testable.ml +++ b/tools/ocaml/xenstored/test/testable.ml @@ -169,7 +169,8 @@ let () =3D let create ?(live_update =3D false) () =3D let store =3D Store.create () in let cons =3D Connections.create () in - let doms =3D Domains.init (Event.init ()) ignore in + let gnt =3D Gnt.Gnttab.interface_open () in (* dummy *) + let doms =3D Domains.init (Event.init ()) gnt ignore in let dom0 =3D Domains.create0 doms in let txidtbl =3D Hashtbl.create 47 in Connections.add_domain cons dom0 ; diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xen= stored.ml index 34e706910e..a6b86b167c 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -166,9 +166,8 @@ let from_channel_f_compat chan global_f socket_f domain= _f watch_f store_f =3D global_f ~rw | "socket" :: fd :: [] -> socket_f ~fd:(int_of_string fd) - | "dom" :: domid :: mfn :: port :: []-> + | "dom" :: domid :: _mfn :: port :: []-> domain_f (int_of_string domid) - (Nativeint.of_string mfn) (int_of_string port) | "watch" :: domid :: path :: token :: [] -> watch_f (int_of_string domid) @@ -208,10 +207,10 @@ let from_channel_compat ~live store cons doms chan = =3D else warn "Ignoring invalid socket FD %d" fd in - let domain_f domid mfn port =3D + let domain_f domid port =3D let ndom =3D if domid > 0 then - Domains.create doms domid mfn port + Domains.create doms domid port else Domains.create0 doms in @@ -270,8 +269,7 @@ let from_channel_bin ~live store cons doms chan =3D Connections.find_domain cons 0 | LR.Domain d -> debug "Recreating domain %d, port %d" d.id d.remote_port;=20 - (* FIXME: gnttab *) - Domains.create doms d.id 0n d.remote_port + Domains.create doms d.id d.remote_port |> Connections.add_domain cons; Connections.find_domain cons d.id | LR.Socket fd -> --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620757221; cv=none; d=zohomail.com; s=zohoarc; b=bLLt+ez9zZO8TXZnQ6G+XeIvfIfD61hpwrN3Om+Ci2JD93Ou7gAZ4xw05IFaTNhINUzozIFRXHWAqnsTlZwHUdBuUQo+Y7frYf8PogY3BcK7mQGGrA0whMaujreApgnacCJ42X8dcUc5aguXFC+ZvgmK2geUsUnoXHYD5Mh/YwQ= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620757221; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=8UATXPU8sTm/h1bKCxJ+aQ6ltdE2nEONxhI+t4BNCgg=; b=Qn4nZIOFu09OOGc2aAw9/J2X5VpIoJ/nRUj5NaBYE+DHo1O0SrcPQb36w8B1QKtEkgZl8yAmltUMYYIEDicJLurQX4PJZ7jXmMnanGNodDxXxAlJIGE2gFQmMECyk/9P8zaFuTFJ1JKJqPkPVhGLPRXlwm7Yrab0Yb7y2NtTbk0= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620757221963907.652004992473; Tue, 11 May 2021 11:20:21 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125968.237169 (Exim 4.92) (envelope-from ) id 1lgWzJ-0002bh-3a; Tue, 11 May 2021 18:20:09 +0000 Received: by outflank-mailman (output) from mailman id 125968.237169; Tue, 11 May 2021 18:20:09 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWzI-0002bK-RU; Tue, 11 May 2021 18:20:08 +0000 Received: by outflank-mailman (input) for mailman id 125968; Tue, 11 May 2021 18:20:07 +0000 Received: from us1-rack-iad1.inumbo.com ([172.99.69.81]) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWzH-0007g6-Gl for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:20:07 +0000 Received: from esa3.hc3370-68.iphmx.com (unknown [216.71.145.155]) by us1-rack-iad1.inumbo.com (Halon) with ESMTPS id 88ff7d7f-6c71-4a69-8edb-c37ae6c09640; Tue, 11 May 2021 18:19:54 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 88ff7d7f-6c71-4a69-8edb-c37ae6c09640 DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620757194; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=vLnsZPs8BICIF7ZVuZV/p4rSztfidYu+6cB1ksjHrPs=; b=Y49JnBmCod3yo8Xc8u2idtcJmcLc6vgk/A7VOa1kMU1tj2VkljT09uo4 1LiyjECCTYxnqUAs8n1XFMU6uWXXuepDXRDAwwfkHmCPUr0PVXXujWthV dCv5N8Z70Uc7QGXM9KhpobI+GkZRhTlG3XXBPyCDkd31/oyyXFgX6wbkq w=; Authentication-Results: esa3.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: hOS2G/aFV/aXoVyR5dAibfzoLgF/9nA3Lys700JNgpd8zSz8ovffHnIYY2GjGow1RtG4tKVnNS OVFwr4jKpLo/DBFUD8CWZuAPe8VTWKM+iNuDqnqDyaQthiV1DzZ4zlcvySgAvWF4Y/3JtI3JTu 9ar3fFqtIVRgnJWiwPfVB0KlcvCwOKDt1J29dchHXGXYVct4IsmwhZ7HBQ4ZugXpnua7j4UoMB 0OAfpLYhAvx+V+NbZNgkNVK9tPbh6tWYMonKZPtHavvDyVeTscjAM0ivWBWjZSMcUB2p/HnuMJ +38= X-SBRS: 5.1 X-MesageID: 43580616 X-Ironport-Server: esa3.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:KlyDw6z8XyK2zqkOsK6lKrPwFL1zdoMgy1knxilNoRw8SKKlfq eV7Y0mPH7P+VAssR4b+exoVJPtfZqYz+8R3WBzB8bEYOCFghrKEGgK1+KLqFeMJ8S9zJ846U 4JSdkHNDSaNzlHZKjBjzVQa+xQouW6zA== X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43580616" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 14/17] tools/ocaml: safer Xenmmap interface Date: Tue, 11 May 2021 19:05:27 +0100 Message-ID: <3e5e2d75c78646d31f4d50625cd0c05c70bae331.1620755942.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) Xenmmap.mmap_interface is created from multiple places: * via mmap(), which needs to be unmap()-ed * xc_map_foreign_range * xengnttab_map_grant_ref Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/libs/mmap/gnt.ml | 14 ++++++++------ tools/ocaml/libs/mmap/gnt.mli | 3 ++- tools/ocaml/libs/mmap/xenmmap.ml | 14 ++++++++++++-- tools/ocaml/libs/mmap/xenmmap.mli | 11 ++++++++--- tools/ocaml/libs/xb/xb.ml | 10 +++++----- tools/ocaml/libs/xb/xb.mli | 4 ++-- tools/ocaml/libs/xc/xenctrl.ml | 6 ++++-- tools/ocaml/libs/xc/xenctrl.mli | 5 ++--- tools/ocaml/xenstored/domain.ml | 2 +- 9 files changed, 44 insertions(+), 25 deletions(-) diff --git a/tools/ocaml/libs/mmap/gnt.ml b/tools/ocaml/libs/mmap/gnt.ml index 65f0334b7c..bef2d3e850 100644 --- a/tools/ocaml/libs/mmap/gnt.ml +++ b/tools/ocaml/libs/mmap/gnt.ml @@ -45,16 +45,18 @@ module Gnttab =3D struct ref: gntref; } =20 + external unmap_exn : interface -> Xenmmap.mmap_interface -> unit =3D "st= ub_gnttab_unmap" + + external map_fresh_exn: interface -> gntref -> domid -> bool -> Xenmmap.= mmap_interface =3D "stub_gnttab_map_fresh" + module Local_mapping =3D struct type t =3D Xenmmap.mmap_interface =20 - let to_pages t =3D t + let to_pages interface t =3D + Xenmmap.make t ~unmap:(unmap_exn interface) end =20 - external unmap_exn : interface -> Local_mapping.t -> unit =3D "stub_gntt= ab_unmap" - - external map_fresh_exn: interface -> gntref -> domid -> bool -> Local_ma= pping.t =3D "stub_gnttab_map_fresh" - let map_exn interface grant writable =3D - map_fresh_exn interface grant.ref grant.domid writable + map_fresh_exn interface grant.ref grant.domid writable + end diff --git a/tools/ocaml/libs/mmap/gnt.mli b/tools/ocaml/libs/mmap/gnt.mli index 302e13b05d..13ab4c7ead 100644 --- a/tools/ocaml/libs/mmap/gnt.mli +++ b/tools/ocaml/libs/mmap/gnt.mli @@ -53,6 +53,7 @@ module Gnttab : sig ref: gntref; (** id which identifies the specific export in the foreign domain *) } + (** A foreign domain must explicitly "grant" us memory and send us the "reference". The pair of (foreign domain id, reference) uniquely identifies the block of memory. This pair ("grant") is transmitted @@ -63,7 +64,7 @@ module Gnttab : sig type t (** Abstract type representing a locally-mapped shared memory page *) =20 - val to_pages: t -> Xenmmap.mmap_interface + val to_pages: interface -> t -> Xenmmap.t end =20 val map_exn : interface -> grant -> bool -> Local_mapping.t diff --git a/tools/ocaml/libs/mmap/xenmmap.ml b/tools/ocaml/libs/mmap/xenmm= ap.ml index 44b67c89d2..af258942a0 100644 --- a/tools/ocaml/libs/mmap/xenmmap.ml +++ b/tools/ocaml/libs/mmap/xenmmap.ml @@ -15,17 +15,27 @@ *) =20 type mmap_interface +type t =3D mmap_interface * (mmap_interface -> unit) + =20 type mmap_prot_flag =3D RDONLY | WRONLY | RDWR type mmap_map_flag =3D SHARED | PRIVATE =20 (* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *) -external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag +external mmap': Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int -> mmap_interface =3D "stub_mmap_init" -external unmap: mmap_interface -> unit =3D "stub_mmap_final" (* read: interface -> start -> length -> data *) external read: mmap_interface -> int -> int -> string =3D "stub_mmap_read" (* write: interface -> data -> start -> length -> unit *) external write: mmap_interface -> string -> int -> int -> unit =3D "stub_m= map_write" (* getpagesize: unit -> size of page *) +external unmap': mmap_interface -> unit =3D "stub_mmap_final" +(* getpagesize: unit -> size of page *) +let make ?(unmap=3Dunmap') interface =3D interface, unmap external getpagesize: unit -> int =3D "stub_mmap_getpagesize" + +let to_interface (intf, _) =3D intf +let mmap fd prot_flag map_flag length offset =3D + let map =3D mmap' fd prot_flag map_flag length offset in + make map ~unmap:unmap' +let unmap (map, do_unmap) =3D do_unmap map diff --git a/tools/ocaml/libs/mmap/xenmmap.mli b/tools/ocaml/libs/mmap/xenm= map.mli index 8f92ed6310..075b24eab4 100644 --- a/tools/ocaml/libs/mmap/xenmmap.mli +++ b/tools/ocaml/libs/mmap/xenmmap.mli @@ -14,15 +14,20 @@ * GNU Lesser General Public License for more details. *) =20 +type t type mmap_interface type mmap_prot_flag =3D RDONLY | WRONLY | RDWR type mmap_map_flag =3D SHARED | PRIVATE =20 -external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int = -> int - -> mmap_interface =3D "stub_mmap_init" -external unmap : mmap_interface -> unit =3D "stub_mmap_final" external read : mmap_interface -> int -> int -> string =3D "stub_mmap_read" external write : mmap_interface -> string -> int -> int -> unit =3D "stub_mmap_write" =20 +val mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> in= t -> t +val unmap : t -> unit + +val make: ?unmap:(mmap_interface -> unit) -> mmap_interface -> t=20 + +val to_interface: t -> mmap_interface + external getpagesize : unit -> int =3D "stub_mmap_getpagesize" diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml index 104d319d77..4ddf741420 100644 --- a/tools/ocaml/libs/xb/xb.ml +++ b/tools/ocaml/libs/xb/xb.ml @@ -28,7 +28,7 @@ let _ =3D =20 type backend_mmap =3D { - mmap: Xenmmap.mmap_interface; (* mmaped interface =3D xs_ring *) + mmap: Xenmmap.t; (* mmaped interface =3D xs_ring *) eventchn_notify: unit -> unit; (* function to notify through eventchn *) mutable work_again: bool; } @@ -59,7 +59,7 @@ let reconnect t =3D match t.backend with (* should never happen, so close the connection *) raise End_of_file | Xenmmap backend -> - Xs_ring.close backend.mmap; + Xs_ring.close Xenmmap.(to_interface backend.mmap); backend.eventchn_notify (); (* Clear our old connection state *) Queue.clear t.pkt_in; @@ -77,7 +77,7 @@ let read_fd back _con b len =3D =20 let read_mmap back _con b len =3D let s =3D Bytes.make len '\000' in - let rd =3D Xs_ring.read back.mmap s len in + let rd =3D Xs_ring.read Xenmmap.(to_interface back.mmap) s len in Bytes.blit s 0 b 0 rd; back.work_again <- (rd > 0); if rd > 0 then @@ -93,7 +93,7 @@ let write_fd back _con b len =3D Unix.write_substring back.fd b 0 len =20 let write_mmap back _con s len =3D - let ws =3D Xs_ring.write_substring back.mmap s len in + let ws =3D Xs_ring.write_substring Xenmmap.(to_interface back.mmap) s len= in if ws > 0 then back.eventchn_notify (); ws @@ -167,7 +167,7 @@ let open_fd fd =3D newcon (Fd { fd =3D fd; }) =20 let open_mmap mmap notifyfct =3D (* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *) - Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton Xs_ri= ng.Server_feature.Reconnection); + Xs_ring.set_server_features (Xenmmap.to_interface mmap) (Xs_ring.Server_f= eatures.singleton Xs_ring.Server_feature.Reconnection); newcon (Xenmmap { mmap =3D mmap; eventchn_notify =3D notifyfct; diff --git a/tools/ocaml/libs/xb/xb.mli b/tools/ocaml/libs/xb/xb.mli index 3a00da6cdd..0184d77ffc 100644 --- a/tools/ocaml/libs/xb/xb.mli +++ b/tools/ocaml/libs/xb/xb.mli @@ -59,7 +59,7 @@ exception Noent exception Invalid exception Reconnect type backend_mmap =3D { - mmap : Xenmmap.mmap_interface; + mmap : Xenmmap.t; eventchn_notify : unit -> unit; mutable work_again : bool; } @@ -86,7 +86,7 @@ val output : t -> bool val input : t -> bool val newcon : backend -> t val open_fd : Unix.file_descr -> t -val open_mmap : Xenmmap.mmap_interface -> (unit -> unit) -> t +val open_mmap : Xenmmap.t -> (unit -> unit) -> t val close : t -> unit val is_fd : t -> bool val is_mmap : t -> bool diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml index a5588c643f..49950c368a 100644 --- a/tools/ocaml/libs/xc/xenctrl.ml +++ b/tools/ocaml/libs/xc/xenctrl.ml @@ -265,9 +265,11 @@ external domain_set_memmap_limit: handle -> domid -> i= nt64 -> unit external domain_memory_increase_reservation: handle -> domid -> int64 -> u= nit =3D "stub_xc_domain_memory_increase_reservation" =20 -external map_foreign_range: handle -> domid -> int +external map_foreign_range': handle -> domid -> int -> nativeint -> Xenmmap.mmap_interface - =3D "stub_map_foreign_range" + =3D "stub_map_foreign_range" +let map_foreign_range handle domid port mfn =3D + Xenmmap.make (map_foreign_range' handle domid port mfn) =20 external domain_assign_device: handle -> domid -> (int * int * int * int) = -> unit =3D "stub_xc_domain_assign_device" diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.= mli index 6e94940a8a..ad9d07e7a0 100644 --- a/tools/ocaml/libs/xc/xenctrl.mli +++ b/tools/ocaml/libs/xc/xenctrl.mli @@ -202,9 +202,8 @@ external domain_set_memmap_limit : handle -> domid -> i= nt64 -> unit external domain_memory_increase_reservation : handle -> domid -> int64 -> unit =3D "stub_xc_domain_memory_increase_reservation" -external map_foreign_range : - handle -> domid -> int -> nativeint -> Xenmmap.mmap_interface - =3D "stub_map_foreign_range" +val map_foreign_range : + handle -> domid -> int -> nativeint -> Xenmmap.t =20 external domain_assign_device: handle -> domid -> (int * int * int * int) = -> unit =3D "stub_xc_domain_assign_device" diff --git a/tools/ocaml/xenstored/domain.ml b/tools/ocaml/xenstored/domain= .ml index 81cb59b8f1..82d7b1a7ef 100644 --- a/tools/ocaml/xenstored/domain.ml +++ b/tools/ocaml/xenstored/domain.ml @@ -23,7 +23,7 @@ type t =3D { id: Xenctrl.domid; mfn: nativeint; - interface: Xenmmap.mmap_interface; + interface: Xenmmap.t; eventchn: Event.t; mutable remote_port: int; mutable port: Xeneventchn.t option; --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620757209; cv=none; d=zohomail.com; s=zohoarc; b=E/79A7QPYL+otkHs7VBdv3SrbRBvm5xQc8rXuHrnNvXXXCmNxIVpC0OqGM4vwh8tW5zAox/lRYhitp07qef13rx5KGKeG9xZSR893ib5rvigUCIjNjlqE5xItynW0JuACK20mq/Mg/HZzv4taNCSYtdUt5vvBYRen/itrEZP6y4= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620757209; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=ZWqvvfH/pSuceHqfiA4kqYHT6DIfxmT8+4jW3pShXB0=; b=WgoGIt0SFWoNNoizt2nTeTqWxsAwgktAIYBMN/gWPGzxXApKCq3AEDo9F/I1YFgNx36vWh3dhQ3ifEvrdBmZU0I9OooihROP/jo1ySIS/GprrlI2QvNJDGicwix3BCqbSEed+A7TlIKchZulvjcimeeR402++o8VSrUHxOXOIpQ= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620757209220979.2123440320045; Tue, 11 May 2021 11:20:09 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125963.237120 (Exim 4.92) (envelope-from ) id 1lgWz7-0000Bd-5n; Tue, 11 May 2021 18:19:57 +0000 Received: by outflank-mailman (output) from mailman id 125963.237120; Tue, 11 May 2021 18:19:57 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWz7-0000BV-2T; Tue, 11 May 2021 18:19:57 +0000 Received: by outflank-mailman (input) for mailman id 125963; Tue, 11 May 2021 18:19:56 +0000 Received: from all-amaz-eas1.inumbo.com ([34.197.232.57] helo=us1-amaz-eas2.inumbo.com) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWz6-0007fz-5J for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:19:56 +0000 Received: from esa6.hc3370-68.iphmx.com (unknown [216.71.155.175]) by us1-amaz-eas2.inumbo.com (Halon) with ESMTPS id 004134c6-8940-498b-b7f6-53c71747813c; Tue, 11 May 2021 18:19:52 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 004134c6-8940-498b-b7f6-53c71747813c DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620757192; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=/QT5ezwDnkjXc3nVgBVAB8DaWEl/4FRFCADP++oYh28=; b=Jdu6ymxTEyir3Wpq1Vlje0oTSI8uvRDp3EyQ5XHU8GofqKnyO/4yfL/T tadaeJnDhPWPHVau6fdtmwh0bZEN92ikFEct1VuRWE+8T+4Bto5mRkjmo XhPMYX+n/3LKVu7pP4SrfkG0+/zf7153MPrjkTArPJkUgO2F6N1x6W1iT o=; Authentication-Results: esa6.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: CKYOs+i1d3uxTBukfgQWpA1/0Q6N5xF4YW3jDwQw4XsDP1Yu/ygVFpSXvRJ3wFHVWtIMu3qyOX F9MHR0nLkK4Jyspb534EhqoXML/Esnp857rRv0rWlQ5smYpGBZDZx0sGM3p6785xDL2X7wBbEX Qb5pYN3pIQllJJ3iigpKUx5qV+7pSHODIad8Vvb/r5S/HNEiwr5l2rtW5DFqtLRrgjc6ygT9t2 zkO4fJLvzYevOalpREIDVvSWqSfkDcLy1i2K+LfbAv9VRyHxi/RD7guWQCnoUkR43o9Ah/vROA G+8= X-SBRS: 5.1 X-MesageID: 43676922 X-Ironport-Server: esa6.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:jUJ+BaDEC34bMKflHelo55DYdb4zR+YMi2TDt3oddfU1SL38qy nKpp4mPHDP5wr5NEtPpTniAtjjfZq/z/5ICOAqVN/PYOCPggCVxepZnOjfKlPbehEX9oRmpN 1dm6oVMqyMMbCt5/yKnDVRELwbsaa6GLjDv5a785/0JzsaE52J6W1Ce2GmO3wzfiZqL7wjGq GR48JWzgDQAkj+PqyAdx84t/GonayzqK7b X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43676922" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu , Andrew Cooper Subject: [PATCH v2 15/17] tools/ocaml/xenstored: use gnttab instead of xenctrl's foreign_map_range Date: Tue, 11 May 2021 19:05:28 +0100 Message-ID: <2e703b8a3e75370ed0208b2c1da9a3562df82a14.1620755943.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) This is an oxenstored port of the following C xenstored commit: 38eeb3864de40aa568c48f9f26271c141c62b50b tools/xenstored: Drop mapping of t= he ring via foreign map Now only Xenctrl.domain_getinfo remains as the last use of unstable xenctrl= interface in oxenstored. Depends on: tools/ocaml: safer Xenmmap interface (without it the code would build but the wrong unmap function would get called on domain destruction) CC: Andrew Cooper Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/xenstored/domains.ml | 7 +++++-- tools/ocaml/xenstored/xenstored.ml | 3 ++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/tools/ocaml/xenstored/domains.ml b/tools/ocaml/xenstored/domai= ns.ml index 17fe2fa257..d9cb693751 100644 --- a/tools/ocaml/xenstored/domains.ml +++ b/tools/ocaml/xenstored/domains.ml @@ -22,6 +22,7 @@ let xc =3D Xenctrl.interface_open () =20 type domains =3D { eventchn: Event.t; + gnttab: Gnt.Gnttab.interface; table: (Xenctrl.domid, Domain.t) Hashtbl.t; =20 (* N.B. the Queue module is not thread-safe but oxenstored is single-thre= aded. *) @@ -42,8 +43,9 @@ type domains =3D { mutable n_penalised: int; (* Number of domains with less than maximum cre= dit *) } =20 -let init eventchn on_first_conflict_pause =3D { +let init eventchn gnttab on_first_conflict_pause =3D { eventchn =3D eventchn; + gnttab; table =3D Hashtbl.create 10; doms_conflict_paused =3D Queue.create (); doms_with_conflict_penalty =3D Queue.create (); @@ -123,7 +125,8 @@ let resume _doms _domid =3D () =20 let create doms domid mfn port =3D - let interface =3D Xenctrl.map_foreign_range xc domid (Xenmmap.getpagesize= ()) mfn in + let mapping =3D Gnt.(Gnttab.map_exn doms.gnttab { domid; ref =3D xenstore= } true) in + let interface =3D Gnt.Gnttab.Local_mapping.to_pages doms.gnttab mapping in let dom =3D Domain.make domid mfn port interface doms.eventchn in Hashtbl.add doms.table domid dom; Domain.bind_interdomain dom; diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xen= stored.ml index a6b86b167c..75c35107d5 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -446,6 +446,7 @@ let main () =3D =20 let store =3D Store.create () in let eventchn =3D Event.init () in + let gnttab =3D Gnt.Gnttab.interface_open () in let next_frequent_ops =3D ref 0. in let advance_next_frequent_ops () =3D next_frequent_ops :=3D (Unix.gettimeofday () +. !Define.conflict_max_his= tory_seconds) @@ -453,7 +454,7 @@ let main () =3D let delay_next_frequent_ops_by duration =3D next_frequent_ops :=3D !next_frequent_ops +. duration in - let domains =3D Domains.init eventchn advance_next_frequent_ops in + let domains =3D Domains.init eventchn gnttab advance_next_frequent_ops in =20 (* For things that need to be done periodically but more often * than the periodic_ops function *) --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620757204; cv=none; d=zohomail.com; s=zohoarc; b=Jo8BLkoiyj5tRh22AO8HRuVwL6FYIhnj/EH/MPd10MJYoIV7YRJaoCpBusROfDC68dGJgs3uY7Xp95rFVQkUPmsv6GABgwpdkfVl1MmHPnsiBvBq74Xj0puJHcdkigjRnvh3mw+MF07chvUOdfe4+X82euYcvUwyv/xYBdkaDUw= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620757204; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=lGkeq4Ejs6PJtcsCCAUpY903JDs54yIbxj+g3I6Miz0=; b=EyhpX/C2rRlAgkIZ0/wuxDlTI+DYYWXZ6EryaN3uOq3qUndtLRnTm9uJSX+0jbTwvRoKajOcEBGc0V0TRstCK8rUjqQcmNo43SY4nPoC7AKY1hHELWcHr5/DcotvgnvVFcRWdd+UGUdhMAHi8S2LZu+CCtfZ4czritG/v1UreCA= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620757204450334.74157220027814; Tue, 11 May 2021 11:20:04 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125960.237090 (Exim 4.92) (envelope-from ) id 1lgWyy-0007jj-NK; Tue, 11 May 2021 18:19:48 +0000 Received: by outflank-mailman (output) from mailman id 125960.237090; Tue, 11 May 2021 18:19:48 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWyy-0007iS-GO; Tue, 11 May 2021 18:19:48 +0000 Received: by outflank-mailman (input) for mailman id 125960; Tue, 11 May 2021 18:19:47 +0000 Received: from us1-rack-iad1.inumbo.com ([172.99.69.81]) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWyx-0007g6-HP for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:19:47 +0000 Received: from esa1.hc3370-68.iphmx.com (unknown [216.71.145.142]) by us1-rack-iad1.inumbo.com (Halon) with ESMTPS id 0b63d9b5-d94b-41d2-920f-8f6312662347; Tue, 11 May 2021 18:19:46 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 0b63d9b5-d94b-41d2-920f-8f6312662347 DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620757186; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=SU7cgAQhk8vsTkLv/y2uGvNvL2Atz9xPDkxcsiAL/Ik=; b=DF2iR63RcPxEEgp5BdlmahraON9RvtLSzlhmj8WPmXh0+MnIZRjIrdP+ kvuXgjybqV6Rle9uoS7KhyILgYDjXzvrkLTS/S1rNKf5fdLt1HRyP4U0R YeXUsr2WToNHrUp00vq5gxznRf03UfQjiuGWtso8h194dTKBdCBPR9i2m 0=; Authentication-Results: esa1.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: Js8J1Ottk9+P26tbK96orEpViIabgTRWSOozgof7eDuwY7XKgwVCvGH0wBVhvtSCELEnFH6OJ0 fBp22c5JAdwR7wDAGrXyMhkeEsMspYxwUf93ZrkIutqa4FMP7EGaPEZJAL3D8gqS9yq/c+jxDZ Il+RjeVW592GORgriTnu20gCMwlO175x/506AASueEQwnhscllpB1n1TqbbMz94191Y6RGxQjH YTxsahTYWhchKTcXO5fsX5eaVAaRvofo9uNw5FDs6chwZVMmWlqb9+y7Dd4odwuOeQGR4oRAZf j3E= X-SBRS: 5.1 X-MesageID: 43955845 X-Ironport-Server: esa1.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:7A/JIa6E+2oilrlqOQPXwPDXdLJyesId70hD6qhwISY6TiX+rb HWoB17726TtN9/YhEdcLy7VJVoBEmskKKdgrNhWotKPjOW21dARbsKheCJrgEIWReOktK1vZ 0QC5SWY+eQMbEVt6nHCXGDYrQd/OU= X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43955845" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu , Juergen Gross Subject: [PATCH v2 16/17] tools/ocaml/xenstored: don't store domU's mfn of ring page Date: Tue, 11 May 2021 19:05:29 +0100 Message-ID: <49200c1e5de78257fc43e26f545651484dbe4ff0.1620755943.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) This is a port of the following C xenstored commit 122b52230aa5b79d65e18b8b77094027faa2f8e2 tools/xenstore: don't store domU's= mfn of ring page in xenstored Backwards compat: accept a domain dump both with and without MFN. CC: Juergen Gross Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/xenstored/domain.ml | 7 ++----- tools/ocaml/xenstored/domains.ml | 6 +++--- tools/ocaml/xenstored/process.ml | 16 +++++----------- 3 files changed, 10 insertions(+), 19 deletions(-) diff --git a/tools/ocaml/xenstored/domain.ml b/tools/ocaml/xenstored/domain= .ml index 82d7b1a7ef..960ebef218 100644 --- a/tools/ocaml/xenstored/domain.ml +++ b/tools/ocaml/xenstored/domain.ml @@ -22,7 +22,6 @@ let warn fmt =3D Logging.warn "domain" fmt type t =3D { id: Xenctrl.domid; - mfn: nativeint; interface: Xenmmap.t; eventchn: Event.t; mutable remote_port: int; @@ -40,7 +39,6 @@ type t =3D let is_dom0 d =3D d.id =3D 0 let get_id domain =3D domain.id let get_interface d =3D d.interface -let get_mfn d =3D d.mfn let get_remote_port d =3D d.remote_port let get_port d =3D d.port =20 @@ -61,7 +59,7 @@ let string_of_port =3D function | Some x -> string_of_int (Xeneventchn.to_int x) =20 let dump d chan =3D - fprintf chan "dom,%d,%nd,%d\n" d.id d.mfn d.remote_port + fprintf chan "dom,%d,%d\n" d.id d.remote_port =20 let notify dom =3D match dom.port with | None -> @@ -87,9 +85,8 @@ let close dom =3D Xenmmap.unmap dom.interface; () =20 -let make id mfn remote_port interface eventchn =3D { +let make id remote_port interface eventchn =3D { id =3D id; - mfn =3D mfn; remote_port =3D remote_port; interface =3D interface; eventchn =3D eventchn; diff --git a/tools/ocaml/xenstored/domains.ml b/tools/ocaml/xenstored/domai= ns.ml index d9cb693751..0dfeed193a 100644 --- a/tools/ocaml/xenstored/domains.ml +++ b/tools/ocaml/xenstored/domains.ml @@ -124,10 +124,10 @@ let cleanup doms =3D let resume _doms _domid =3D () =20 -let create doms domid mfn port =3D +let create doms domid port =3D let mapping =3D Gnt.(Gnttab.map_exn doms.gnttab { domid; ref =3D xenstore= } true) in let interface =3D Gnt.Gnttab.Local_mapping.to_pages doms.gnttab mapping in - let dom =3D Domain.make domid mfn port interface doms.eventchn in + let dom =3D Domain.make domid port interface doms.eventchn in Hashtbl.add doms.table domid dom; Domain.bind_interdomain dom; dom @@ -147,7 +147,7 @@ let create0 doms =3D port, interface ) in - let dom =3D Domain.make 0 Nativeint.zero port interface doms.eventchn in + let dom =3D Domain.make 0 port interface doms.eventchn in Hashtbl.add doms.table 0 dom; Domain.bind_interdomain dom; Domain.notify dom; diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/proce= ss.ml index 13b7153536..890970b8c5 100644 --- a/tools/ocaml/xenstored/process.ml +++ b/tools/ocaml/xenstored/process.ml @@ -235,10 +235,6 @@ let do_debug con t _domains cons data =3D | "watches" :: _ -> let watches =3D Connections.debug cons in Some (watches ^ "\000") - | "mfn" :: domid :: _ -> - let domid =3D int_of_string domid in - let con =3D Connections.find_domain cons domid in - may (fun dom -> Printf.sprintf "%nd\000" (Domain.get_mfn dom)) (Connecti= on.get_domain con) | _ -> None with _ -> None =20 @@ -554,15 +550,13 @@ let do_introduce con t domains cons data =3D let dom =3D if Domains.exist domains domid then begin let edom =3D Domains.find domains domid in - if (Domain.get_mfn edom) =3D mfn && (Connections.find_domain cons domid= ) !=3D con then begin - (* Use XS_INTRODUCE for recreating the xenbus event-channel. *) - edom.remote_port <- port; - Domain.bind_interdomain edom; - end; + (* Use XS_INTRODUCE for recreating the xenbus event-channel. *) + edom.remote_port <- port; + Domain.bind_interdomain edom; edom end else try - let ndom =3D Domains.create domains domid mfn port in + let ndom =3D Domains.create domains domid port in Connections.add_domain cons ndom; Connections.fire_spec_watches (Transaction.get_root t) cons Store.Path.= introduce_domain; ndom @@ -571,7 +565,7 @@ let do_introduce con t domains cons data =3D Logging.debug "process" "do_introduce: %s (%s)" (Printexc.to_string e)= bt; raise Invalid_Cmd_Args in - if (Domain.get_remote_port dom) <> port || (Domain.get_mfn dom) <> mfn th= en + if (Domain.get_remote_port dom) <> port then raise Domain_not_match =20 let do_release con t domains cons data =3D --=20 2.25.1 From nobody Fri Nov 29 22:53:17 2024 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1620757204; cv=none; d=zohomail.com; s=zohoarc; b=YwcrNwWc8hd+TcigbFZrJ1hkcFSpNEG0CV5K/L62O6rXIFrA9AYqGeKUeoTtiEZWctHyMzKG9bMZQ2HMgCDwI9WFMnmpsS39P+p1S3EJorDLk/Tb2KtC/RCIQ5NsKwYRFgHrdfORsL/iRkAFos8ccFogyJKr/wobZnF3vQhzE8Y= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1620757204; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=OYc4vPQwpGW3I23ppDqLlsGLbyVHtOAhNXNHUDKS2sA=; b=jNUIM62eVi+WyTCepzQH01hqqBVBGq5au5Rmquy5+aAcffKd7XOGq6K4gy3tc7MYbUF6IJMyMkCmimXcqH1pikJpwbG+mqcE/18lH7jKQKeIZcTh1osLlr6EvIRhYo0ewqOVn2Jp6QemZwPPf7ZkXTeGSz9IMGhl+GGElAWZkl0= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) header.from= Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1620757204046553.3633801850682; Tue, 11 May 2021 11:20:04 -0700 (PDT) Received: from list by lists.xenproject.org with outflank-mailman.125959.237084 (Exim 4.92) (envelope-from ) id 1lgWyy-0007gJ-B3; Tue, 11 May 2021 18:19:48 +0000 Received: by outflank-mailman (output) from mailman id 125959.237084; Tue, 11 May 2021 18:19:48 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWyy-0007gC-8A; Tue, 11 May 2021 18:19:48 +0000 Received: by outflank-mailman (input) for mailman id 125959; Tue, 11 May 2021 18:19:46 +0000 Received: from all-amaz-eas1.inumbo.com ([34.197.232.57] helo=us1-amaz-eas2.inumbo.com) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1lgWyw-0007fz-6U for xen-devel@lists.xenproject.org; Tue, 11 May 2021 18:19:46 +0000 Received: from esa6.hc3370-68.iphmx.com (unknown [216.71.155.175]) by us1-amaz-eas2.inumbo.com (Halon) with ESMTPS id 7a4fe988-ddc3-46cd-ab49-5b2f1a4c3dcd; Tue, 11 May 2021 18:19:44 +0000 (UTC) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: 7a4fe988-ddc3-46cd-ab49-5b2f1a4c3dcd DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1620757184; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=mfyFDJgIkLfaf/q9LEu49lHIlJRkjQUjve9JlgsoDR8=; b=fGYhQP2ai9DgOHZnAjk2WWVyFQjmJ6XaPuIHTgU3ZfgbcVcfuYn4MEkd g920QAUan/R0iZZ9faOMaskSd5Fe+sfa4OdqkDf68PHUA/o47nJU18q5U vawgbDNLs494HbRi9Oas8M4EE/TfpC/3l5ybNJCvSVPqD0V2eIeQ0q02M o=; Authentication-Results: esa6.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none IronPort-SDR: iyilpD8SzCuioWNXOA9zFQdv0QcR3XhXht5LopOS6cVHbkq7tv7tK6I/yHXjb/ouc6mgLZvkvm Vp0V5STd83/IReHf6355A4PJeDdXxclLhlEbM6eX/TORACxQJbqoPVWC9GLOntlt4cYetwS/LX 5hgPDAVyhtIlp+jxOznnPz2jNGB13Ux4NtM+q2MYYtdTri0/mpbF1m4h2uEIqq/PFsmjTFsSRq yHomvODWg6ssASAGw9fxtJDw9HE5ZP70w5jMVtJtozSajL4Wzge+1rvn4zwV8d8Tju8Pem+hTU 70s= X-SBRS: 5.1 X-MesageID: 43676913 X-Ironport-Server: esa6.hc3370-68.iphmx.com X-Remote-IP: 162.221.158.21 X-Policy: $RELAYED IronPort-HdrOrdr: A9a23:msXP7qz674nE3o0i9+mmKrPw6L1zdoMgy1knxilNoHxuH/Bw9v re+cjzsCWftN9/Yh4dcLy7VpVoIkmsl6Kdg7NwAV7KZmCP1FdARLsI0WKI+UyCJ8SRzI9gPa cLSdkFNDXzZ2IK8PoTNmODYqodKNrsytHWuQ/HpU0dKT2D88tbnn9E4gDwKDwQeCB2QaAXOb C7/cR9qz+paR0sH7+G7ilsZZmkmzXT/qiWGCI7Ow== X-IronPort-AV: E=Sophos;i="5.82,291,1613451600"; d="scan'208";a="43676913" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , "Christian Lindig" , David Scott , "Ian Jackson" , Wei Liu Subject: [PATCH v2 17/17] tools/ocaml/libs/mmap: Clean up unused read/write Date: Tue, 11 May 2021 19:05:30 +0100 Message-ID: <9bfd0989994953f08142d26cbe5a22651a1faa2a.1620755943.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.25.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) Xenmmap is only modified by the ring functions, these functions are unused. Signed-off-by: Edwin T=C3=B6r=C3=B6k --- tools/ocaml/libs/mmap/xenmmap.ml | 5 ---- tools/ocaml/libs/mmap/xenmmap.mli | 4 --- tools/ocaml/libs/mmap/xenmmap_stubs.c | 41 --------------------------- 3 files changed, 50 deletions(-) diff --git a/tools/ocaml/libs/mmap/xenmmap.ml b/tools/ocaml/libs/mmap/xenmm= ap.ml index af258942a0..e17a62e607 100644 --- a/tools/ocaml/libs/mmap/xenmmap.ml +++ b/tools/ocaml/libs/mmap/xenmmap.ml @@ -24,11 +24,6 @@ type mmap_map_flag =3D SHARED | PRIVATE (* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *) external mmap': Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int -> mmap_interface =3D "stub_mmap_init" -(* read: interface -> start -> length -> data *) -external read: mmap_interface -> int -> int -> string =3D "stub_mmap_read" -(* write: interface -> data -> start -> length -> unit *) -external write: mmap_interface -> string -> int -> int -> unit =3D "stub_m= map_write" -(* getpagesize: unit -> size of page *) external unmap': mmap_interface -> unit =3D "stub_mmap_final" (* getpagesize: unit -> size of page *) let make ?(unmap=3Dunmap') interface =3D interface, unmap diff --git a/tools/ocaml/libs/mmap/xenmmap.mli b/tools/ocaml/libs/mmap/xenm= map.mli index 075b24eab4..abf2a50131 100644 --- a/tools/ocaml/libs/mmap/xenmmap.mli +++ b/tools/ocaml/libs/mmap/xenmmap.mli @@ -19,10 +19,6 @@ type mmap_interface type mmap_prot_flag =3D RDONLY | WRONLY | RDWR type mmap_map_flag =3D SHARED | PRIVATE =20 -external read : mmap_interface -> int -> int -> string =3D "stub_mmap_read" -external write : mmap_interface -> string -> int -> int -> unit - =3D "stub_mmap_write" - val mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> in= t -> t val unmap : t -> unit =20 diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c b/tools/ocaml/libs/mmap/= xenmmap_stubs.c index e8d2d6add5..633e1fa916 100644 --- a/tools/ocaml/libs/mmap/xenmmap_stubs.c +++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c @@ -96,47 +96,6 @@ CAMLprim value stub_mmap_final(value intf) CAMLreturn(Val_unit); } =20 -CAMLprim value stub_mmap_read(value intf, value start, value len) -{ - CAMLparam3(intf, start, len); - CAMLlocal1(data); - int c_start; - int c_len; - - c_start =3D Int_val(start); - c_len =3D Int_val(len); - - if (c_start > Intf_val(intf)->len) - caml_invalid_argument("start invalid"); - if (c_start + c_len > Intf_val(intf)->len) - caml_invalid_argument("len invalid"); - - data =3D caml_alloc_string(c_len); - memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len); - - CAMLreturn(data); -} - -CAMLprim value stub_mmap_write(value intf, value data, - value start, value len) -{ - CAMLparam4(intf, data, start, len); - int c_start; - int c_len; - - c_start =3D Int_val(start); - c_len =3D Int_val(len); - - if (c_start > Intf_val(intf)->len) - caml_invalid_argument("start invalid"); - if (c_start + c_len > Intf_val(intf)->len) - caml_invalid_argument("len invalid"); - - memcpy(Intf_val(intf)->addr + c_start, (char *) data, c_len); - - CAMLreturn(Val_unit); -} - CAMLprim value stub_mmap_getpagesize(value unit) { CAMLparam1(unit); --=20 2.25.1