diff -Nru ounit-2.0.8/appveyor.yml ounit-2.2.3/appveyor.yml --- ounit-2.0.8/appveyor.yml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/appveyor.yml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,16 @@ +platform: + - x86 + +environment: + FORK_USER: ocaml + FORK_BRANCH: master + CYG_ROOT: C:\cygwin64 + EXTRA_DEPS: dune + OUNIT_CI: true + PACKAGE: ounit2 + +install: + - ps: iex ((new-object net.webclient).DownloadString("https://raw.githubusercontent.com/$env:FORK_USER/ocaml-ci-scripts/$env:FORK_BRANCH/appveyor-install.ps1")) + +build_script: + - call %CYG_ROOT%\bin\bash.exe -l %APPVEYOR_BUILD_FOLDER%\appveyor-opam.sh diff -Nru ounit-2.0.8/ardivink.lua ounit-2.2.3/ardivink.lua --- ounit-2.0.8/ardivink.lua 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/ardivink.lua 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -oasis = require("oasis") -darcs = require("darcs") -ci = require("ci") -dist = require("dist") - -ci.init() -oasis.init() -darcs.init() - -ci.prependenv("PATH", "/usr/opt/godi/bin") -ci.prependenv("PATH", "/usr/opt/godi/sbin") -ci.putenv("OUNIT_OUTPUT_HTML_DIR", dist.make_filename("ounit-log-$(suite_name).html")) -ci.putenv("OUNIT_OUTPUT_JUNIT_FILE", dist.make_filename("junit-$(suite_name).xml")) -ci.putenv("OUNIT_OUTPUT_FILE", dist.make_filename("ounit-log-$(suite_name).txt")) - -oasis.std_process("--enable-tests") - --- Create documentation package. -ci.exec("make", "doc-dev-dist") diff -Nru ounit-2.0.8/AUTHORS.txt ounit-2.2.3/AUTHORS.txt --- ounit-2.0.8/AUTHORS.txt 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/AUTHORS.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: 32bb7258886e92969facf1ca9ed449e8) *) - -Authors of ounit: - -* Maas-Maarten Zeeman -* Sylvain Le Gall - -(* OASIS_STOP *) diff -Nru ounit-2.0.8/changelog ounit-2.2.3/changelog --- ounit-2.0.8/changelog 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/changelog 1970-01-01 00:00:00.000000000 +0000 @@ -1,139 +0,0 @@ -ounit-2.0.8 - - - Handle infinity and NaN in cmp_float, thanks to Johannes Kloos - (Closes: #1381) - -ounit-2.0.7 - - - Prevent OUnitLoggerJUnit to fail when the hostname cannot be found, thanks - to Bailey Parker for the fix (Closes: #1744) - -ounit-2.0.6 - - - Fix internal uppercase_name. - -ounit-2.0.5 - - - Allow to recover from interrupted Unix.select call. This allows to - run more reliably the RunnerProcess with lwt. (Closes: #1363) - -ounit-2.0.4 - - - minor bug fixes: - - replace String.map by Buffer.* to be compatible with OCaml < 4.0. - -ounit-2.0.3 - - - minor bug fixes: - - use Marshal.from_string to be compatible with OCaml <= 4.01. - - declare dependency on bytes in _oasis - -ounit-2.0.2 - - - minor bug fixes: - - replace String.uppercase_ascii. - -ounit-2.0.1 - - - minor bug fixes - - fix safe-string compatibility issuesi, thanks to Christoph Spiel - (Closes: #1760, #1761) - - fix some format string errors, thanks to Damien Doligez (Closes: #1422) - - fix backward incompatiblity with OUnit v1 (Closes: #1392) - -ounit-2.0.0 - - - major rewrite of all the code! - - implements a quickfix compatible way of outputing failures, it jumps to - the a position in the logfile to help you debug the problem. - - better configuration setup: environment variable, command line options, - configuration files (OUnitConf) - - improved output of the tests: output HTML report, output JUnit report, - systematic logging to a file (OUnitLogger*) - - choose how to run a test: in parallel using processes (auto-detect number - of CPU), concurrently using threads or sequentialy as before. - - choose which test to run: just run test in sequence (simple) or run the - tests that failed in the last run first and skip the success if they are - still failing (failfirst) (OUnitChooser) - - OUnitBracket: use a registration in the context to make it easier to use - - remove all useless functions in the OUnit2 interface - - non-fatal section: allow to fail inside non-fatal section without - quitting immediately the whole test - - refactor OUnit.ml to still provides the same function but using OUnit2. - - timer that makes tests fail if they take too long (runner = processes) - - allow to parametrize filenames so that you can use - OUNIT_OUTPUT_FILE=ounit-$(suite_name)-$(shard_id).log - and have $(suite_name) replace by the test suite name - - create locks to avoid accessing the same resources within a single process - or the whole application (OUnitShared) - - OUnitTestData locate test data, if any. - - enforce environment cleanness by checking it before and after the test - (e.g check that Sys.getcwd is the same). - -ounit-1.1.2 - - - regenerate with oasis v0.3.0~rc6 - -ounit-1.1.1 - - - bracket now enforce returning unit - - update examples - - ListSimpleMake now use the provided comparator for all elements - -ounit-1.1.0 - - - Add a ~pp_diff parameter to assert_equal and some classic diff operations - (Closes: #635, #642) - - Add an assert_command function (Closes: #641) - - Add a bracket_tmpfile to ease temporary file use - - Enhance documentation, translate the docbook manual into ocamldoc and - add content - - Allow to add extra command line arguments to run_test_tt_main - (Closes: #640) - - Add a -list-test options to run_test_tt_main, to list available tests - - Skip tests when using "-only-test", rather than removing it. This way - the path is the same even if some tests don't pass (Closes: #637) - - Add backtrace support (Closes: #639), thanks to Michael Ekstrand - - Use OASIS - - Move to OCaml Forge: http://ounit.forge.ocamlcore.org - - Maintainance is now done by Sylvain Le Gall (OCamlCore SARL), thanks to - Maas-Maarten Zeeman for all his work - -ounit-1.0.3 - - - Add the possibility to skip test and mark tests as todo - -ounit-1.0.2 - - - Refactored OUnit package. The test result and test event data structures - are now clearly separated. - -ounit-1.0.1 - - - Added optional compare function to assert_equal, and a float compare - function. Thanks go to Daniel Buenzli - -ounit-1.0.0 - - - Add bracket support (Thanks go to Laurent Vaucher) - - - Add an example for bracket usage - -ounit-0.1.0 - - - Makefile improvements - -ounit-0.0.3 - - - Added findlib support - -ounit-0.0.2 - - - Added assert_raises which checkes if an exception is raised. - (thanks go to Keita Yamaguchi, for the idea) - - - Fixed (hopefully) the .depend file - -ounit-0.0.1 - - - First release of ocaml-unit diff -Nru ounit-2.0.8/CHANGES.md ounit-2.2.3/CHANGES.md --- ounit-2.0.8/CHANGES.md 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/CHANGES.md 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,214 @@ +## v2.2.3 - 2020-07-11 + +### Changed +- Minimal OCaml version is now 4.04. + +### Fixed +- Make colored output and JUnit features more prominent in the documentation. + (Closes: #13, #12) +- Increase default timeouts, so that they work as well for slow architecture + like s390x. The fastest timeout is now 20s (immediate test) and the longest + is 1h (huge test). (Closes: #18) + +## v2.2.2 - 2020-01-24 + +### Fixed +- Don't follow symlink in bracket_tmpdir removal code (Closes: #11). + +## v2.2.1 - 2019-10-02 + +### Fixed +- Fix problem with OCaml 4.03 and ambiguous command (Closes: #10). + +## v2.2.0 - 2019-09-25 + +### Changed +- Rename ounit/ounit-lwt OPAM and library to ounit2/ounit2-lwt. The META file + to rename oUnit to ounit was not working on Windows and MacOSX because their + filesystems are case insensitive and the install directories were the same. + The new ounit2/ounit2-lwt packages avoid name clash on Windows/MacOSX and + we still have ounit/ounit-lwt to allow the transition to the new package + name. (Closes: #8) + +## v2.1.2 - 2019-09-23 + +### Fixed +- Fix assert_raises type, which has been inadvertently changed during the + migration to dune. +- Add unix dependency to ounit.advanced. + +## v2.1.1 - 2019-09-23 + +### Changed +- install a backward compatible META to help the transition from oUnit to ounit + library name. In order to depend on OUnit now, the name "ounit" should be + used (rather than the old "oUnit"). This change allows to be consistent with + the name of the opam package. + +## v2.1.0 - 2019-09-22 + +### Added +- New logger for CI, like Travis and AppVeyor, with colored output. It is + enabled by adding OUNIT_CI=true to environment section of .travis.yml or + appveyor.yml. +- ounit-lwt to build test with OUnit and Lwt. It also allows + to use the runner "processes" to run test in parallel. (Closes: OF#1765) + +### Changed +- assert_command only displays the difference with the initial environment. + This avoids to have hundreeds of lines of useless environment variables. +- Upgrade minimal OCaml version to 4.02, since dune requires at least this + version. + +### Fixed +- Run garbage collection in between tests to prevent unexpected bugs in GC (e.g + finaliser throwing exceptions). (Closes: OF#1766) + +## v2.0.8 + +- Handle infinity and NaN in cmp_float, thanks to Johannes Kloos + (Closes: OF#1381) + +## v2.0.7 + +- Prevent OUnitLoggerJUnit to fail when the hostname cannot be found, thanks + to Bailey Parker for the fix (Closes: OF#1744) + +## v2.0.6 + +- Fix internal uppercase_name. + +## v2.0.5 + +- Allow to recover from interrupted Unix.select call. This allows to + run more reliably the RunnerProcess with lwt. (Closes: OF#1363) + +## v2.0.4 + +- minor bug fixes: + - replace String.map by Buffer.* to be compatible with OCaml < 4.0. + +## v2.0.3 + +- minor bug fixes: + - use Marshal.from_string to be compatible with OCaml <= 4.01. + - declare dependency on bytes in _oasis + +## v2.0.2 + +- minor bug fixes: + - replace String.uppercase_ascii. + +## v2.0.1 + +- minor bug fixes +- fix safe-string compatibility issuesi, thanks to Christoph Spiel + (Closes: OF#1760, OF#1761) +- fix some format string errors, thanks to Damien Doligez (Closes: OF#1422) +- fix backward incompatiblity with OUnit v1 (Closes: OF#1392) + +## v2.0.0 + +- major rewrite of all the code! +- implements a quickfix compatible way of outputing failures, it jumps to + the a position in the logfile to help you debug the problem. +- better configuration setup: environment variable, command line options, + configuration files (OUnitConf) +- improved output of the tests: output HTML report, output JUnit report, + systematic logging to a file (OUnitLogger*) +- choose how to run a test: in parallel using processes (auto-detect number + of CPU), concurrently using threads or sequentialy as before. +- choose which test to run: just run test in sequence (simple) or run the + tests that failed in the last run first and skip the success if they are + still failing (failfirst) (OUnitChooser) +- OUnitBracket: use a registration in the context to make it easier to use +- remove all useless functions in the OUnit2 interface +- non-fatal section: allow to fail inside non-fatal section without + quitting immediately the whole test +- refactor OUnit.ml to still provides the same function but using OUnit2. +- timer that makes tests fail if they take too long (runner = processes) +- allow to parametrize filenames so that you can use + OUNIT_OUTPUT_FILE=ounit-$(suite_name)-$(shard_id).log + and have $(suite_name) replace by the test suite name +- create locks to avoid accessing the same resources within a single process + or the whole application (OUnitShared) +- OUnitTestData locate test data, if any. +- enforce environment cleanness by checking it before and after the test + (e.g check that Sys.getcwd is the same). + +## v1.1.2 + +- regenerate with oasis v0.3.0~rc6 + +## v1.1.1 + +- bracket now enforce returning unit +- update examples +- ListSimpleMake now use the provided comparator for all elements + +## v1.1.0 + +- Add a ~pp_diff parameter to assert_equal and some classic diff operations + (Closes: OF#635, OF#642) +- Add an assert_command function (Closes: OF#641) +- Add a bracket_tmpfile to ease temporary file use +- Enhance documentation, translate the docbook manual into ocamldoc and + add content +- Allow to add extra command line arguments to run_test_tt_main + (Closes: OF#640) +- Add a -list-test options to run_test_tt_main, to list available tests +- Skip tests when using "-only-test", rather than removing it. This way + the path is the same even if some tests don't pass (Closes: OF#637) +- Add backtrace support (Closes: OF#639), thanks to Michael Ekstrand +- Use OASIS +- Move to OCaml Forge: http://ounit.forge.ocamlcore.org +- Maintainance is now done by Sylvain Le Gall (OCamlCore SARL), thanks to + Maas-Maarten Zeeman for all his work + +## v1.0.3 + +- Add the possibility to skip test and mark tests as todo + +## v1.0.2 + +- Refactored OUnit package. The test result and test event data structures + are now clearly separated. + +## v1.0.1 + +- Added optional compare function to assert_equal, and a float compare + function. Thanks go to Daniel Buenzli + +## v1.0.0 + +- Add bracket support (Thanks go to Laurent Vaucher) +- Add an example for bracket usage + +## v0.1.0 + +- Makefile improvements + +## v0.0.3 + +- Added findlib support + +## v0.0.2 + +- Added assert_raises which checkes if an exception is raised. + (thanks go to Keita Yamaguchi, for the idea) +- Fixed (hopefully) the .depend file + +## v0.0.1 + +- First release of ocaml-unit + +## Changelog format +The format is loosely based on [Keep a Changelog], and this project adheres to +[Semantic Versioning]. + +[Keep a Changelog]: https://keepachangelog.com/en/1.0.0 +[Semantic Versioning]: https://semver.org/spec/v2.0.0.html + +## BTS references + +* OF#XX: OCaml Forge BTS (pre-2019) diff -Nru ounit-2.0.8/configure ounit-2.2.3/configure --- ounit-2.0.8/configure 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/configure 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -#!/bin/sh - -# OASIS_START -# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) -set -e - -FST=true -for i in "$@"; do - if $FST; then - set -- - FST=false - fi - - case $i in - --*=*) - ARG=${i%%=*} - VAL=${i##*=} - set -- "$@" "$ARG" "$VAL" - ;; - *) - set -- "$@" "$i" - ;; - esac -done - -ocaml setup.ml -configure "$@" -# OASIS_STOP diff -Nru ounit-2.0.8/debian/changelog ounit-2.2.3/debian/changelog --- ounit-2.0.8/debian/changelog 2020-02-21 07:33:51.000000000 +0000 +++ ounit-2.2.3/debian/changelog 2020-08-17 11:10:28.000000000 +0000 @@ -1,14 +1,20 @@ -ounit (2.0.8-2build2) focal; urgency=medium +ounit (2.2.3-2) unstable; urgency=medium - * No-change rebuild against ocaml-nox-4.08.1 + * Team upload + * Comment out AssertCodePosition test (fails on bytecode) - -- Steve Langasek Fri, 21 Feb 2020 07:33:51 +0000 + -- Stéphane Glondu Mon, 17 Aug 2020 13:10:28 +0200 -ounit (2.0.8-2build1) eoan; urgency=medium +ounit (2.2.3-1) unstable; urgency=medium - * Rebuild against new OCAML ABIs. + * Team upload + * New upstream release + * Remove Lifeng from Uploaders (Closes: #925074) + * Bump debhelper compat level to 13 + * Bump Standards-Version to 4.5.0 + * Add Rules-Requires-Root: no - -- Gianfranco Costamagna Tue, 03 Sep 2019 11:44:36 +0200 + -- Stéphane Glondu Mon, 17 Aug 2020 11:56:21 +0200 ounit (2.0.8-2) unstable; urgency=medium diff -Nru ounit-2.0.8/debian/compat ounit-2.2.3/debian/compat --- ounit-2.0.8/debian/compat 2019-08-03 10:08:48.000000000 +0000 +++ ounit-2.2.3/debian/compat 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -12 diff -Nru ounit-2.0.8/debian/control ounit-2.2.3/debian/control --- ounit-2.0.8/debian/control 2020-02-21 07:33:51.000000000 +0000 +++ ounit-2.2.3/debian/control 2020-08-17 11:10:28.000000000 +0000 @@ -1,19 +1,16 @@ Source: ounit Section: ocaml Priority: optional -Maintainer: Ubuntu Developers -XSBC-Original-Maintainer: Debian OCaml Maintainers -Uploaders: - Lifeng Sun +Maintainer: Debian OCaml Maintainers Build-Depends: - debhelper (>= 12), - ocaml-nox (>= 4.00.1), - ocaml-best-compilers, - ocaml-findlib (>= 1.3.2), - dh-ocaml (>= 0.9.1), - ocamlbuild, + debhelper-compat (= 13), + ocaml-nox (>= 4.04.0), + ocaml-findlib, + ocaml-dune, + dh-ocaml, libxml2-utils -Standards-Version: 4.4.0 +Standards-Version: 4.5.0 +Rules-Requires-Root: no Homepage: https://github.com/gildor478/ounit Vcs-Git: https://salsa.debian.org/ocaml-team/ounit.git Vcs-Browser: https://salsa.debian.org/ocaml-team/ounit diff -Nru ounit-2.0.8/debian/libounit-ocaml-dev.dirs.in ounit-2.2.3/debian/libounit-ocaml-dev.dirs.in --- ounit-2.0.8/debian/libounit-ocaml-dev.dirs.in 2019-08-03 10:06:06.000000000 +0000 +++ ounit-2.2.3/debian/libounit-ocaml-dev.dirs.in 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -@OCamlStdlibDir@ diff -Nru ounit-2.0.8/debian/libounit-ocaml-dev.doc-base ounit-2.2.3/debian/libounit-ocaml-dev.doc-base --- ounit-2.0.8/debian/libounit-ocaml-dev.doc-base 2019-08-03 10:06:06.000000000 +0000 +++ ounit-2.2.3/debian/libounit-ocaml-dev.doc-base 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -Document: libounit-ocaml-dev-ocamldoc-api-reference -Title: libounit-ocaml-dev OCamldoc API Reference -Abstract: API reference manual for libounit-ocaml-dev (generated via OCamldoc) -Section: Programming/OCaml - -Format: HTML -Index: /usr/share/doc/libounit-ocaml-dev/html/api/index.html -Files: /usr/share/doc/libounit-ocaml-dev/html/api/* diff -Nru ounit-2.0.8/debian/libounit-ocaml-dev.docs ounit-2.2.3/debian/libounit-ocaml-dev.docs --- ounit-2.0.8/debian/libounit-ocaml-dev.docs 2019-08-03 10:06:06.000000000 +0000 +++ ounit-2.2.3/debian/libounit-ocaml-dev.docs 2020-08-17 11:10:28.000000000 +0000 @@ -1 +1 @@ -README.txt +usr/doc/ounit2/* diff -Nru ounit-2.0.8/debian/libounit-ocaml-dev.install.in ounit-2.2.3/debian/libounit-ocaml-dev.install.in --- ounit-2.0.8/debian/libounit-ocaml-dev.install.in 2019-08-03 10:06:06.000000000 +0000 +++ ounit-2.2.3/debian/libounit-ocaml-dev.install.in 2020-08-17 11:10:28.000000000 +0000 @@ -1,13 +1,2 @@ -usr/share/doc/ounit/* /usr/share/doc/libounit-ocaml-dev/html/api -@OCamlStdlibDir@/oUnit/*.cma -@OCamlStdlibDir@/oUnit/*.cmi -@OCamlStdlibDir@/oUnit/META -@OCamlStdlibDir@/oUnit/*.mli -@OCamlStdlibDir@/oUnit/*.ml -@OCamlStdlibDir@/oUnit/*.annot -@OCamlStdlibDir@/oUnit/*.cmt -@OCamlStdlibDir@/oUnit/*.cmti -OPT: debian/tmp/usr/lib/ocaml/oUnit/*.a -DYN: debian/tmp/usr/lib/ocaml/oUnit/*.cmxs -OPT: debian/tmp/usr/lib/ocaml/oUnit/*.cmx -OPT: debian/tmp/usr/lib/ocaml/oUnit/*.cmxa +@OCamlStdlibDir@/ounit2 +@OCamlStdlibDir@/oUnit diff -Nru ounit-2.0.8/debian/patches/0001-Comment-out-AssertCodePosition-test-fails-on-bytecod.patch ounit-2.2.3/debian/patches/0001-Comment-out-AssertCodePosition-test-fails-on-bytecod.patch --- ounit-2.0.8/debian/patches/0001-Comment-out-AssertCodePosition-test-fails-on-bytecod.patch 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/debian/patches/0001-Comment-out-AssertCodePosition-test-fails-on-bytecod.patch 2020-08-17 11:10:28.000000000 +0000 @@ -0,0 +1,27 @@ +From: Stephane Glondu +Date: Mon, 17 Aug 2020 13:07:47 +0200 +Subject: Comment out AssertCodePosition test (fails on bytecode) + +Bug: https://github.com/gildor478/ounit/issues/21 +--- + test/testOtherTests.ml | 2 ++ + 1 file changed, 2 insertions(+) + +diff --git a/test/testOtherTests.ml b/test/testOtherTests.ml +index 1292d5a..248fdb9 100644 +--- a/test/testOtherTests.ml ++++ b/test/testOtherTests.ml +@@ -147,6 +147,7 @@ let tests = + ]); + + ++(* + "AssertCodePosition" >:: + (fun ctxt -> + skip_if (not (Printexc.backtrace_status ())) "No backtrace."; +@@ -172,4 +173,5 @@ let tests = + assert_equal ~printer:(fun s -> s) fn_exp fn1; + assert_equal ~printer:(fun s -> s) fn_exp fn2; + assert_equal ~printer:string_of_int 3 (lineno2 - lineno1)); ++*) + ] diff -Nru ounit-2.0.8/debian/patches/series ounit-2.2.3/debian/patches/series --- ounit-2.0.8/debian/patches/series 2019-08-03 10:06:06.000000000 +0000 +++ ounit-2.2.3/debian/patches/series 2020-08-17 11:10:28.000000000 +0000 @@ -0,0 +1 @@ +0001-Comment-out-AssertCodePosition-test-fails-on-bytecod.patch diff -Nru ounit-2.0.8/debian/rules ounit-2.2.3/debian/rules --- ounit-2.0.8/debian/rules 2019-08-03 10:16:35.000000000 +0000 +++ ounit-2.2.3/debian/rules 2020-08-17 11:10:28.000000000 +0000 @@ -23,6 +23,7 @@ DESTDIR=$(CURDIR)/debian/tmp +include /usr/share/dpkg/pkg-info.mk include /usr/share/ocaml/ocamlvars.mk OCAMLFIND_DESTDIR=$(DESTDIR)/$(OCAML_STDLIB_DIR) @@ -33,30 +34,14 @@ %: dh $@ --with ocaml -.PHONY: override_dh_auto_configure -override_dh_auto_configure: - ocaml setup.ml -configure --prefix /usr --destdir '$(DESTDIR)' - -.PHONY: override_dh_auto_build override_dh_auto_build: - ocaml setup.ml -build - ocaml setup.ml -doc + dune build -p ounit2 -.PHONY: override_dh_auto_test override_dh_auto_test: - ocaml setup.ml -test + dune runtest -p ounit2 -.PHONY: override_dh_auto_install override_dh_auto_install: - mkdir -p '$(OCAMLFIND_DESTDIR)' - ocaml setup.ml -install - -.PHONY: override_dh_missing -override_dh_missing: - dh_missing --fail-missing - -.PHONY: override_dh_auto_clean -override_dh_auto_clean: - ocaml setup.ml -distclean - -override_dh_dwz: + dune install --destdir=$(DESTDIR) --prefix=/usr --libdir=..$(OCAML_STDLIB_DIR) ounit2 + rm -f $(DESTDIR)/usr/doc/ounit2/LICENSE.txt + mkdir -p $(OCAMLFIND_DESTDIR) + $(MAKE) install-ounit version=$(DEB_VERSION_UPSTREAM) diff -Nru ounit-2.0.8/debian/watch ounit-2.2.3/debian/watch --- ounit-2.0.8/debian/watch 2019-08-03 10:06:06.000000000 +0000 +++ ounit-2.2.3/debian/watch 2020-08-17 11:10:28.000000000 +0000 @@ -1,3 +1,2 @@ version=3 -opts="filenamemangle=s/.*?\/(\d[\d.]*)\.tar\.gz/ounit-$1.tar.gz/" \ - https://github.com/gildor478/ounit/releases .*?/(\d[\d.]*)\.tar\.gz +https://github.com/gildor478/ounit/releases .*/archive/v?(\d[\d.]+)\.tar\.gz diff -Nru ounit-2.0.8/doc/manual.txt ounit-2.2.3/doc/manual.txt --- ounit-2.0.8/doc/manual.txt 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/doc/manual.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,268 +0,0 @@ -{!indexlist} - -{2 What is unit Testing?} - -A test-oriented methodology for software development is most -effective when tests are easy to create, change, and execute. The -JUnit tool pioneered test-first development in Java. OUnit is -an adaptation of JUnit to OCaml. - -With OUnit, as with JUnit, you can easily create tests, name them, -group them into suites, and execute them, with the framework -checking the results automatically. - -{2 Getting Started} - -The basic principle of a OUnit test suite is to have a {i test.ml} file which will -contain the tests, and an OCaml module under test, here named {i foo.ml}. - -File {i foo.ml}: -{[ -(* The functions we wish to test *) -let unity x = x;; -let funix ()= 0;; -let fgeneric () = failwith "Not implemented";; -]} - -The main point of a test is to check that the function under test has the -expected behavior. You check the behavior using assert functions. The simplest -one is {!OUnit2.assert_equal}. This function compares the result of the -function under test with an expected result. - -Some useful functions include: -- {!OUnit2.assert_equal} the basic assert function -- {!OUnit2.(>:::)} to define a list of tests -- {!OUnit2.(>::)} to name a test -- {!OUnit2.run_test_tt_main} to run the test suite you define -- {!OUnit2.bracket_tmpfile} that create a temporary filename. -- {!OUnit2.bracket_tmpdir} that create a temporary directory. - -File {i test.ml}: -{[ -open OUnit2;; - -let test1 test_ctxt = assert_equal "x" (Foo.unity "x");; - -let test2 test_ctxt = assert_equal 100 (Foo.unity 100);; - -(* Name the test cases and group them together *) -let suite = -"suite">::: - ["test1">:: test1; - "test2">:: test2] -;; - -let () = - run_test_tt_main suite -;; -]} - -And compile the module - -{[ -$ ocamlfind ocamlc -o test -package oUnit -linkpkg -g foo.ml test.ml -]} - -A executable named "test" will be created. When run it produces the -following output. - -{[ -$ ./test -.. -Ran: 2 tests in: 0.00 Seconds -OK -]} - -When using {!OUnit2.run_test_tt_main}, a non-zero exit code signals that the -test suite failed. - -{2 Advanced usage} - -This section is only for advanced users who wish to uncover the power of OUnit. - -{!modules: OUnit2} - -{3 Error reporting} - -The error reporting part of OUnit is quite important. If you want to identify -the failure, you should tune the display of the value and the test. - -Here is a list of things you can display: -- name of the test: OUnit uses numbers to define path's test. But an error - reporting about a failed test "0:1:2" is less explicit than - "OUnit:0:comparator:1:float_comparator:2" -- [~msg] parameter: it allows you to define, say, which assert has failed in your - test. When you have more than one assert in a test, you should provide a - [~msg] to differentiate them -- [~printer] parameter: {!OUnit2.assert_equal} allows you to define a printer for - compared values. A message ["abcd" is not equal to "defg"] is better than [not - equal] - -{[ -open OUnit2;; - -let _ = - "mytest">:: - (fun test_ctxt -> - assert_equal - ~msg:"int value" - ~printer:string_of_int - 1 - (Foo.unity 1)) -;; -]} - -{3 Command-line arguments} - -{!OUnit2.run_test_tt_main} already provides a set of command-line arguments to -help users run only the tests they want: -- [-only-test]: skip all the tests except this one, you can use this flag - several time to select more than one test to run -- [-list-test]: list all the available tests and exit -- [-help]: display help message and exit - -It is also possible to add your own command-line arguments, environment -variables and config file variables. You should do it if you want to define some -extra arguments. - -For example: - -{[ -open OUnit2;; - -let my_program = - Conf.make_exec "my_program" -;; - -let test1 test_ctxt = - assert_command (my_program test_ctxt) [] -;; - -let () = - run_test_tt_main ("test1" >:: test1) -;; -]} - -The [Conf.make_*] creates a command-line argument, an environment variable and -a config file variable. - -{3 Skip and todo tests} - -Tests are not always meaningful and can even fail because something is missing -in the environment. In order to handle this, you can define a skip condition -that will skip the test. - -If you start by defining your tests rather than implementing the functions -under test, you know that some tests will just fail. You can mark these tests -as pending todo tests. This way they will be reported differently in your test suite. - -{[ -open OUnit2;; - -let _ = - "allfuns" >::: - [ - "funix">:: - (fun test_ctxt -> - skip_if (Sys.os_type = "Win32") "Don't work on Windows"; - assert_equal - 0 - (Foo.funix ())); - - "fgeneric">:: - (fun test_ctxt -> - todo "fgeneric not implemented"; - assert_equal - 0 - (Foo.fgeneric ())); - ] -;; -]} - -{3 Effective OUnit} - -This section has general tips about unit testing and OUnit. It is the -result of some years using OUnit in real-world applications. - -- test everything: the more you create tests, the better chance you have to - catch errors in your program early. Every submitted bug to your application - should have a matching test. This is a good practice, but it is not always - easy to implement. -- test only what is really exported: on the long term, you have to maintain your - test suite. If you test low-level functions, you'll have a lot of tests to - rewrite. You should focus on creating tests for functions for which the - behavior shouldn't change. -- test fast: the best test suite is the one that runs after every single build. - You should set your default Makefile target to run the test suite. It means - that your test suite should be fast to run, typically, a 10s test suite is - fine. -- test long: contrary to the former tip, you should also have a complete test - suite which can be very long to run. The best way to achieve both tips, is to - define a command-line argument [-long] and skip the tests that are too long in - your test suite according to it. When you do a release, you should run - your long test suite. -- family tests: when testing behavior, most of the time you call exactly the - same code with different arguments. In this case [List.map] and - {!OUnit2.(>:::)} are your friends. For example: - -{[ -open OUnit2;; - -let _ = - "Family">::: - (List.map - (fun (arg,res) -> - let title = - Printf.sprintf "%s->%s" arg res - in - title >:: - (fun test_ctxt -> - assert_equal res (Foo.unity arg))) - ["abcd", "abcd"; - "defg", "defg"; - "wxyz", "wxyz"]) -;; -]} - -- test failures and successes: the most obvious thing you want to test are - successes, i.e. that you get the expected behavior in the normal case. But - most of the errors arise in corner cases and in the code of the test itself. - For example, you can have a partial application of your {!OUnit2.assert_equal} - and never encounter any errors, just because the [assert_equal] is not called. - In this case, if you test errors as well as the "happy path", you will have - a notice the missing errors as well. -- set up and clean your environment in the test: you should not set up and clean - your test environment outside the test. Ideally, if you run no tests, the - program should do nothing. This also ensures that you are always testing in a - clean environment, not polluted by the result of failed tests of an earlier - test run. This includes the process environment, like current working - directory. - -{[ -open OUnit2;; - -let _ = - (* We need to call a function in a particular directory *) - "change-dir-and-run">:: - (fun test_ctxt -> - assert_command ~chdir:"/foo/test" "ls" []) -;; -]} -- separate your tests: OUnit test code should live outside the code under a - directory called {i test}. This allow to drop the dependency on OUnit when - distributing your library/application. This also enables people to easily - make a difference from what really matters (the main code) and what are only - tests. It is also possible to have the tests directly in the code, like in - Quickcheck-style tests. - -The unit testing scope is always hard to define. Unit testing should be about -testing a single feature. But OUnit can also help you to test higher-level -behavior, by running a full program for example. While it isn't real unit -testing, you can use OUnit to do it and should not hesitate to do it. - -In terms of lines of codes, a test suite can represent from 10% to 150% of the -code under test. With time, your test suite will grow faster than your -program/library. A good ratio is 33%. - -@author Maas-Maarten Zeeman -@author Sylvain Le Gall diff -Nru ounit-2.0.8/doc-dist.sh ounit-2.2.3/doc-dist.sh --- ounit-2.0.8/doc-dist.sh 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/doc-dist.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -#!/bin/bash -############################################################################ -# The OUnit library # -# # -# Copyright (C) 2002-2008 Maas-Maarten Zeeman. # -# Copyright (C) 2010 OCamlCore SARL # -# Copyright (C) 2013 Sylvain Le Gall # -# # -# The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL # -# and Sylvain Le Gall. # -# # -# Permission is hereby granted, free of charge, to any person obtaining # -# a copy of this document and the OUnit software ("the Software"), to # -# deal in the Software without restriction, including without limitation # -# the rights 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 Maas-Maarten Zeeman be liable for any claim, damages # -# or other liability, whether in an action of contract, tort or # -# otherwise, arising from, out of or in connection with the Software or # -# the use or other dealings in the software. # -# # -# See LICENSE.txt for details. # -############################################################################ - -. admin-gallu-common || exit 1 - -set -e - -arg_string_set version --default "dev" \ - "Version of OUnit." - -arg_parse arg_anon_fail "$@" - -CURDIR=$(pwd) - -TOPDIR="ounit-doc-$version" -get_tmpdir TEMPDIR -mkdir -p "$TEMPDIR/$TOPDIR/api-ounit" -cp -R _build/src/api-ounit.docdir/* "$TEMPDIR/$TOPDIR/api-ounit" - -tar czf "$CURDIR/dist/$TOPDIR.tar.gz" -C $TEMPDIR $TOPDIR diff -Nru ounit-2.0.8/dune-project ounit-2.2.3/dune-project --- ounit-2.0.8/dune-project 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/dune-project 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,3 @@ +(lang dune 1.11) +(name ounit) +(explicit_js_mode) diff -Nru ounit-2.0.8/examples/dune ounit-2.2.3/examples/dune --- ounit-2.0.8/examples/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/examples/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,4 @@ +(tests + (names test_list test_stack) + (package ounit2) + (libraries ounit2)) diff -Nru ounit-2.0.8/examples/example.ml ounit-2.2.3/examples/example.ml --- ounit-2.0.8/examples/example.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/examples/example.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnit - -let empty_list = [] -let list_a = [1;2;3] - -let test_list_length _ = - assert_equal 1 (List.length empty_list); - assert_equal 3 (List.length list_a) - (* etc, etc *) - -let test_list_append _ = - let list_b = List.append empty_list [1;2;3] in - assert_equal list_b list_a - -let suite = "OUnit Example" >::: ["test_list_length" >:: test_list_length; - "test_list_append" >:: test_list_append] -let _ = - run_test_tt_main suite diff -Nru ounit-2.0.8/examples/Makefile ounit-2.2.3/examples/Makefile --- ounit-2.0.8/examples/Makefile 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/examples/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -############################################################################ -# The OUnit library # -# # -# Copyright (C) 2002-2008 Maas-Maarten Zeeman. # -# Copyright (C) 2010 OCamlCore SARL # -# Copyright (C) 2013 Sylvain Le Gall # -# # -# The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL # -# and Sylvain Le Gall. # -# # -# Permission is hereby granted, free of charge, to any person obtaining # -# a copy of this document and the OUnit software ("the Software"), to # -# deal in the Software without restriction, including without limitation # -# the rights 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 Maas-Maarten Zeeman be liable for any claim, damages # -# or other liability, whether in an action of contract, tort or # -# otherwise, arising from, out of or in connection with the Software or # -# the use or other dealings in the software. # -# # -# See LICENSE.txt for details. # -############################################################################ - -TESTS = test_list.ml test_list2.ml test_stack.ml - -test: test_suite example - -./test_suite - -./example - -test_suite: $(TESTS) test_suite.ml - ocamlfind ocamlc -o test_suite -package oUnit -linkpkg \ - test_list.ml test_list2.ml test_stack.ml test_suite.ml - -example: example.ml - ocamlfind ocamlc -o example -package oUnit -linkpkg \ - example.ml - -clean: - -$(RM) *.cmi *.cmo test_suite example diff -Nru ounit-2.0.8/examples/test_list2.ml ounit-2.2.3/examples/test_list2.ml --- ounit-2.0.8/examples/test_list2.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/examples/test_list2.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnit - -let empty_list = [] -let list_a = [1;2;3] - -let test_list_length _ = - assert_equal 1 (List.length empty_list); - assert_equal 3 (List.length list_a) - (* etc, etc *) - -let test_list_append _ = - let list_b = List.append empty_list [1;2;3] in - assert_equal list_b list_a - -let suite = "Test_list2" >::: ["test_list_length2" >:: test_list_length; - "test_list_append2" >:: test_list_append] - diff -Nru ounit-2.0.8/examples/test_list.ml ounit-2.2.3/examples/test_list.ml --- ounit-2.0.8/examples/test_list.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/examples/test_list.ml 2020-07-11 15:47:08.000000000 +0000 @@ -30,22 +30,26 @@ (* See LICENSE.txt for details. *) (**************************************************************************) -open OUnit +open OUnit2 let empty_list = [] let list_a = [1;2;3] let test_list_length _ = - assert_equal 1 (List.length empty_list); + (* Check if the list is empty. *) + assert_equal 0 (List.length empty_list); + (* Check if a given list contains 3 elements. *) assert_equal 3 (List.length list_a) - (* etc, etc *) let test_list_append _ = let list_b = List.append empty_list [1;2;3] in assert_equal list_b list_a -let suite = "OUnit Example" >::: ["test_list_length" >:: test_list_length; - "test_list_append" >:: test_list_append] +let suite = + "ExampleTestList" >::: [ + "test_list_length" >:: test_list_length; + "test_list_append" >:: test_list_append + ] let () = run_test_tt_main suite diff -Nru ounit-2.0.8/examples/test_stack.ml ounit-2.2.3/examples/test_stack.ml --- ounit-2.0.8/examples/test_stack.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/examples/test_stack.ml 2020-07-11 15:47:08.000000000 +0000 @@ -30,7 +30,7 @@ (* See LICENSE.txt for details. *) (**************************************************************************) -open OUnit +open OUnit2 (* * This test shows how brackets can be used. They are handy to create @@ -38,14 +38,14 @@ *) (* prepare a stack for test *) -let setup _ = +let setup _test_ctxt = let s = Stack.create () in Stack.push 1 s; Stack.push 2 s; Stack.push 3 s; s -let teardown _ = +let teardown _stack _test_ctxt = () let test_top stack = @@ -53,17 +53,37 @@ let test_clear stack = Stack.clear stack; - assert_raises Stack.Empty (fun _ -> Stack.top stack) + assert_raises + Stack.Empty + (fun _ -> + let _i = Stack.top stack in + ()) let test_pop stack = assert_equal 3 (Stack.pop stack); assert_equal 2 (Stack.pop stack); assert_equal 1 (Stack.pop stack); - assert_raises Stack.Empty (fun _ -> Stack.pop stack) - -let suite = "Test Stack" >::: - ["test_top" >:: (bracket setup test_top teardown); - "test_clear" >:: (bracket setup test_clear teardown); - "test_pop" >:: (bracket setup test_pop teardown)] - + assert_raises + Stack.Empty + (fun _ -> let _i : int = Stack.pop stack in ()) + +let suite = + "Test Stack" >::: [ + "test_top" >:: + (fun test_ctxt -> + let stack = bracket setup teardown test_ctxt in + test_top stack); + + "test_clear" >:: + (fun test_ctxt -> + let stack = bracket setup teardown test_ctxt in + test_clear stack); + + "test_pop" >:: + (fun test_ctxt -> + let stack = bracket setup teardown test_ctxt in + test_pop stack) + ] +let () = + run_test_tt_main suite diff -Nru ounit-2.0.8/examples/test_suite.ml ounit-2.2.3/examples/test_suite.ml --- ounit-2.0.8/examples/test_suite.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/examples/test_suite.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnit - -(* Collect the tests of different modules into one test suite *) -let suite = "OUnit Example" >::: - [Test_list.suite; - Test_list2.suite; - Test_stack.suite] - -let _ = - run_test_tt_main suite diff -Nru ounit-2.0.8/.gitignore ounit-2.2.3/.gitignore --- ounit-2.0.8/.gitignore 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/.gitignore 2020-07-11 15:47:08.000000000 +0000 @@ -1,11 +1,5 @@ -/_build/ -/setup.data -/setup.log +_build/ +*.merlin +*.install +*.swp /dist/ -/test.byte -/log-html/ -/junit.xml -/testFakeHTML.byte -/testFakeRunner.byte -/testFakeShared.byte -/api-ounit.docdir diff -Nru ounit-2.0.8/INSTALL.txt ounit-2.2.3/INSTALL.txt --- ounit-2.0.8/INSTALL.txt 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/INSTALL.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: 0d6708f8c4693a5f8c6110fc47730ecb) *) - -This is the INSTALL file for the ounit distribution. - -This package uses OASIS to generate its build system. See section OASIS for -full information. - -Dependencies -============ - -In order to compile this package, you will need: - -* ocaml (>= 3.11.0) for all, test main, doc api-ounit -* findlib -* bytes for library oUnitAdvanced -* xmllint for test main - -Installing -========== - -1. Uncompress the source archive and go to the root of the package -2. Run 'ocaml setup.ml -configure' -3. Run 'ocaml setup.ml -build' -4. Run 'ocaml setup.ml -install' - -Uninstalling -============ - -1. Go to the root of the package -2. Run 'ocaml setup.ml -uninstall' - -OASIS -===== - -OASIS is a program that generates a setup.ml file using a simple '_oasis' -configuration file. The generated setup only depends on the standard OCaml -installation: no additional library is required. - -(* OASIS_STOP *) diff -Nru ounit-2.0.8/Makefile ounit-2.2.3/Makefile --- ounit-2.0.8/Makefile 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/Makefile 2020-07-11 15:47:08.000000000 +0000 @@ -30,67 +30,50 @@ # See LICENSE.txt for details. # ############################################################################ -#TESTFLAGS=-only-test "OUnit:1" -#TESTFLAGS=-verbose true +version = dev default: test -# OASIS_START -# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) +build: + dune build @install -SETUP = ocaml setup.ml +doc: + dune build @doc -build: setup.data - $(SETUP) -build $(BUILDFLAGS) - -doc: setup.data build - $(SETUP) -doc $(DOCFLAGS) - -test: setup.data build - $(SETUP) -test $(TESTFLAGS) +test: + dune runtest all: - $(SETUP) -all $(ALLFLAGS) - -install: setup.data - $(SETUP) -install $(INSTALLFLAGS) + dune build @all + dune runtest -uninstall: setup.data - $(SETUP) -uninstall $(UNINSTALLFLAGS) +install: install-ounit install-ounit-lwt -reinstall: setup.data - $(SETUP) -reinstall $(REINSTALLFLAGS) +install-ounit: + -ocamlfind remove oUnit + ocamlfind install oUnit src/lib/oUnit/META -patch-version $(version) + +install-ounit-lwt: + -ocamlfind remove ounit-lwt + ocamlfind install ounit-lwt src/lib/ounit-lwt/META -patch-version $(version) + +uninstall: + dune uninstall + -ocamlfind remove oUnit + -ocamlfind remove ounit-lwt clean: - $(SETUP) -clean $(CLEANFLAGS) - -distclean: - $(SETUP) -distclean $(DISTCLEANFLAGS) - -setup.data: - $(SETUP) -configure $(CONFIGUREFLAGS) - -configure: - $(SETUP) -configure $(CONFIGUREFLAGS) + dune clean -.PHONY: build doc test all install uninstall reinstall clean distclean configure +null: + true -# OASIS_STOP - -doc-test: doc - ocamldoc -g ../ocaml-tmp/odoc-extract-code/odoc_extract_code.cmo \ - -load _build/src/oUnit.odoc -intro doc/manual.txt > _build/src/tmp.ml; - ocamlc -c -I _build/src/ _build/src/tmp.ml +.PHONY: build doc test all uninstall clean null +.PHONY: install install-ounit install-ounit-lwt PRECOMMIT_ARGS= \ --exclude log-html \ - --exclude myocamlbuild.ml \ - --exclude setup.ml \ - --exclude README.txt \ - --exclude INSTALL.txt \ - --exclude Makefile \ - --exclude configure \ - --exclude _tags + --exclude Makefile precommit: -@if command -v OCamlPrecommit > /dev/null; then \ @@ -103,26 +86,17 @@ .PHONY: precommit -doc-dev-dist: doc fix-perms - ./doc-dist.sh --version dev - -.PHONY: doc-dev-dist - -deploy: doc fix-perms - ./doc-dist.sh --version $(shell oasis query version) - admin-gallu-deploy --verbose \ - --forge_upload --forge_group ounit --forge_user gildor-admin \ - --forge_extra_file "dist/ounit-doc-$(shell oasis query version).tar.gz" - admin-gallu-oasis-increment \ - --setup_run --setup_args "-setup-update dynamic" --use_vcs +deploy: doc test + dune-release lint + git push --all + dune-release tag + dune-release distrib --skip-tests + dune-release publish + dune-release opam pkg + dune-release opam submit .PHONY: deploy -fix-perms: - chmod +x doc-dist.sh - -.PHONY: fix-perms - headache: find ./ \ -name _darcs -prune -false \ diff -Nru ounit-2.0.8/myocamlbuild.ml ounit-2.2.3/myocamlbuild.ml --- ounit-2.0.8/myocamlbuild.ml 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/myocamlbuild.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,935 +0,0 @@ - -open Ocamlbuild_plugin;; -open Command;; - -rule "src/oUnitLoggerHTMLData.ml" - ~prod:"src/oUnitLoggerHTMLData.ml" - ~deps:["src/oUnit.css"; "src/oUnit.js"] - begin - fun env build -> - let ounit_css = Printf.sprintf "%S" (read_file "src/oUnit.css") in - let ounit_js = Printf.sprintf "%S" (read_file "src/oUnit.js") in - Echo( - [ - "let oUnit_css = " ^ ounit_css ^ ";;"; - "let oUnit_js = " ^ ounit_js ^ ";;"; - ], - "src/oUnitLoggerHTMLData.ml") - end -;; - -(* OASIS_START *) -(* DO NOT EDIT (digest: c5113dfd5a91f679685a7b9102d70619) *) -module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) - - - let ns_ str = str - let s_ str = str - let f_ (str: ('a, 'b, 'c, 'd) format4) = str - - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - - let init = [] -end - -module OASISString = struct -(* # 22 "src/oasis/OASISString.ml" *) - - - (** Various string utilities. - - Mostly inspired by extlib and batteries ExtString and BatString libraries. - - @author Sylvain Le Gall - *) - - - let nsplitf str f = - if str = "" then - [] - else - let buf = Buffer.create 13 in - let lst = ref [] in - let push () = - lst := Buffer.contents buf :: !lst; - Buffer.clear buf - in - let str_len = String.length str in - for i = 0 to str_len - 1 do - if f str.[i] then - push () - else - Buffer.add_char buf str.[i] - done; - push (); - List.rev !lst - - - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the - separator. - *) - let nsplit str c = - nsplitf str ((=) c) - - - let find ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx - - - let sub_start str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str len (str_len - len) - - - let sub_end ?(offset=0) str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str 0 (str_len - len) - - - let starts_with ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - let ok = ref true in - while !ok && - !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - ok := false; - incr str_idx - done; - !what_idx = String.length what - - - let strip_starts_with ~what str = - if starts_with ~what str then - sub_start str (String.length what) - else - raise Not_found - - - let ends_with ~what ?(offset=0) str = - let what_idx = ref ((String.length what) - 1) in - let str_idx = ref ((String.length str) - 1) in - let ok = ref true in - while !ok && - offset <= !str_idx && - 0 <= !what_idx do - if str.[!str_idx] = what.[!what_idx] then - decr what_idx - else - ok := false; - decr str_idx - done; - !what_idx = -1 - - - let strip_ends_with ~what str = - if ends_with ~what str then - sub_end str (String.length what) - else - raise Not_found - - - let replace_chars f s = - let buf = Buffer.create (String.length s) in - String.iter (fun c -> Buffer.add_char buf (f c)) s; - Buffer.contents buf - - let lowercase_ascii = - replace_chars - (fun c -> - if (c >= 'A' && c <= 'Z') then - Char.chr (Char.code c + 32) - else - c) - - let uncapitalize_ascii s = - if s <> "" then - (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - - let uppercase_ascii = - replace_chars - (fun c -> - if (c >= 'a' && c <= 'z') then - Char.chr (Char.code c - 32) - else - c) - - let capitalize_ascii s = - if s <> "" then - (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - -end - -module OASISUtils = struct -(* # 22 "src/oasis/OASISUtils.ml" *) - - - open OASISGettext - - - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end - - - module MapString = MapExt.Make(String) - - - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list = elements - end - end - - - module SetString = SetExt.Make(String) - - - let compare_csl s1 s2 = - String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) - - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - let equal s1 s2 = (compare_csl s1 s2) = 0 - let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) - end) - - module SetStringCsl = - SetExt.Make - (struct - type t = string - let compare = compare_csl - end) - - - let varname_of_string ?(hyphen='_') s = - if String.length s = 0 then - begin - invalid_arg "varname_of_string" - end - else - begin - let buf = - OASISString.replace_chars - (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || - ('0' <= c && c <= '9') then - c - else - hyphen) - s; - in - let buf = - (* Start with a _ if digit *) - if '0' <= s.[0] && s.[0] <= '9' then - "_"^buf - else - buf - in - OASISString.lowercase_ascii buf - end - - - let varname_concat ?(hyphen='_') p s = - let what = String.make 1 hyphen in - let p = - try - OASISString.strip_ends_with ~what p - with Not_found -> - p - in - let s = - try - OASISString.strip_starts_with ~what s - with Not_found -> - s - in - p^what^s - - - let is_varname str = - str = varname_of_string str - - - let failwithf fmt = Printf.ksprintf failwith fmt - - - let rec file_location ?pos1 ?pos2 ?lexbuf () = - match pos1, pos2, lexbuf with - | Some p, None, _ | None, Some p, _ -> - file_location ~pos1:p ~pos2:p ?lexbuf () - | Some p1, Some p2, _ -> - let open Lexing in - let fn, lineno = p1.pos_fname, p1.pos_lnum in - let c1 = p1.pos_cnum - p1.pos_bol in - let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in - Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 - | _, _, Some lexbuf -> - file_location - ~pos1:(Lexing.lexeme_start_p lexbuf) - ~pos2:(Lexing.lexeme_end_p lexbuf) - () - | None, None, None -> - s_ "" - - - let failwithpf ?pos1 ?pos2 ?lexbuf fmt = - let loc = file_location ?pos1 ?pos2 ?lexbuf () in - Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt - - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - open OASISGettext - open OASISUtils - - - type test = string - type flag = string - - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - type 'a choices = (t * 'a) list - - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - - -end - - -# 437 "myocamlbuild.ml" -module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - - - module MapString = Map.Make(String) - - - type t = string MapString.t - - - let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" - - - let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = - let line = ref 1 in - let lexer st = - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - Genlex.make_lexer ["="] st_line - in - let rec read_file lxr mp = - match Stream.npeek 3 lxr with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; - read_file lxr (MapString.add nm value mp) - | [] -> mp - | _ -> - failwith - (Printf.sprintf "Malformed data file '%s' line %d" filename !line) - in - match stream with - | Some st -> read_file (lexer st) MapString.empty - | None -> - if Sys.file_exists filename then begin - let chn = open_in_bin filename in - let st = Stream.of_channel chn in - try - let mp = read_file (lexer st) MapString.empty in - close_in chn; mp - with e -> - close_in chn; raise e - end else if allow_empty then begin - MapString.empty - end else begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - let rec var_expand str env = - let buff = Buffer.create ((String.length str) * 2) in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = var_expand (MapString.find name env) env - let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst -end - - -# 517 "myocamlbuild.ml" -module MyOCamlbuildFindlib = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) - - - (** OCamlbuild extension, copied from - * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html - * by N. Pouillard and others - * - * Updated on 2016-06-02 - * - * Modified by Sylvain Le Gall - *) - open Ocamlbuild_plugin - - - type conf = {no_automatic_syntax: bool} - - - let run_and_read = Ocamlbuild_pack.My_unix.run_and_read - - - let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings - - - let exec_from_conf exec = - let exec = - let env = BaseEnvLight.load ~allow_empty:true () in - try - BaseEnvLight.var_get exec env - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" exec; - exec - in - let fix_win32 str = - if Sys.os_type = "Win32" then begin - let buff = Buffer.create (String.length str) in - (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. - *) - String.iter - (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) - str; - Buffer.contents buff - end else begin - str - end - in - fix_win32 exec - - - let split s ch = - let buf = Buffer.create 13 in - let x = ref [] in - let flush () = - x := (Buffer.contents buf) :: !x; - Buffer.clear buf - in - String.iter - (fun c -> - if c = ch then - flush () - else - Buffer.add_char buf c) - s; - flush (); - List.rev !x - - - let split_nl s = split s '\n' - - - let before_space s = - try - String.before s (String.index s ' ') - with Not_found -> s - - (* ocamlfind command *) - let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] - - (* This lists all supported packages. *) - let find_packages () = - List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) - - - (* Mock to list available syntaxes. *) - let find_syntaxes () = ["camlp4o"; "camlp4r"] - - - let well_known_syntax = [ - "camlp4.quotations.o"; - "camlp4.quotations.r"; - "camlp4.exceptiontracer"; - "camlp4.extend"; - "camlp4.foldgenerator"; - "camlp4.listcomprehension"; - "camlp4.locationstripper"; - "camlp4.macro"; - "camlp4.mapgenerator"; - "camlp4.metagenerator"; - "camlp4.profiler"; - "camlp4.tracer" - ] - - - let dispatch conf = - function - | After_options -> - (* By using Before_options one let command line options have an higher - * priority on the contrary using After_options will guarantee to have - * the higher priority override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop"; - Options.ocamlmklib := ocamlfind & A"ocamlmklib" - - | After_rules -> - - (* Avoid warnings for unused tag *) - flag ["tests"] N; - - (* When one link an OCaml library/binary/package, one should use - * -linkpkg *) - flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - let base_args = [A"-package"; A pkg] in - (* TODO: consider how to really choose camlp4o or camlp4r. *) - let syn_args = [A"-syntax"; A "camlp4o"] in - let (args, pargs) = - (* Heuristic to identify syntax extensions: whether they end in - ".syntax"; some might not. - *) - if not (conf.no_automatic_syntax) && - (Filename.check_suffix pkg "syntax" || - List.mem pkg well_known_syntax) then - (syn_args @ base_args, syn_args) - else - (base_args, []) - in - flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; - flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; - - (* TODO: Check if this is allowed for OCaml < 3.12.1 *) - flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; - end - (find_packages ()); - - (* Like -package but for extensions syntax. Morover -syntax is useless - * when linking. *) - List.iter begin fun syntax -> - flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & - S[A"-syntax"; A syntax]; - end (find_syntaxes ()); - - (* The default "thread" tag is not compatible with ocamlfind. - * Indeed, the default rules add the "threads.cma" or "threads.cmxa" - * options when using this tag. When using the "-linkpkg" option with - * ocamlfind, this module will then be added twice on the command line. - * - * To solve this, one approach is to add the "-thread" option when using - * the "threads" package using the previous plugin. - *) - flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); - flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); - flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]); - - | _ -> - () -end - -module MyOCamlbuildBase = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - - (** Base functions for writing myocamlbuild.ml - @author Sylvain Le Gall - *) - - - open Ocamlbuild_plugin - module OC = Ocamlbuild_pack.Ocaml_compiler - - - type dir = string - type file = string - type name = string - type tag = string - - - type t = - { - lib_ocaml: (name * dir list * string list) list; - lib_c: (name * dir * file list) list; - flags: (tag list * (spec OASISExpr.choices)) list; - (* Replace the 'dir: include' from _tags by a precise interdepends in - * directory. - *) - includes: (dir * dir list) list; - } - - -(* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - - let env_filename = Pathname.basename BaseEnvLight.default_filename - - - let dispatch_combine lst = - fun e -> - List.iter - (fun dispatch -> dispatch e) - lst - - - let tag_libstubs nm = - "use_lib"^nm^"_stubs" - - - let nm_libstubs nm = - nm^"_stubs" - - - let dispatch t e = - let env = BaseEnvLight.load ~allow_empty:true () in - match e with - | Before_options -> - let no_trailing_dot s = - if String.length s >= 1 && s.[0] = '.' then - String.sub s 1 ((String.length s) - 1) - else - s - in - List.iter - (fun (opt, var) -> - try - opt := no_trailing_dot (BaseEnvLight.var_get var env) - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" var) - [ - Options.ext_obj, "ext_obj"; - Options.ext_lib, "ext_lib"; - Options.ext_dll, "ext_dll"; - ] - - | After_rules -> - (* Declare OCaml libraries *) - List.iter - (function - | nm, [], intf_modules -> - ocaml_lib nm; - let cmis = - List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis - | nm, dir :: tl, intf_modules -> - ocaml_lib ~dir:dir (dir^"/"^nm); - List.iter - (fun dir -> - List.iter - (fun str -> - flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) - ["compile"; "infer_interface"; "doc"]) - tl; - let cmis = - List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] - cmis) - t.lib_ocaml; - - (* Declare directories dependencies, replace "include" in _tags. *) - List.iter - (fun (dir, include_dirs) -> - Pathname.define_context dir include_dirs) - t.includes; - - (* Declare C libraries *) - List.iter - (fun (lib, dir, headers) -> - (* Handle C part of library *) - flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; - A("-l"^(nm_libstubs lib))]); - - flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] - (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - - if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then - flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); - - (* When ocaml link something that use the C library, then one - need that file to be up to date. - This holds both for programs and for libraries. - *) - dep ["link"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - dep ["compile"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - (* TODO: be more specific about what depends on headers *) - (* Depends on .h files *) - dep ["compile"; "c"] - headers; - - (* Setup search path for lib *) - flag ["link"; "ocaml"; "use_"^lib] - (S[A"-I"; P(dir)]); - ) - t.lib_c; - - (* Add flags *) - List.iter - (fun (tags, cond_specs) -> - let spec = BaseEnvLight.var_choose cond_specs env in - let rec eval_specs = - function - | S lst -> S (List.map eval_specs lst) - | A str -> A (BaseEnvLight.var_expand str env) - | spec -> spec - in - flag tags & (eval_specs spec)) - t.flags - | _ -> - () - - - let dispatch_default conf t = - dispatch_combine - [ - dispatch t; - MyOCamlbuildFindlib.dispatch conf; - ] - - -end - - -# 878 "myocamlbuild.ml" -open Ocamlbuild_plugin;; -let package_default = - { - MyOCamlbuildBase.lib_ocaml = - [ - ("oUnitAdvanced", ["src"], []); - ("oUnit", ["src"], []); - ("oUnitThreads", ["src"], []) - ]; - lib_c = []; - flags = []; - includes = [("test", ["src"])] - } - ;; - -let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} - -let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; - -# 899 "myocamlbuild.ml" -(* OASIS_STOP *) - -Ocamlbuild_plugin.dispatch - (function - | After_rules as e -> - dep ["doc"; "docdir"; "extension:html"; - "ocaml"; "oasis_document_api_ounit"] & - ["doc/manual.txt"]; - flag ["doc"; "docdir"; "extension:html"; - "ocaml"; "oasis_document_api_ounit"] & - (S[A"-t"; A"OUnit user guide"; - A"-intro"; P"doc/manual.txt"; - A"-colorize-code"]); - dispatch_default e - | e -> - dispatch_default e) -;; diff -Nru ounit-2.0.8/_oasis ounit-2.2.3/_oasis --- ounit-2.0.8/_oasis 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/_oasis 1970-01-01 00:00:00.000000000 +0000 @@ -1,115 +0,0 @@ -OASISFormat: 0.3 -OCamlVersion: >= 3.11.0 -Name: ounit -Version: 2.0.8 -Synopsis: Unit testing framework -Authors: Maas-Maarten Zeeman, - Sylvain Le Gall -Copyrights: (C) 2002-2008 Maas-Maarten Zeeman, - (C) 2010 OCamlCore SARL -License: MIT -LicenseFile: LICENSE.txt -Homepage: http://ounit.forge.ocamlcore.org -Plugins: META (0.2), StdFiles (0.2), DevFiles (0.2) -BuildTools: ocamlbuild - -Description: - OUnit is a unit testing framework for OCaml, inspired by the JUnit tool for - Java, and the HUnit tool for Haskell. - . - More information on [HUnit](http://hunit.sourceforge.net) - -Library "oUnit" - Path: src - Modules: OUnit, - OUnit2 - BuildDepends: unix, oUnit.advanced - -Library "oUnitAdvanced" - Path: src - Modules: OUnitUtils, - OUnitPropList, - OUnitPlugin, - OUnitChooser, - OUnitResultSummary, - OUnitLoggerStd, - OUnitLoggerHTML, - OUnitLoggerHTMLData, - OUnitLoggerJUnit, - OUnitAssert, - OUnitBracket, - OUnitTest, - OUnitState, - OUnitRunner, - OUnitRunnerProcesses, - OUnitCore, - OUnitLogger, - OUnitConf, - OUnitShared, - OUnitCache, - OUnitTestData, - OUnitCheckEnv, - OUnitDiff - FindlibParent: oUnit - BuildDepends: bytes - FindlibName: advanced - -Library "oUnitThreads" - Path: src - Modules: OUnitThreads - InternalModules: OUnitRunnerThreads - BuildDepends: threads, oUnit - FindlibParent: oUnit - FindlibName: threads - -# A fake test executable that generates an HTML output. -Executable testFakeHTML - Path: test - MainIs: testFakeHTML.ml - BuildDepends: oUnit - Install: false - Build$: flag(tests) - -# A fake test executable that helps to test all the runners. -Executable testFakeRunner - Path: test - MainIs: testFakeRunner.ml - BuildDepends: oUnit, oUnit.threads - Install: false - Build$: flag(tests) - -# A fake test executable that helps to test shared module with all runners. -Executable testFakeShared - Path: test - MainIs: testFakeShared.ml - BuildDepends: oUnit, oUnit.threads - Install: false - Build$: flag(tests) - -# The main test. -Executable test - Path: test - MainIs: test.ml - BuildDepends: oUnit, oUnit.advanced, str - Install: false - Build$: flag(tests) - -Test main - Command: $test -xmllint $xmllint \ - -testFakeHTML $testfakehtml \ - -testFakeRunner $testfakerunner \ - -testFakeShared $testfakeshared - TestTools: test, testFakeHTML, testFakeRunner, xmllint - -Document "api-ounit" - Title: API reference for OUnit - Type: ocamlbuild (0.2) - BuildTools+: ocamldoc - XOCamlbuildLibraries: oUnit, oUnit.threads, oUnit.advanced - XOCamlbuildPath: src/ - -SourceRepository head - Type: git - Location: https://github.com/gildor478/ounit.git - Branch: master - Browser: https://github.com/gildor478/ounit diff -Nru ounit-2.0.8/ounit2-lwt.opam ounit-2.2.3/ounit2-lwt.opam --- ounit-2.0.8/ounit2-lwt.opam 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/ounit2-lwt.opam 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,22 @@ +opam-version: "2.0" +maintainer: "Sylvain Le Gall " +authors: [ "Sylvain Le Gall" ] +homepage: "https://github.com/gildor478/ounit" +dev-repo: "git+https://github.com/gildor478/ounit.git" +bug-reports: "https://github.com/gildor478/ounit/issues" +doc: "https://gildor478.github.io/ounit/" +depends: [ + "ocaml" {>= "4.04.0"} + "dune" {>= "1.11.0"} + "lwt" + "ounit2" {= version} +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} + ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} +] +synopsis: "OUnit testing framework (Lwt)" +description:""" +This library contains helper functions for building Lwt tests using OUnit. +""" diff -Nru ounit-2.0.8/ounit2.opam ounit-2.2.3/ounit2.opam --- ounit-2.0.8/ounit2.opam 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/ounit2.opam 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,26 @@ +opam-version: "2.0" +maintainer: "Sylvain Le Gall " +authors: [ "Maas-Maarten Zeeman" "Sylvain Le Gall" ] +homepage: "https://github.com/gildor478/ounit" +dev-repo: "git+https://github.com/gildor478/ounit.git" +bug-reports: "https://github.com/gildor478/ounit/issues" +doc: "https://gildor478.github.io/ounit/" +depends: [ + "ocaml" {>= "4.04.0"} + "dune" {>= "1.11.0"} + "base-bytes" + "base-unix" + "stdlib-shims" +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} + ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} +] +synopsis: "OUnit testing framework" +description: """ +OUnit is a unit test framework for OCaml. It allows one to easily create +unit-tests for OCaml code. It is loosely based on [HUnit], a unit testing +framework for Haskell. It is similar to [JUnit], and other XUnit testing +frameworks. +""" diff -Nru ounit-2.0.8/ounit-lwt.opam ounit-2.2.3/ounit-lwt.opam --- ounit-2.0.8/ounit-lwt.opam 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/ounit-lwt.opam 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,19 @@ +opam-version: "2.0" +maintainer: "Sylvain Le Gall " +authors: [ "Sylvain Le Gall" ] +homepage: "https://github.com/gildor478/ounit" +dev-repo: "git+https://github.com/gildor478/ounit.git" +bug-reports: "https://github.com/gildor478/ounit/issues" +doc: "https://gildor478.github.io/ounit/" +depends: [ + "ocamlfind" {build} + "ounit2-lwt" {= version} +] +install: [ + [make "install-ounit-lwt" "version=%{version}%"] +] +synopsis: "This is a transition package, ounit-lwt is now ounit2-lwt" +description:""" +More details for the transition: +https://github.com/gildor478/ounit#transition-to-ounit2 +""" diff -Nru ounit-2.0.8/ounit.opam ounit-2.2.3/ounit.opam --- ounit-2.0.8/ounit.opam 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/ounit.opam 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,19 @@ +opam-version: "2.0" +maintainer: "Sylvain Le Gall " +authors: [ "Maas-Maarten Zeeman" "Sylvain Le Gall" ] +homepage: "https://github.com/gildor478/ounit" +dev-repo: "git+https://github.com/gildor478/ounit.git" +bug-reports: "https://github.com/gildor478/ounit/issues" +doc: "https://gildor478.github.io/ounit/" +depends: [ + "ocamlfind" {build} + "ounit2" {= version} +] +install: [ + [make "install-ounit" "version=%{version}%"] +] +synopsis: "This is a transition package, ounit is now ounit2" +description:""" +More details for the transition: +https://github.com/gildor478/ounit#transition-to-ounit2 +""" diff -Nru ounit-2.0.8/README.md ounit-2.2.3/README.md --- ounit-2.0.8/README.md 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/README.md 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,63 @@ +OUnit - xUnit testing framework for OCaml +========================================================================= + +[![Travis status][travis-img]][travis] +[![AppVeyor status][appveyor-img]][appveyor] + +OUnit is a unit test framework for OCaml. It allows one to easily create +unit-tests for OCaml code. It is loosely based on [HUnit], a unit testing +framework for Haskell. It is similar to [JUnit], and other XUnit testing +frameworks. + +Features: +- colored output +- JUnit report generation +- HTML report generation + +[HUnit]: http://hunit.sourceforge.net/ +[JUnit]: http://junit.org/ +[travis]: https://travis-ci.org/gildor478/ounit +[travis-img]: https://travis-ci.org/gildor478/ounit.svg?branch=master +[appveyor]: https://ci.appveyor.com/project/gildor478/ounit +[appveyor-img]: https://ci.appveyor.com/api/projects/status/g86mhhc0dda25llx/branch/master?svg=true +[opam]: https://opam.ocaml.org + +Installation +------------ + +The recommended way to install ounit is via the [opam package manager][opam]: + +```sh +$ opam install ounit2 +``` + +Documentation +------------- + +API documentation is +[available online](https://gildor478.github.io/ounit). + +Examples +-------- + +* From the examples/ directory of ounit: + * [test_list.ml](examples/test_list.ml) + * [test_stack.ml](examples/test_stack.ml) +* External projects: + * [OASIS tests](https://github.com/ocaml/oasis/tree/master/test) + +Transition to ounit2 +-------------------- + +In the past OUnit used the ocamlfind package name "oUnit". It is uncommon to +use uppercase letters in ocamlfind package name. It caused some problems during +the transition to "dune". It was also not the same name as the OPAM package. As +of version 2.2, the opam package ounit and the ocamlfind package oUnit are +renamed to ounit2 (the same for both the ocamlfind and opam packages). + +To do the transition for your own tests: +* in OPAM, the library should now depends on "ounit2" or "ounit2-lwt" +* in dune files/OASIS/Makefile/pkg.ml replace "oUnit" by "ounit2" and + "ounit-lwt" to "ounit2-lwt". + +We will keep OPAM packages "ounit"/"ounit-lwt" for the transition. diff -Nru ounit-2.0.8/README.txt ounit-2.2.3/README.txt --- ounit-2.0.8/README.txt 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/README.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: 7972011e467ce4298adee5afbb353623) *) - -ounit - Unit testing framework -============================== - -OUnit is a unit testing framework for OCaml, inspired by the JUnit tool for -Java, and the HUnit tool for Haskell. - -More information on [HUnit](http://hunit.sourceforge.net) - -See the file [INSTALL.txt](INSTALL.txt) for building and installation -instructions. - -[Home page](http://ounit.forge.ocamlcore.org) - -Copyright and license ---------------------- - -(C) 2002-2008 Maas-Maarten Zeeman -(C) 2010 OCamlCore SARL - -ounit is distributed under the terms of the MIT License. - -See [LICENSE.txt](LICENSE.txt) for more information. - -(* OASIS_STOP *) diff -Nru ounit-2.0.8/setup.ml ounit-2.2.3/setup.ml --- ounit-2.0.8/setup.ml 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/setup.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,8297 +0,0 @@ -(* setup.ml generated for the first time by OASIS v0.2.0~alpha1 *) - -(* OASIS_START *) -(* DO NOT EDIT (digest: c6da7bb33df941a852b7e7876ae6b3a8) *) -(* - Regenerated by OASIS v0.4.11~HEAD - Visit http://oasis.forge.ocamlcore.org for more information and - documentation about functions used in this file. -*) -module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) - - - let ns_ str = str - let s_ str = str - let f_ (str: ('a, 'b, 'c, 'd) format4) = str - - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - - let init = [] -end - -module OASISString = struct -(* # 22 "src/oasis/OASISString.ml" *) - - - (** Various string utilities. - - Mostly inspired by extlib and batteries ExtString and BatString libraries. - - @author Sylvain Le Gall - *) - - - let nsplitf str f = - if str = "" then - [] - else - let buf = Buffer.create 13 in - let lst = ref [] in - let push () = - lst := Buffer.contents buf :: !lst; - Buffer.clear buf - in - let str_len = String.length str in - for i = 0 to str_len - 1 do - if f str.[i] then - push () - else - Buffer.add_char buf str.[i] - done; - push (); - List.rev !lst - - - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the - separator. - *) - let nsplit str c = - nsplitf str ((=) c) - - - let find ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx - - - let sub_start str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str len (str_len - len) - - - let sub_end ?(offset=0) str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str 0 (str_len - len) - - - let starts_with ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - let ok = ref true in - while !ok && - !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - ok := false; - incr str_idx - done; - !what_idx = String.length what - - - let strip_starts_with ~what str = - if starts_with ~what str then - sub_start str (String.length what) - else - raise Not_found - - - let ends_with ~what ?(offset=0) str = - let what_idx = ref ((String.length what) - 1) in - let str_idx = ref ((String.length str) - 1) in - let ok = ref true in - while !ok && - offset <= !str_idx && - 0 <= !what_idx do - if str.[!str_idx] = what.[!what_idx] then - decr what_idx - else - ok := false; - decr str_idx - done; - !what_idx = -1 - - - let strip_ends_with ~what str = - if ends_with ~what str then - sub_end str (String.length what) - else - raise Not_found - - - let replace_chars f s = - let buf = Buffer.create (String.length s) in - String.iter (fun c -> Buffer.add_char buf (f c)) s; - Buffer.contents buf - - let lowercase_ascii = - replace_chars - (fun c -> - if (c >= 'A' && c <= 'Z') then - Char.chr (Char.code c + 32) - else - c) - - let uncapitalize_ascii s = - if s <> "" then - (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - - let uppercase_ascii = - replace_chars - (fun c -> - if (c >= 'a' && c <= 'z') then - Char.chr (Char.code c - 32) - else - c) - - let capitalize_ascii s = - if s <> "" then - (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - -end - -module OASISUtils = struct -(* # 22 "src/oasis/OASISUtils.ml" *) - - - open OASISGettext - - - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end - - - module MapString = MapExt.Make(String) - - - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list = elements - end - end - - - module SetString = SetExt.Make(String) - - - let compare_csl s1 s2 = - String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) - - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - let equal s1 s2 = (compare_csl s1 s2) = 0 - let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) - end) - - module SetStringCsl = - SetExt.Make - (struct - type t = string - let compare = compare_csl - end) - - - let varname_of_string ?(hyphen='_') s = - if String.length s = 0 then - begin - invalid_arg "varname_of_string" - end - else - begin - let buf = - OASISString.replace_chars - (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || - ('0' <= c && c <= '9') then - c - else - hyphen) - s; - in - let buf = - (* Start with a _ if digit *) - if '0' <= s.[0] && s.[0] <= '9' then - "_"^buf - else - buf - in - OASISString.lowercase_ascii buf - end - - - let varname_concat ?(hyphen='_') p s = - let what = String.make 1 hyphen in - let p = - try - OASISString.strip_ends_with ~what p - with Not_found -> - p - in - let s = - try - OASISString.strip_starts_with ~what s - with Not_found -> - s - in - p^what^s - - - let is_varname str = - str = varname_of_string str - - - let failwithf fmt = Printf.ksprintf failwith fmt - - - let rec file_location ?pos1 ?pos2 ?lexbuf () = - match pos1, pos2, lexbuf with - | Some p, None, _ | None, Some p, _ -> - file_location ~pos1:p ~pos2:p ?lexbuf () - | Some p1, Some p2, _ -> - let open Lexing in - let fn, lineno = p1.pos_fname, p1.pos_lnum in - let c1 = p1.pos_cnum - p1.pos_bol in - let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in - Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 - | _, _, Some lexbuf -> - file_location - ~pos1:(Lexing.lexeme_start_p lexbuf) - ~pos2:(Lexing.lexeme_end_p lexbuf) - () - | None, None, None -> - s_ "" - - - let failwithpf ?pos1 ?pos2 ?lexbuf fmt = - let loc = file_location ?pos1 ?pos2 ?lexbuf () in - Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt - - -end - -module OASISUnixPath = struct -(* # 22 "src/oasis/OASISUnixPath.ml" *) - - - type unix_filename = string - type unix_dirname = string - - - type host_filename = string - type host_dirname = string - - - let current_dir_name = "." - - - let parent_dir_name = ".." - - - let is_current_dir fn = - fn = current_dir_name || fn = "" - - - let concat f1 f2 = - if is_current_dir f1 then - f2 - else - let f1' = - try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 - in - f1'^"/"^f2 - - - let make = - function - | hd :: tl -> - List.fold_left - (fun f p -> concat f p) - hd - tl - | [] -> - invalid_arg "OASISUnixPath.make" - - - let dirname f = - try - String.sub f 0 (String.rindex f '/') - with Not_found -> - current_dir_name - - - let basename f = - try - let pos_start = - (String.rindex f '/') + 1 - in - String.sub f pos_start ((String.length f) - pos_start) - with Not_found -> - f - - - let chop_extension f = - try - let last_dot = - String.rindex f '.' - in - let sub = - String.sub f 0 last_dot - in - try - let last_slash = - String.rindex f '/' - in - if last_slash < last_dot then - sub - else - f - with Not_found -> - sub - - with Not_found -> - f - - - let capitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (OASISString.capitalize_ascii base) - - - let uncapitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (OASISString.uncapitalize_ascii base) - - -end - -module OASISHostPath = struct -(* # 22 "src/oasis/OASISHostPath.ml" *) - - - open Filename - open OASISGettext - - - module Unix = OASISUnixPath - - - let make = - function - | [] -> - invalid_arg "OASISHostPath.make" - | hd :: tl -> - List.fold_left Filename.concat hd tl - - - let of_unix ufn = - match Sys.os_type with - | "Unix" | "Cygwin" -> ufn - | "Win32" -> - make - (List.map - (fun p -> - if p = Unix.current_dir_name then - current_dir_name - else if p = Unix.parent_dir_name then - parent_dir_name - else - p) - (OASISString.nsplit ufn '/')) - | os_type -> - OASISUtils.failwithf - (f_ "Don't know the path format of os_type %S when translating unix \ - filename. %S") - os_type ufn - - -end - -module OASISFileSystem = struct -(* # 22 "src/oasis/OASISFileSystem.ml" *) - - (** File System functions - - @author Sylvain Le Gall - *) - - type 'a filename = string - - class type closer = - object - method close: unit - end - - class type reader = - object - inherit closer - method input: Buffer.t -> int -> unit - end - - class type writer = - object - inherit closer - method output: Buffer.t -> unit - end - - class type ['a] fs = - object - method string_of_filename: 'a filename -> string - method open_out: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> writer - method open_in: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> reader - method file_exists: 'a filename -> bool - method remove: 'a filename -> unit - end - - - module Mode = - struct - let default_in = [Open_rdonly] - let default_out = [Open_wronly; Open_creat; Open_trunc] - - let text_in = Open_text :: default_in - let text_out = Open_text :: default_out - - let binary_in = Open_binary :: default_in - let binary_out = Open_binary :: default_out - end - - let std_length = 4096 (* Standard buffer/read length. *) - let binary_out = Mode.binary_out - let binary_in = Mode.binary_in - - let of_unix_filename ufn = (ufn: 'a filename) - let to_unix_filename fn = (fn: string) - - - let defer_close o f = - try - let r = f o in o#close; r - with e -> - o#close; raise e - - - let stream_of_reader rdr = - let buf = Buffer.create std_length in - let pos = ref 0 in - let eof = ref false in - let rec next idx = - let bpos = idx - !pos in - if !eof then begin - None - end else if bpos < Buffer.length buf then begin - Some (Buffer.nth buf bpos) - end else begin - pos := !pos + Buffer.length buf; - Buffer.clear buf; - begin - try - rdr#input buf std_length; - with End_of_file -> - if Buffer.length buf = 0 then - eof := true - end; - next idx - end - in - Stream.from next - - - let read_all buf rdr = - try - while true do - rdr#input buf std_length - done - with End_of_file -> - () - - class ['a] host_fs rootdir : ['a] fs = - object (self) - method private host_filename fn = Filename.concat rootdir fn - method string_of_filename = self#host_filename - - method open_out ?(mode=Mode.text_out) ?(perm=0o666) fn = - let chn = open_out_gen mode perm (self#host_filename fn) in - object - method close = close_out chn - method output buf = Buffer.output_buffer chn buf - end - - method open_in ?(mode=Mode.text_in) ?(perm=0o666) fn = - (* TODO: use Buffer.add_channel when minimal version of OCaml will - * be >= 4.03.0 (previous version was discarding last chars). - *) - let chn = open_in_gen mode perm (self#host_filename fn) in - let strm = Stream.of_channel chn in - object - method close = close_in chn - method input buf len = - let read = ref 0 in - try - for _i = 0 to len do - Buffer.add_char buf (Stream.next strm); - incr read - done - with Stream.Failure -> - if !read = 0 then - raise End_of_file - end - - method file_exists fn = Sys.file_exists (self#host_filename fn) - method remove fn = Sys.remove (self#host_filename fn) - end - -end - -module OASISContext = struct -(* # 22 "src/oasis/OASISContext.ml" *) - - - open OASISGettext - - - type level = - [ `Debug - | `Info - | `Warning - | `Error] - - - type source - type source_filename = source OASISFileSystem.filename - - - let in_srcdir ufn = OASISFileSystem.of_unix_filename ufn - - - type t = - { - (* TODO: replace this by a proplist. *) - quiet: bool; - info: bool; - debug: bool; - ignore_plugins: bool; - ignore_unknown_fields: bool; - printf: level -> string -> unit; - srcfs: source OASISFileSystem.fs; - load_oasis_plugin: string -> bool; - } - - - let printf lvl str = - let beg = - match lvl with - | `Error -> s_ "E: " - | `Warning -> s_ "W: " - | `Info -> s_ "I: " - | `Debug -> s_ "D: " - in - prerr_endline (beg^str) - - - let default = - ref - { - quiet = false; - info = false; - debug = false; - ignore_plugins = false; - ignore_unknown_fields = false; - printf = printf; - srcfs = new OASISFileSystem.host_fs(Sys.getcwd ()); - load_oasis_plugin = (fun _ -> false); - } - - - let quiet = - {!default with quiet = true} - - - let fspecs () = - (* TODO: don't act on default. *) - let ignore_plugins = ref false in - ["-quiet", - Arg.Unit (fun () -> default := {!default with quiet = true}), - s_ " Run quietly"; - - "-info", - Arg.Unit (fun () -> default := {!default with info = true}), - s_ " Display information message"; - - - "-debug", - Arg.Unit (fun () -> default := {!default with debug = true}), - s_ " Output debug message"; - - "-ignore-plugins", - Arg.Set ignore_plugins, - s_ " Ignore plugin's field."; - - "-C", - Arg.String - (fun str -> - Sys.chdir str; - default := {!default with srcfs = new OASISFileSystem.host_fs str}), - s_ "dir Change directory before running (affects setup.{data,log})."], - fun () -> {!default with ignore_plugins = !ignore_plugins} -end - -module PropList = struct -(* # 22 "src/oasis/PropList.ml" *) - - - open OASISGettext - - - type name = string - - - exception Not_set of name * string option - exception No_printer of name - exception Unknown_field of name * name - - - let () = - Printexc.register_printer - (function - | Not_set (nm, Some rsn) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) - | Not_set (nm, None) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set") nm) - | No_printer nm -> - Some - (Printf.sprintf (f_ "No default printer for value %s") nm) - | Unknown_field (nm, schm) -> - Some - (Printf.sprintf - (f_ "Field %s is not defined in schema %s") nm schm) - | _ -> - None) - - - module Data = - struct - type t = - (name, unit -> unit) Hashtbl.t - - let create () = - Hashtbl.create 13 - - let clear t = - Hashtbl.clear t - - -(* # 77 "src/oasis/PropList.ml" *) - end - - - module Schema = - struct - type ('ctxt, 'extra) value = - { - get: Data.t -> string; - set: Data.t -> ?context:'ctxt -> string -> unit; - help: (unit -> string) option; - extra: 'extra; - } - - type ('ctxt, 'extra) t = - { - name: name; - fields: (name, ('ctxt, 'extra) value) Hashtbl.t; - order: name Queue.t; - name_norm: string -> string; - } - - let create ?(case_insensitive=false) nm = - { - name = nm; - fields = Hashtbl.create 13; - order = Queue.create (); - name_norm = - (if case_insensitive then - OASISString.lowercase_ascii - else - fun s -> s); - } - - let add t nm set get extra help = - let key = - t.name_norm nm - in - - if Hashtbl.mem t.fields key then - failwith - (Printf.sprintf - (f_ "Field '%s' is already defined in schema '%s'") - nm t.name); - Hashtbl.add - t.fields - key - { - set = set; - get = get; - help = help; - extra = extra; - }; - Queue.add nm t.order - - let mem t nm = - Hashtbl.mem t.fields nm - - let find t nm = - try - Hashtbl.find t.fields (t.name_norm nm) - with Not_found -> - raise (Unknown_field (nm, t.name)) - - let get t data nm = - (find t nm).get data - - let set t data nm ?context x = - (find t nm).set - data - ?context - x - - let fold f acc t = - Queue.fold - (fun acc k -> - let v = - find t k - in - f acc k v.extra v.help) - acc - t.order - - let iter f t = - fold - (fun () -> f) - () - t - - let name t = - t.name - end - - - module Field = - struct - type ('ctxt, 'value, 'extra) t = - { - set: Data.t -> ?context:'ctxt -> 'value -> unit; - get: Data.t -> 'value; - sets: Data.t -> ?context:'ctxt -> string -> unit; - gets: Data.t -> string; - help: (unit -> string) option; - extra: 'extra; - } - - let new_id = - let last_id = - ref 0 - in - fun () -> incr last_id; !last_id - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - (* Default value container *) - let v = - ref None - in - - (* If name is not given, create unique one *) - let nm = - match name with - | Some s -> s - | None -> Printf.sprintf "_anon_%d" (new_id ()) - in - - (* Last chance to get a value: the default *) - let default () = - match default with - | Some d -> d - | None -> raise (Not_set (nm, Some (s_ "no default value"))) - in - - (* Get data *) - let get data = - (* Get value *) - try - (Hashtbl.find data nm) (); - match !v with - | Some x -> x - | None -> default () - with Not_found -> - default () - in - - (* Set data *) - let set data ?context x = - let x = - match update with - | Some f -> - begin - try - f ?context (get data) x - with Not_set _ -> - x - end - | None -> - x - in - Hashtbl.replace - data - nm - (fun () -> v := Some x) - in - - (* Parse string value, if possible *) - let parse = - match parse with - | Some f -> - f - | None -> - fun ?context s -> - failwith - (Printf.sprintf - (f_ "Cannot parse field '%s' when setting value %S") - nm - s) - in - - (* Set data, from string *) - let sets data ?context s = - set ?context data (parse ?context s) - in - - (* Output value as string, if possible *) - let print = - match print with - | Some f -> - f - | None -> - fun _ -> raise (No_printer nm) - in - - (* Get data, as a string *) - let gets data = - print (get data) - in - - begin - match schema with - | Some t -> - Schema.add t nm sets gets extra help - | None -> - () - end; - - { - set = set; - get = get; - sets = sets; - gets = gets; - help = help; - extra = extra; - } - - let fset data t ?context x = - t.set data ?context x - - let fget data t = - t.get data - - let fsets data t ?context s = - t.sets data ?context s - - let fgets data t = - t.gets data - end - - - module FieldRO = - struct - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - let fld = - Field.create ?schema ?name ?parse ?print ?default ?update ?help extra - in - fun data -> Field.fget data fld - end -end - -module OASISMessage = struct -(* # 22 "src/oasis/OASISMessage.ml" *) - - - open OASISGettext - open OASISContext - - - let generic_message ~ctxt lvl fmt = - let cond = - if ctxt.quiet then - false - else - match lvl with - | `Debug -> ctxt.debug - | `Info -> ctxt.info - | _ -> true - in - Printf.ksprintf - (fun str -> - if cond then - begin - ctxt.printf lvl str - end) - fmt - - - let debug ~ctxt fmt = - generic_message ~ctxt `Debug fmt - - - let info ~ctxt fmt = - generic_message ~ctxt `Info fmt - - - let warning ~ctxt fmt = - generic_message ~ctxt `Warning fmt - - - let error ~ctxt fmt = - generic_message ~ctxt `Error fmt - -end - -module OASISVersion = struct -(* # 22 "src/oasis/OASISVersion.ml" *) - - - open OASISGettext - - - type t = string - - - type comparator = - | VGreater of t - | VGreaterEqual of t - | VEqual of t - | VLesser of t - | VLesserEqual of t - | VOr of comparator * comparator - | VAnd of comparator * comparator - - - (* Range of allowed characters *) - let is_digit c = '0' <= c && c <= '9' - let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') - let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false - - - let rec version_compare v1 v2 = - if v1 <> "" || v2 <> "" then - begin - (* Compare ascii string, using special meaning for version - * related char - *) - let val_ascii c = - if c = '~' then -1 - else if is_digit c then 0 - else if c = '\000' then 0 - else if is_alpha c then Char.code c - else (Char.code c) + 256 - in - - let len1 = String.length v1 in - let len2 = String.length v2 in - - let p = ref 0 in - - (** Compare ascii part *) - let compare_vascii () = - let cmp = ref 0 in - while !cmp = 0 && - !p < len1 && !p < len2 && - not (is_digit v1.[!p] && is_digit v2.[!p]) do - cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); - incr p - done; - if !cmp = 0 && !p < len1 && !p = len2 then - val_ascii v1.[!p] - else if !cmp = 0 && !p = len1 && !p < len2 then - - (val_ascii v2.[!p]) - else - !cmp - in - - (** Compare digit part *) - let compare_digit () = - let extract_int v p = - let start_p = !p in - while !p < String.length v && is_digit v.[!p] do - incr p - done; - let substr = - String.sub v !p ((String.length v) - !p) - in - let res = - match String.sub v start_p (!p - start_p) with - | "" -> 0 - | s -> int_of_string s - in - res, substr - in - let i1, tl1 = extract_int v1 (ref !p) in - let i2, tl2 = extract_int v2 (ref !p) in - i1 - i2, tl1, tl2 - in - - match compare_vascii () with - | 0 -> - begin - match compare_digit () with - | 0, tl1, tl2 -> - if tl1 <> "" && is_digit tl1.[0] then - 1 - else if tl2 <> "" && is_digit tl2.[0] then - -1 - else - version_compare tl1 tl2 - | n, _, _ -> - n - end - | n -> - n - end - else begin - 0 - end - - - let version_of_string str = str - - - let string_of_version t = t - - - let chop t = - try - let pos = - String.rindex t '.' - in - String.sub t 0 pos - with Not_found -> - t - - - let rec comparator_apply v op = - match op with - | VGreater cv -> - (version_compare v cv) > 0 - | VGreaterEqual cv -> - (version_compare v cv) >= 0 - | VLesser cv -> - (version_compare v cv) < 0 - | VLesserEqual cv -> - (version_compare v cv) <= 0 - | VEqual cv -> - (version_compare v cv) = 0 - | VOr (op1, op2) -> - (comparator_apply v op1) || (comparator_apply v op2) - | VAnd (op1, op2) -> - (comparator_apply v op1) && (comparator_apply v op2) - - - let rec string_of_comparator = - function - | VGreater v -> "> "^(string_of_version v) - | VEqual v -> "= "^(string_of_version v) - | VLesser v -> "< "^(string_of_version v) - | VGreaterEqual v -> ">= "^(string_of_version v) - | VLesserEqual v -> "<= "^(string_of_version v) - | VOr (c1, c2) -> - (string_of_comparator c1)^" || "^(string_of_comparator c2) - | VAnd (c1, c2) -> - (string_of_comparator c1)^" && "^(string_of_comparator c2) - - - let rec varname_of_comparator = - let concat p v = - OASISUtils.varname_concat - p - (OASISUtils.varname_of_string - (string_of_version v)) - in - function - | VGreater v -> concat "gt" v - | VLesser v -> concat "lt" v - | VEqual v -> concat "eq" v - | VGreaterEqual v -> concat "ge" v - | VLesserEqual v -> concat "le" v - | VOr (c1, c2) -> - (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) - | VAnd (c1, c2) -> - (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - - -end - -module OASISLicense = struct -(* # 22 "src/oasis/OASISLicense.ml" *) - - - (** License for _oasis fields - @author Sylvain Le Gall - *) - - - type license = string - type license_exception = string - - - type license_version = - | Version of OASISVersion.t - | VersionOrLater of OASISVersion.t - | NoVersion - - - type license_dep_5_unit = - { - license: license; - excption: license_exception option; - version: license_version; - } - - - type license_dep_5 = - | DEP5Unit of license_dep_5_unit - | DEP5Or of license_dep_5 list - | DEP5And of license_dep_5 list - - - type t = - | DEP5License of license_dep_5 - | OtherLicense of string (* URL *) - - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - open OASISGettext - open OASISUtils - - - type test = string - type flag = string - - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - type 'a choices = (t * 'a) list - - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - - -end - -module OASISText = struct -(* # 22 "src/oasis/OASISText.ml" *) - - type elt = - | Para of string - | Verbatim of string - | BlankLine - - type t = elt list - -end - -module OASISSourcePatterns = struct -(* # 22 "src/oasis/OASISSourcePatterns.ml" *) - - open OASISUtils - open OASISGettext - - module Templater = - struct - (* TODO: use this module in BaseEnv.var_expand and BaseFileAB, at least. *) - type t = - { - atoms: atom list; - origin: string - } - and atom = - | Text of string - | Expr of expr - and expr = - | Ident of string - | String of string - | Call of string * expr - - - type env = - { - variables: string MapString.t; - functions: (string -> string) MapString.t; - } - - - let eval env t = - let rec eval_expr env = - function - | String str -> str - | Ident nm -> - begin - try - MapString.find nm env.variables - with Not_found -> - (* TODO: add error location within the string. *) - failwithf - (f_ "Unable to find variable %S in source pattern %S") - nm t.origin - end - - | Call (fn, expr) -> - begin - try - (MapString.find fn env.functions) (eval_expr env expr) - with Not_found -> - (* TODO: add error location within the string. *) - failwithf - (f_ "Unable to find function %S in source pattern %S") - fn t.origin - end - in - String.concat "" - (List.map - (function - | Text str -> str - | Expr expr -> eval_expr env expr) - t.atoms) - - - let parse env s = - let lxr = Genlex.make_lexer [] in - let parse_expr s = - let st = lxr (Stream.of_string s) in - match Stream.npeek 3 st with - | [Genlex.Ident fn; Genlex.Ident nm] -> Call(fn, Ident nm) - | [Genlex.Ident fn; Genlex.String str] -> Call(fn, String str) - | [Genlex.String str] -> String str - | [Genlex.Ident nm] -> Ident nm - (* TODO: add error location within the string. *) - | _ -> failwithf (f_ "Unable to parse expression %S") s - in - let parse s = - let lst_exprs = ref [] in - let ss = - let buff = Buffer.create (String.length s) in - Buffer.add_substitute - buff - (fun s -> lst_exprs := (parse_expr s) :: !lst_exprs; "\000") - s; - Buffer.contents buff - in - let rec join = - function - | hd1 :: tl1, hd2 :: tl2 -> Text hd1 :: Expr hd2 :: join (tl1, tl2) - | [], tl -> List.map (fun e -> Expr e) tl - | tl, [] -> List.map (fun e -> Text e) tl - in - join (OASISString.nsplit ss '\000', List.rev (!lst_exprs)) - in - let t = {atoms = parse s; origin = s} in - (* We rely on a simple evaluation for checking variables/functions. - It works because there is no if/loop statement. - *) - let _s : string = eval env t in - t - -(* # 144 "src/oasis/OASISSourcePatterns.ml" *) - end - - - type t = Templater.t - - - let env ~modul () = - { - Templater. - variables = MapString.of_list ["module", modul]; - functions = MapString.of_list - [ - "capitalize_file", OASISUnixPath.capitalize_file; - "uncapitalize_file", OASISUnixPath.uncapitalize_file; - ]; - } - - let all_possible_files lst ~path ~modul = - let eval = Templater.eval (env ~modul ()) in - List.fold_left - (fun acc pat -> OASISUnixPath.concat path (eval pat) :: acc) - [] lst - - - let to_string t = t.Templater.origin - - -end - -module OASISTypes = struct -(* # 22 "src/oasis/OASISTypes.ml" *) - - - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string (* TODO: replace everywhere. *) - type host_dirname = string (* TODO: replace everywhere. *) - type host_filename = string (* TODO: replace everywhere. *) - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) - - - type findlib_name = string - type findlib_full = string - - - type compiled_object = - | Byte - | Native - | Best - - - type dependency = - | FindlibPackage of findlib_full * OASISVersion.comparator option - | InternalLibrary of name - - - type tool = - | ExternalTool of name - | InternalExecutable of name - - - type vcs = - | Darcs - | Git - | Svn - | Cvs - | Hg - | Bzr - | Arch - | Monotone - | OtherVCS of url - - - type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install - | `Extra - ] - - - type plugin_data_purpose = - [ `Configure - | `Build - | `Install - | `Clean - | `Distclean - | `Install - | `Uninstall - | `Test - | `Doc - | `Extra - | `Other of string - ] - - - type 'a plugin = 'a * name * OASISVersion.t option - - - type all_plugin = plugin_kind plugin - - - type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list - - - type 'a conditional = 'a OASISExpr.choices - - - type custom = - { - pre_command: (command_line option) conditional; - post_command: (command_line option) conditional; - } - - - type common_section = - { - cs_name: name; - cs_data: PropList.Data.t; - cs_plugin_data: plugin_data; - } - - - type build_section = - { - bs_build: bool conditional; - bs_install: bool conditional; - bs_path: unix_dirname; - bs_compiled_object: compiled_object; - bs_build_depends: dependency list; - bs_build_tools: tool list; - bs_interface_patterns: OASISSourcePatterns.t list; - bs_implementation_patterns: OASISSourcePatterns.t list; - bs_c_sources: unix_filename list; - bs_data_files: (unix_filename * unix_filename option) list; - bs_findlib_extra_files: unix_filename list; - bs_ccopt: args conditional; - bs_cclib: args conditional; - bs_dlllib: args conditional; - bs_dllpath: args conditional; - bs_byteopt: args conditional; - bs_nativeopt: args conditional; - } - - - type library = - { - lib_modules: string list; - lib_pack: bool; - lib_internal_modules: string list; - lib_findlib_parent: findlib_name option; - lib_findlib_name: findlib_name option; - lib_findlib_directory: unix_dirname option; - lib_findlib_containers: findlib_name list; - } - - - type object_ = - { - obj_modules: string list; - obj_findlib_fullname: findlib_name list option; - obj_findlib_directory: unix_dirname option; - } - - - type executable = - { - exec_custom: bool; - exec_main_is: unix_filename; - } - - - type flag = - { - flag_description: string option; - flag_default: bool conditional; - } - - - type source_repository = - { - src_repo_type: vcs; - src_repo_location: url; - src_repo_browser: url option; - src_repo_module: string option; - src_repo_branch: string option; - src_repo_tag: string option; - src_repo_subdir: unix_filename option; - } - - - type test = - { - test_type: [`Test] plugin; - test_command: command_line conditional; - test_custom: custom; - test_working_directory: unix_filename option; - test_run: bool conditional; - test_tools: tool list; - } - - - type doc_format = - | HTML of unix_filename (* TODO: source filename. *) - | DocText - | PDF - | PostScript - | Info of unix_filename (* TODO: source filename. *) - | DVI - | OtherDoc - - - type doc = - { - doc_type: [`Doc] plugin; - doc_custom: custom; - doc_build: bool conditional; - doc_install: bool conditional; - doc_install_dir: unix_filename; (* TODO: dest filename ?. *) - doc_title: string; - doc_authors: string list; - doc_abstract: string option; - doc_format: doc_format; - (* TODO: src filename. *) - doc_data_files: (unix_filename * unix_filename option) list; - doc_build_tools: tool list; - } - - - type section = - | Library of common_section * build_section * library - | Object of common_section * build_section * object_ - | Executable of common_section * build_section * executable - | Flag of common_section * flag - | SrcRepo of common_section * source_repository - | Test of common_section * test - | Doc of common_section * doc - - - type section_kind = - [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] - - - type package = - { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; (* TODO: source filename. *) - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - bugreports: url option; - synopsis: string; - description: OASISText.t option; - tags: string list; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; (* TODO: source filename. *) - sections: section list; - plugins: [`Extra] plugin list; - disable_oasis_section: unix_filename list; (* TODO: source filename. *) - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } - - -end - -module OASISFeatures = struct -(* # 22 "src/oasis/OASISFeatures.ml" *) - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISVersion - - module MapPlugin = - Map.Make - (struct - type t = plugin_kind * name - let compare = Pervasives.compare - end) - - module Data = - struct - type t = - { - oasis_version: OASISVersion.t; - plugin_versions: OASISVersion.t option MapPlugin.t; - alpha_features: string list; - beta_features: string list; - } - - let create oasis_version alpha_features beta_features = - { - oasis_version = oasis_version; - plugin_versions = MapPlugin.empty; - alpha_features = alpha_features; - beta_features = beta_features - } - - let of_package pkg = - create - pkg.OASISTypes.oasis_version - pkg.OASISTypes.alpha_features - pkg.OASISTypes.beta_features - - let add_plugin (plugin_kind, plugin_name, plugin_version) t = - {t with - plugin_versions = MapPlugin.add - (plugin_kind, plugin_name) - plugin_version - t.plugin_versions} - - let plugin_version plugin_kind plugin_name t = - MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions - - let to_string t = - Printf.sprintf - "oasis_version: %s; alpha_features: %s; beta_features: %s; \ - plugins_version: %s" - (OASISVersion.string_of_version (t:t).oasis_version) - (String.concat ", " t.alpha_features) - (String.concat ", " t.beta_features) - (String.concat ", " - (MapPlugin.fold - (fun (_, plg) ver_opt acc -> - (plg^ - (match ver_opt with - | Some v -> - " "^(OASISVersion.string_of_version v) - | None -> "")) - :: acc) - t.plugin_versions [])) - end - - type origin = - | Field of string * string - | Section of string - | NoOrigin - - type stage = Alpha | Beta - - - let string_of_stage = - function - | Alpha -> "alpha" - | Beta -> "beta" - - - let field_of_stage = - function - | Alpha -> "AlphaFeatures" - | Beta -> "BetaFeatures" - - type publication = InDev of stage | SinceVersion of OASISVersion.t - - type t = - { - name: string; - plugin: all_plugin option; - publication: publication; - description: unit -> string; - } - - (* TODO: mutex protect this. *) - let all_features = Hashtbl.create 13 - - - let since_version ver_str = SinceVersion (version_of_string ver_str) - let alpha = InDev Alpha - let beta = InDev Beta - - - let to_string t = - Printf.sprintf - "feature: %s; plugin: %s; publication: %s" - (t:t).name - (match t.plugin with - | None -> "" - | Some (_, nm, _) -> nm) - (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) - - let data_check t data origin = - let no_message = "no message" in - - let check_feature features stage = - let has_feature = List.mem (t:t).name features in - if not has_feature then - match (origin:origin) with - | Field (fld, where) -> - Some - (Printf.sprintf - (f_ "Field %s in %s is only available when feature %s \ - is in field %s.") - fld where t.name (field_of_stage stage)) - | Section sct -> - Some - (Printf.sprintf - (f_ "Section %s is only available when features %s \ - is in field %s.") - sct t.name (field_of_stage stage)) - | NoOrigin -> - Some no_message - else - None - in - - let version_is_good ~min_version version fmt = - let version_is_good = - OASISVersion.comparator_apply - version (OASISVersion.VGreaterEqual min_version) - in - Printf.ksprintf - (fun str -> if version_is_good then None else Some str) - fmt - in - - match origin, t.plugin, t.publication with - | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha - | _, _, InDev Beta -> check_feature data.Data.beta_features Beta - | Field(fld, where), None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Field %s in %s is only valid since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking \ - OASIS changelog.") - fld where (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Field(fld, where), Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Field %s in %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - fld where plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Field %s in %s is only valid when the OASIS plugin %s \ - is defined.") - fld where plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Field %s in %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - fld where plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | Section sct, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Section %s is only valid for since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking OASIS \ - changelog.") - sct (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Section sct, Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Section %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - sct plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Section %s is only valid when the OASIS plugin %s \ - is defined.") - sct plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Section %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - sct plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | NoOrigin, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version "%s" no_message - - | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> - begin - try - let plugin_version_current = - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> raise Not_found - in - version_is_good ~min_version plugin_version_current - "%s" no_message - with Not_found -> - Some no_message - end - - - let data_assert t data origin = - match data_check t data origin with - | None -> () - | Some str -> failwith str - - - let data_test t data = - match data_check t data NoOrigin with - | None -> true - | Some _ -> false - - - let package_test t pkg = - data_test t (Data.of_package pkg) - - - let create ?plugin name publication description = - let () = - if Hashtbl.mem all_features name then - failwithf "Feature '%s' is already declared." name - in - let t = - { - name = name; - plugin = plugin; - publication = publication; - description = description; - } - in - Hashtbl.add all_features name t; - t - - - let get_stage name = - try - (Hashtbl.find all_features name).publication - with Not_found -> - failwithf (f_ "Feature %s doesn't exist.") name - - - let list () = - Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] - - (* - * Real flags. - *) - - - let features = - create "features_fields" - (since_version "0.4") - (fun () -> - s_ "Enable to experiment not yet official features.") - - - let flag_docs = - create "flag_docs" - (since_version "0.3") - (fun () -> - s_ "Make building docs require '-docs' flag at configure.") - - - let flag_tests = - create "flag_tests" - (since_version "0.3") - (fun () -> - s_ "Make running tests require '-tests' flag at configure.") - - - let pack = - create "pack" - (since_version "0.3") - (fun () -> - s_ "Allow to create packed library.") - - - let section_object = - create "section_object" beta - (fun () -> - s_ "Implement an object section.") - - - let dynrun_for_release = - create "dynrun_for_release" alpha - (fun () -> - s_ "Make '-setup-update dynamic' suitable for releasing project.") - - - let compiled_setup_ml = - create "compiled_setup_ml" alpha - (fun () -> - s_ "Compile the setup.ml and speed-up actions done with it.") - - let disable_oasis_section = - create "disable_oasis_section" alpha - (fun () -> - s_ "Allow the OASIS section comments and digests to be omitted in \ - generated files.") - - let no_automatic_syntax = - create "no_automatic_syntax" alpha - (fun () -> - s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ - that matches the internal heuristic (if a dependency ends with \ - a .syntax or is a well known syntax).") - - let findlib_directory = - create "findlib_directory" beta - (fun () -> - s_ "Allow to install findlib libraries in sub-directories of the target \ - findlib directory.") - - let findlib_extra_files = - create "findlib_extra_files" beta - (fun () -> - s_ "Allow to install extra files for findlib libraries.") - - let source_patterns = - create "source_patterns" alpha - (fun () -> - s_ "Customize mapping between module name and source file.") -end - -module OASISSection = struct -(* # 22 "src/oasis/OASISSection.ml" *) - - - open OASISTypes - - - let section_kind_common = - function - | Library (cs, _, _) -> - `Library, cs - | Object (cs, _, _) -> - `Object, cs - | Executable (cs, _, _) -> - `Executable, cs - | Flag (cs, _) -> - `Flag, cs - | SrcRepo (cs, _) -> - `SrcRepo, cs - | Test (cs, _) -> - `Test, cs - | Doc (cs, _) -> - `Doc, cs - - - let section_common sct = - snd (section_kind_common sct) - - - let section_common_set cs = - function - | Library (_, bs, lib) -> Library (cs, bs, lib) - | Object (_, bs, obj) -> Object (cs, bs, obj) - | Executable (_, bs, exec) -> Executable (cs, bs, exec) - | Flag (_, flg) -> Flag (cs, flg) - | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) - | Test (_, tst) -> Test (cs, tst) - | Doc (_, doc) -> Doc (cs, doc) - - - (** Key used to identify section - *) - let section_id sct = - let k, cs = - section_kind_common sct - in - k, cs.cs_name - - - let string_of_section_kind = - function - | `Library -> "library" - | `Object -> "object" - | `Executable -> "executable" - | `Flag -> "flag" - | `SrcRepo -> "src repository" - | `Test -> "test" - | `Doc -> "doc" - - - let string_of_section sct = - let k, nm = section_id sct in - (string_of_section_kind k)^" "^nm - - - let section_find id scts = - List.find - (fun sct -> id = section_id sct) - scts - - - module CSection = - struct - type t = section - - let id = section_id - - let compare t1 t2 = - compare (id t1) (id t2) - - let equal t1 t2 = - (id t1) = (id t2) - - let hash t = - Hashtbl.hash (id t) - end - - - module MapSection = Map.Make(CSection) - module SetSection = Set.Make(CSection) - - -end - -module OASISBuildSection = struct -(* # 22 "src/oasis/OASISBuildSection.ml" *) - - open OASISTypes - - (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists bs modul = - let possible_lst = - OASISSourcePatterns.all_possible_files - (bs.bs_interface_patterns @ bs.bs_implementation_patterns) - ~path:bs.bs_path - ~modul - in - match List.filter source_file_exists possible_lst with - | (fn :: _) as fn_lst -> `Sources (OASISUnixPath.chop_extension fn, fn_lst) - | [] -> - let open OASISUtils in - let _, rev_lst = - List.fold_left - (fun (set, acc) fn -> - let base_fn = OASISUnixPath.chop_extension fn in - if SetString.mem base_fn set then - set, acc - else - SetString.add base_fn set, base_fn :: acc) - (SetString.empty, []) possible_lst - in - `No_sources (List.rev rev_lst) - - -end - -module OASISExecutable = struct -(* # 22 "src/oasis/OASISExecutable.ml" *) - - - open OASISTypes - - - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = - OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.dirname exec.exec_main_is) - in - let is_native_exec = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native () - | Byte -> false - in - - OASISUnixPath.concat - dir - (cs.cs_name^(suffix_program ())), - - if not is_native_exec && - not exec.exec_custom && - bs.bs_c_sources <> [] then - Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) - else - None - - -end - -module OASISLibrary = struct -(* # 22 "src/oasis/OASISLibrary.ml" *) - - - open OASISTypes - open OASISGettext - - let find_module ~ctxt source_file_exists cs bs modul = - match OASISBuildSection.find_module source_file_exists bs modul with - | `Sources _ as res -> res - | `No_sources _ as res -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching module '%s' in library %s.") - modul cs.cs_name; - OASISMessage.warning - ~ctxt - (f_ "Use InterfacePatterns or ImplementationPatterns to define \ - this file with feature %S.") - (OASISFeatures.source_patterns.OASISFeatures.name); - res - - let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = - List.fold_left - (fun acc modul -> - match find_module ~ctxt source_file_exists cs bs modul with - | `Sources (base_fn, lst) -> (base_fn, lst) :: acc - | `No_sources _ -> acc) - [] - (lib.lib_modules @ lib.lib_internal_modules) - - - let generated_unix_files - ~ctxt - ~is_native - ~has_native_dynlink - ~ext_lib - ~ext_dll - ~source_file_exists - (cs, bs, lib) = - - let find_modules lst ext = - let find_module modul = - match find_module ~ctxt source_file_exists cs bs modul with - | `Sources (_, [fn]) when ext <> "cmi" - && Filename.check_suffix fn ".mli" -> - None (* No implementation files for pure interface. *) - | `Sources (base_fn, _) -> Some [base_fn] - | `No_sources lst -> Some lst - in - List.fold_left - (fun acc nm -> - match find_module nm with - | None -> acc - | Some base_fns -> - List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) - [] - lst - in - - (* The .cmx that be compiled along *) - let cmxs = - let should_be_built = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native - | Byte -> false - in - if should_be_built then - if lib.lib_pack then - find_modules - [cs.cs_name] - "cmx" - else - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" - else - [] - in - - let acc_nopath = - [] - in - - (* The headers and annot/cmt files that should be compiled along *) - let headers = - let sufx = - if lib.lib_pack - then [".cmti"; ".cmt"; ".annot"] - else [".cmi"; ".cmti"; ".cmt"; ".annot"] - in - List.map - (List.fold_left - (fun accu s -> - let dot = String.rindex s '.' in - let base = String.sub s 0 dot in - List.map ((^) base) sufx @ accu) - []) - (find_modules lib.lib_modules "cmi") - in - - (* Compute what libraries should be built *) - let acc_nopath = - (* Add the packed header file if required *) - let add_pack_header acc = - if lib.lib_pack then - [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc - else - acc - in - let byte acc = - add_pack_header ([cs.cs_name^".cma"] :: acc) - in - let native acc = - let acc = - add_pack_header - (if has_native_dynlink then - [cs.cs_name^".cmxs"] :: acc - else acc) - in - [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc - in - match bs.bs_compiled_object with - | Native -> byte (native acc_nopath) - | Best when is_native -> byte (native acc_nopath) - | Byte | Best -> byte acc_nopath - in - - (* Add C library to be built *) - let acc_nopath = - if bs.bs_c_sources <> [] then begin - ["lib"^cs.cs_name^"_stubs"^ext_lib] - :: - if has_native_dynlink then - ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath - else - acc_nopath - end else begin - acc_nopath - end - in - - (* All the files generated *) - List.rev_append - (List.rev_map - (List.rev_map - (OASISUnixPath.concat bs.bs_path)) - acc_nopath) - (headers @ cmxs) - - -end - -module OASISObject = struct -(* # 22 "src/oasis/OASISObject.ml" *) - - - open OASISTypes - open OASISGettext - - - let find_module ~ctxt source_file_exists cs bs modul = - match OASISBuildSection.find_module source_file_exists bs modul with - | `Sources _ as res -> res - | `No_sources _ as res -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching module '%s' in object %s.") - modul cs.cs_name; - OASISMessage.warning - ~ctxt - (f_ "Use InterfacePatterns or ImplementationPatterns to define \ - this file with feature %S.") - (OASISFeatures.source_patterns.OASISFeatures.name); - res - - let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = - List.fold_left - (fun acc modul -> - match find_module ~ctxt source_file_exists cs bs modul with - | `Sources (base_fn, lst) -> (base_fn, lst) :: acc - | `No_sources _ -> acc) - [] - obj.obj_modules - - - let generated_unix_files - ~ctxt - ~is_native - ~source_file_exists - (cs, bs, obj) = - - let find_module ext modul = - match find_module ~ctxt source_file_exists cs bs modul with - | `Sources (base_fn, _) -> [base_fn ^ ext] - | `No_sources lst -> lst - in - - let header, byte, native, c_object, f = - match obj.obj_modules with - | [ m ] -> (find_module ".cmi" m, - find_module ".cmo" m, - find_module ".cmx" m, - find_module ".o" m, - fun x -> x) - | _ -> ([cs.cs_name ^ ".cmi"], - [cs.cs_name ^ ".cmo"], - [cs.cs_name ^ ".cmx"], - [cs.cs_name ^ ".o"], - OASISUnixPath.concat bs.bs_path) - in - List.map (List.map f) ( - match bs.bs_compiled_object with - | Native -> - native :: c_object :: byte :: header :: [] - | Best when is_native -> - native :: c_object :: byte :: header :: [] - | Byte | Best -> - byte :: header :: []) - - -end - -module OASISFindlib = struct -(* # 22 "src/oasis/OASISFindlib.ml" *) - - - open OASISTypes - open OASISUtils - open OASISGettext - - - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - [`Library of library | `Object of object_] * - unix_dirname option * - group_t list) - - - type data = common_section * - build_section * - [`Library of library | `Object of object_] - type tree = - | Node of (data option) * (tree MapString.t) - | Leaf of data - - - let findlib_mapping pkg = - (* Map from library name to either full findlib name or parts + parent. *) - let fndlb_parts_of_lib_name = - let fndlb_parts cs lib = - let name = - match lib.lib_findlib_name with - | Some nm -> nm - | None -> cs.cs_name - in - let name = - String.concat "." (lib.lib_findlib_containers @ [name]) - in - name - in - List.fold_left - (fun mp -> - function - | Library (cs, _, lib) -> - begin - let lib_name = cs.cs_name in - let fndlb_parts = fndlb_parts cs lib in - if MapString.mem lib_name mp then - failwithf - (f_ "The library name '%s' is used more than once.") - lib_name; - match lib.lib_findlib_parent with - | Some lib_name_parent -> - MapString.add - lib_name - (`Unsolved (lib_name_parent, fndlb_parts)) - mp - | None -> - MapString.add - lib_name - (`Solved fndlb_parts) - mp - end - - | Object (cs, _, obj) -> - begin - let obj_name = cs.cs_name in - if MapString.mem obj_name mp then - failwithf - (f_ "The object name '%s' is used more than once.") - obj_name; - let findlib_full_name = match obj.obj_findlib_fullname with - | Some ns -> String.concat "." ns - | None -> obj_name - in - MapString.add - obj_name - (`Solved findlib_full_name) - mp - end - - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> - mp) - MapString.empty - pkg.sections - in - - (* Solve the above graph to be only library name to full findlib name. *) - let fndlb_name_of_lib_name = - let rec solve visited mp lib_name lib_name_child = - if SetString.mem lib_name visited then - failwithf - (f_ "Library '%s' is involved in a cycle \ - with regard to findlib naming.") - lib_name; - let visited = SetString.add lib_name visited in - try - match MapString.find lib_name mp with - | `Solved fndlb_nm -> - fndlb_nm, mp - | `Unsolved (lib_nm_parent, post_fndlb_nm) -> - let pre_fndlb_nm, mp = - solve visited mp lib_nm_parent lib_name - in - let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in - fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp - with Not_found -> - failwithf - (f_ "Library '%s', which is defined as the findlib parent of \ - library '%s', doesn't exist.") - lib_name lib_name_child - in - let mp = - MapString.fold - (fun lib_name status mp -> - match status with - | `Solved _ -> - (* Solved initialy, no need to go further *) - mp - | `Unsolved _ -> - let _, mp = solve SetString.empty mp lib_name "" in - mp) - fndlb_parts_of_lib_name - fndlb_parts_of_lib_name - in - MapString.map - (function - | `Solved fndlb_nm -> fndlb_nm - | `Unsolved _ -> assert false) - mp - in - - (* Convert an internal library name to a findlib name. *) - let findlib_name_of_library_name lib_nm = - try - MapString.find lib_nm fndlb_name_of_lib_name - with Not_found -> - raise (InternalLibraryNotFound lib_nm) - in - - (* Add a library to the tree. - *) - let add sct mp = - let fndlb_fullname = - let cs, _, _ = sct in - let lib_name = cs.cs_name in - findlib_name_of_library_name lib_name - in - let rec add_children nm_lst (children: tree MapString.t) = - match nm_lst with - | (hd :: tl) -> - begin - let node = - try - add_node tl (MapString.find hd children) - with Not_found -> - (* New node *) - new_node tl - in - MapString.add hd node children - end - | [] -> - (* Should not have a nameless library. *) - assert false - and add_node tl node = - if tl = [] then - begin - match node with - | Node (None, children) -> - Node (Some sct, children) - | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> - (* TODO: allow to merge Package, i.e. - * archive(byte) = "foo.cma foo_init.cmo" - *) - let cs, _, _ = sct in - failwithf - (f_ "Library '%s' and '%s' have the same findlib name '%s'") - cs.cs_name cs'.cs_name fndlb_fullname - end - else - begin - match node with - | Leaf data -> - Node (Some data, add_children tl MapString.empty) - | Node (data_opt, children) -> - Node (data_opt, add_children tl children) - end - and new_node = - function - | [] -> - Leaf sct - | hd :: tl -> - Node (None, MapString.add hd (new_node tl) MapString.empty) - in - add_children (OASISString.nsplit fndlb_fullname '.') mp - in - - let unix_directory dn lib = - let directory = - match lib with - | `Library lib -> lib.lib_findlib_directory - | `Object obj -> obj.obj_findlib_directory - in - match dn, directory with - | None, None -> None - | None, Some dn | Some dn, None -> Some dn - | Some dn1, Some dn2 -> Some (OASISUnixPath.concat dn1 dn2) - in - - let rec group_of_tree dn mp = - MapString.fold - (fun nm node acc -> - let cur = - match node with - | Node (Some (cs, bs, lib), children) -> - let current_dn = unix_directory dn lib in - Package (nm, cs, bs, lib, current_dn, group_of_tree current_dn children) - | Node (None, children) -> - Container (nm, group_of_tree dn children) - | Leaf (cs, bs, lib) -> - let current_dn = unix_directory dn lib in - Package (nm, cs, bs, lib, current_dn, []) - in - cur :: acc) - mp [] - in - - let group_mp = - List.fold_left - (fun mp -> - function - | Library (cs, bs, lib) -> - add (cs, bs, `Library lib) mp - | Object (cs, bs, obj) -> - add (cs, bs, `Object obj) mp - | _ -> - mp) - MapString.empty - pkg.sections - in - - let groups = group_of_tree None group_mp in - - let library_name_of_findlib_name = - lazy begin - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty - end - in - let library_name_of_findlib_name fndlb_nm = - try - MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) - with Not_found -> - raise (FindlibPackageNotFound fndlb_nm) - in - - groups, - findlib_name_of_library_name, - library_name_of_findlib_name - - - let findlib_of_group = - function - | Container (fndlb_nm, _) - | Package (fndlb_nm, _, _, _, _, _) -> fndlb_nm - - - let root_of_group grp = - let rec root_lib_aux = - (* We do a DFS in the group. *) - function - | Container (_, children) -> - List.fold_left - (fun res grp -> - if res = None then - root_lib_aux grp - else - res) - None - children - | Package (_, cs, bs, lib, _, _) -> - Some (cs, bs, lib) - in - match root_lib_aux grp with - | Some res -> - res - | None -> - failwithf - (f_ "Unable to determine root library of findlib library '%s'") - (findlib_of_group grp) - - -end - -module OASISFlag = struct -(* # 22 "src/oasis/OASISFlag.ml" *) - - -end - -module OASISPackage = struct -(* # 22 "src/oasis/OASISPackage.ml" *) - - -end - -module OASISSourceRepository = struct -(* # 22 "src/oasis/OASISSourceRepository.ml" *) - - -end - -module OASISTest = struct -(* # 22 "src/oasis/OASISTest.ml" *) - - -end - -module OASISDocument = struct -(* # 22 "src/oasis/OASISDocument.ml" *) - - -end - -module OASISExec = struct -(* # 22 "src/oasis/OASISExec.ml" *) - - - open OASISGettext - open OASISUtils - open OASISMessage - - - (* TODO: I don't like this quote, it is there because $(rm) foo expands to - * 'rm -f' foo... - *) - let run ~ctxt ?f_exit_code ?(quote=true) cmd args = - let cmd = - if quote then - if Sys.os_type = "Win32" then - if String.contains cmd ' ' then - (* Double the 1st double quote... win32... sigh *) - "\""^(Filename.quote cmd) - else - cmd - else - Filename.quote cmd - else - cmd - in - let cmdline = - String.concat " " (cmd :: args) - in - info ~ctxt (f_ "Running command '%s'") cmdline; - match f_exit_code, Sys.command cmdline with - | None, 0 -> () - | None, i -> - failwithf - (f_ "Command '%s' terminated with error code %d") - cmdline i - | Some f, i -> - f i - - - let run_read_output ~ctxt ?f_exit_code cmd args = - let fn = - Filename.temp_file "oasis-" ".txt" - in - try - begin - let () = - run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) - in - let chn = - open_in fn - in - let routput = - ref [] - in - begin - try - while true do - routput := (input_line chn) :: !routput - done - with End_of_file -> - () - end; - close_in chn; - Sys.remove fn; - List.rev !routput - end - with e -> - (try Sys.remove fn with _ -> ()); - raise e - - - let run_read_one_line ~ctxt ?f_exit_code cmd args = - match run_read_output ~ctxt ?f_exit_code cmd args with - | [fst] -> - fst - | lst -> - failwithf - (f_ "Command return unexpected output %S") - (String.concat "\n" lst) -end - -module OASISFileUtil = struct -(* # 22 "src/oasis/OASISFileUtil.ml" *) - - - open OASISGettext - - - let file_exists_case fn = - let dirname = Filename.dirname fn in - let basename = Filename.basename fn in - if Sys.file_exists dirname then - if basename = Filename.current_dir_name then - true - else - List.mem - basename - (Array.to_list (Sys.readdir dirname)) - else - false - - - let find_file ?(case_sensitive=true) paths exts = - - (* Cardinal product of two list *) - let ( * ) lst1 lst2 = - List.flatten - (List.map - (fun a -> - List.map - (fun b -> a, b) - lst2) - lst1) - in - - let rec combined_paths lst = - match lst with - | p1 :: p2 :: tl -> - let acc = - (List.map - (fun (a, b) -> Filename.concat a b) - (p1 * p2)) - in - combined_paths (acc :: tl) - | [e] -> - e - | [] -> - [] - in - - let alternatives = - List.map - (fun (p, e) -> - if String.length e > 0 && e.[0] <> '.' then - p ^ "." ^ e - else - p ^ e) - ((combined_paths paths) * exts) - in - List.find (fun file -> - (if case_sensitive then - file_exists_case file - else - Sys.file_exists file) - && not (Sys.is_directory file) - ) alternatives - - - let which ~ctxt prg = - let path_sep = - match Sys.os_type with - | "Win32" -> - ';' - | _ -> - ':' - in - let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in - let exec_ext = - match Sys.os_type with - | "Win32" -> - "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) - | _ -> - [""] - in - find_file ~case_sensitive:false [path_lst; [prg]] exec_ext - - - (**/**) - let rec fix_dir dn = - (* Windows hack because Sys.file_exists "src\\" = false when - * Sys.file_exists "src" = true - *) - let ln = - String.length dn - in - if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then - fix_dir (String.sub dn 0 (ln - 1)) - else - dn - - - let q = Filename.quote - (**/**) - - - let cp ~ctxt ?(recurse=false) src tgt = - if recurse then - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt - "xcopy" [q src; q tgt; "/E"] - | _ -> - OASISExec.run ~ctxt - "cp" ["-r"; q src; q tgt] - else - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "copy" - | _ -> "cp") - [q src; q tgt] - - - let mkdir ~ctxt tgt = - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "md" - | _ -> "mkdir") - [q tgt] - - - let rec mkdir_parent ~ctxt f tgt = - let tgt = - fix_dir tgt - in - if Sys.file_exists tgt then - begin - if not (Sys.is_directory tgt) then - OASISUtils.failwithf - (f_ "Cannot create directory '%s', a file of the same name already \ - exists") - tgt - end - else - begin - mkdir_parent ~ctxt f (Filename.dirname tgt); - if not (Sys.file_exists tgt) then - begin - f tgt; - mkdir ~ctxt tgt - end - end - - - let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end else begin - OASISMessage.error ~ctxt - (f_ "Cannot remove directory '%s': not empty.") - tgt - end - - - let glob ~ctxt fn = - let basename = - Filename.basename fn - in - if String.length basename >= 2 && - basename.[0] = '*' && - basename.[1] = '.' then - begin - let ext_len = - (String.length basename) - 2 - in - let ext = - String.sub basename 2 ext_len - in - let dirname = - Filename.dirname fn - in - Array.fold_left - (fun acc fn -> - try - let fn_ext = - String.sub - fn - ((String.length fn) - ext_len) - ext_len - in - if fn_ext = ext then - (Filename.concat dirname fn) :: acc - else - acc - with Invalid_argument _ -> - acc) - [] - (Sys.readdir dirname) - end - else - begin - if file_exists_case fn then - [fn] - else - [] - end -end - - -# 3159 "setup.ml" -module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - - - module MapString = Map.Make(String) - - - type t = string MapString.t - - - let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" - - - let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = - let line = ref 1 in - let lexer st = - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - Genlex.make_lexer ["="] st_line - in - let rec read_file lxr mp = - match Stream.npeek 3 lxr with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; - read_file lxr (MapString.add nm value mp) - | [] -> mp - | _ -> - failwith - (Printf.sprintf "Malformed data file '%s' line %d" filename !line) - in - match stream with - | Some st -> read_file (lexer st) MapString.empty - | None -> - if Sys.file_exists filename then begin - let chn = open_in_bin filename in - let st = Stream.of_channel chn in - try - let mp = read_file (lexer st) MapString.empty in - close_in chn; mp - with e -> - close_in chn; raise e - end else if allow_empty then begin - MapString.empty - end else begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - let rec var_expand str env = - let buff = Buffer.create ((String.length str) * 2) in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = var_expand (MapString.find name env) env - let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst -end - - -# 3239 "setup.ml" -module BaseContext = struct -(* # 22 "src/base/BaseContext.ml" *) - - (* TODO: get rid of this module. *) - open OASISContext - - - let args () = fst (fspecs ()) - - - let default = default - -end - -module BaseMessage = struct -(* # 22 "src/base/BaseMessage.ml" *) - - - (** Message to user, overrid for Base - @author Sylvain Le Gall - *) - open OASISMessage - open BaseContext - - - let debug fmt = debug ~ctxt:!default fmt - - - let info fmt = info ~ctxt:!default fmt - - - let warning fmt = warning ~ctxt:!default fmt - - - let error fmt = error ~ctxt:!default fmt - -end - -module BaseEnv = struct -(* # 22 "src/base/BaseEnv.ml" *) - - open OASISGettext - open OASISUtils - open OASISContext - open PropList - - - module MapString = BaseEnvLight.MapString - - - type origin_t = - | ODefault - | OGetEnv - | OFileLoad - | OCommandLine - - - type cli_handle_t = - | CLINone - | CLIAuto - | CLIWith - | CLIEnable - | CLIUser of (Arg.key * Arg.spec * Arg.doc) list - - - type definition_t = - { - hide: bool; - dump: bool; - cli: cli_handle_t; - arg_help: string option; - group: string option; - } - - - let schema = Schema.create "environment" - - - (* Environment data *) - let env = Data.create () - - - (* Environment data from file *) - let env_from_file = ref MapString.empty - - - (* Lexer for var *) - let var_lxr = Genlex.make_lexer [] - - - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - (* TODO: this is a quick hack to allow calling Test.Command - * without defining executable name really. I.e. if there is - * an exec Executable toto, then $(toto) should be replace - * by its real name. It is however useful to have this function - * for other variable that depend on the host and should be - * written better than that. - *) - let st = - var_lxr (Stream.of_string var) - in - match Stream.npeek 3 st with - | [Genlex.Ident "utoh"; Genlex.Ident nm] -> - OASISHostPath.of_unix (var_get nm) - | [Genlex.Ident "utoh"; Genlex.String s] -> - OASISHostPath.of_unix s - | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> - String.escaped (var_get nm) - | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> - String.escaped s - | [Genlex.Ident nm] -> - var_get nm - | _ -> - failwithf - (f_ "Unknown expression '%s' in variable expansion of %s.") - var - str - with - | Unknown_field (_, _) -> - failwithf - (f_ "No variable %s defined when trying to expand %S.") - var - str - | Stream.Error e -> - failwithf - (f_ "Syntax error when parsing '%s' when trying to \ - expand %S: %s") - var - str - e) - str; - Buffer.contents buff - - - and var_get name = - let vl = - try - Schema.get schema env name - with Unknown_field _ as e -> - begin - try - MapString.find name !env_from_file - with Not_found -> - raise e - end - in - var_expand vl - - - let var_choose ?printer ?name lst = - OASISExpr.choose - ?printer - ?name - var_get - lst - - - let var_protect vl = - let buff = - Buffer.create (String.length vl) - in - String.iter - (function - | '$' -> Buffer.add_string buff "\\$" - | c -> Buffer.add_char buff c) - vl; - Buffer.contents buff - - - let var_define - ?(hide=false) - ?(dump=true) - ?short_desc - ?(cli=CLINone) - ?arg_help - ?group - name (* TODO: type constraint on the fact that name must be a valid OCaml - id *) - dflt = - - let default = - [ - OFileLoad, (fun () -> MapString.find name !env_from_file); - ODefault, dflt; - OGetEnv, (fun () -> Sys.getenv name); - ] - in - - let extra = - { - hide = hide; - dump = dump; - cli = cli; - arg_help = arg_help; - group = group; - } - in - - (* Try to find a value that can be defined - *) - let var_get_low lst = - let errors, res = - List.fold_left - (fun (errors, res) (_, v) -> - if res = None then - begin - try - errors, Some (v ()) - with - | Not_found -> - errors, res - | Failure rsn -> - (rsn :: errors), res - | e -> - (Printexc.to_string e) :: errors, res - end - else - errors, res) - ([], None) - (List.sort - (fun (o1, _) (o2, _) -> - Pervasives.compare o2 o1) - lst) - in - match res, errors with - | Some v, _ -> - v - | None, [] -> - raise (Not_set (name, None)) - | None, lst -> - raise (Not_set (name, Some (String.concat (s_ ", ") lst))) - in - - let help = - match short_desc with - | Some fs -> Some fs - | None -> None - in - - let var_get_lst = - FieldRO.create - ~schema - ~name - ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) - ~print:var_get_low - ~default - ~update:(fun ?context:_ x old_x -> x @ old_x) - ?help - extra - in - - fun () -> - var_expand (var_get_low (var_get_lst env)) - - - let var_redefine - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt = - if Schema.mem schema name then - begin - (* TODO: look suspsicious, we want to memorize dflt not dflt () *) - Schema.set schema env ~context:ODefault name (dflt ()); - fun () -> var_get name - end - else - begin - var_define - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt - end - - - let var_ignore (_: unit -> string) = () - - - let print_hidden = - var_define - ~hide:true - ~dump:false - ~cli:CLIAuto - ~arg_help:"Print even non-printable variable. (debug)" - "print_hidden" - (fun () -> "false") - - - let var_all () = - List.rev - (Schema.fold - (fun acc nm def _ -> - if not def.hide || bool_of_string (print_hidden ()) then - nm :: acc - else - acc) - [] - schema) - - - let default_filename = in_srcdir "setup.data" - - - let load ~ctxt ?(allow_empty=false) ?(filename=default_filename) () = - let open OASISFileSystem in - env_from_file := - let repr_filename = ctxt.srcfs#string_of_filename filename in - if ctxt.srcfs#file_exists filename then begin - let buf = Buffer.create 13 in - defer_close - (ctxt.srcfs#open_in ~mode:binary_in filename) - (read_all buf); - defer_close - (ctxt.srcfs#open_in ~mode:binary_in filename) - (fun rdr -> - OASISMessage.info ~ctxt "Loading environment from %S." repr_filename; - BaseEnvLight.load ~allow_empty - ~filename:(repr_filename) - ~stream:(stream_of_reader rdr) - ()) - end else if allow_empty then begin - BaseEnvLight.MapString.empty - end else begin - failwith - (Printf.sprintf - (f_ "Unable to load environment, the file '%s' doesn't exist.") - repr_filename) - end - - - let unload () = - env_from_file := MapString.empty; - Data.clear env - - - let dump ~ctxt ?(filename=default_filename) () = - let open OASISFileSystem in - defer_close - (ctxt.OASISContext.srcfs#open_out ~mode:binary_out filename) - (fun wrtr -> - let buf = Buffer.create 63 in - let output nm value = - Buffer.add_string buf (Printf.sprintf "%s=%S\n" nm value) - in - let mp_todo = - (* Dump data from schema *) - Schema.fold - (fun mp_todo nm def _ -> - if def.dump then begin - try - output nm (Schema.get schema env nm) - with Not_set _ -> - () - end; - MapString.remove nm mp_todo) - !env_from_file - schema - in - (* Dump data defined outside of schema *) - MapString.iter output mp_todo; - wrtr#output buf) - - let print () = - let printable_vars = - Schema.fold - (fun acc nm def short_descr_opt -> - if not def.hide || bool_of_string (print_hidden ()) then - begin - try - let value = Schema.get schema env nm in - let txt = - match short_descr_opt with - | Some s -> s () - | None -> nm - in - (txt, value) :: acc - with Not_set _ -> - acc - end - else - acc) - [] - schema - in - let max_length = - List.fold_left max 0 - (List.rev_map String.length - (List.rev_map fst printable_vars)) - in - let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in - Printf.printf "\nConfiguration:\n"; - List.iter - (fun (name, value) -> - Printf.printf "%s: %s" name (dot_pad name); - if value = "" then - Printf.printf "\n" - else - Printf.printf " %s\n" value) - (List.rev printable_vars); - Printf.printf "\n%!" - - - let args () = - let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in - [ - "--override", - Arg.Tuple - ( - let rvr = ref "" - in - let rvl = ref "" - in - [ - Arg.Set_string rvr; - Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set - schema - env - ~context:OCommandLine - !rvr - !rvl) - ] - ), - "var+val Override any configuration variable."; - - ] - @ - List.flatten - (Schema.fold - (fun acc name def short_descr_opt -> - let var_set s = - Schema.set - schema - env - ~context:OCommandLine - name - s - in - - let arg_name = - OASISUtils.varname_of_string ~hyphen:'-' name - in - - let hlp = - match short_descr_opt with - | Some txt -> txt () - | None -> "" - in - - let arg_hlp = - match def.arg_help with - | Some s -> s - | None -> "str" - in - - let default_value = - try - Printf.sprintf - (f_ " [%s]") - (Schema.get - schema - env - name) - with Not_set _ -> - "" - in - - let args = - match def.cli with - | CLINone -> - [] - | CLIAuto -> - [ - arg_concat "--" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIWith -> - [ - arg_concat "--with-" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIEnable -> - let dflt = - if default_value = " [true]" then - s_ " [default: enabled]" - else - s_ " [default: disabled]" - in - [ - arg_concat "--enable-" arg_name, - Arg.Unit (fun () -> var_set "true"), - Printf.sprintf (f_ " %s%s") hlp dflt; - - arg_concat "--disable-" arg_name, - Arg.Unit (fun () -> var_set "false"), - Printf.sprintf (f_ " %s%s") hlp dflt - ] - | CLIUser lst -> - lst - in - args :: acc) - [] - schema) -end - -module BaseArgExt = struct -(* # 22 "src/base/BaseArgExt.ml" *) - - - open OASISUtils - open OASISGettext - - - let parse argv args = - (* Simulate command line for Arg *) - let current = - ref 0 - in - - try - Arg.parse_argv - ~current:current - (Array.concat [[|"none"|]; argv]) - (Arg.align args) - (failwithf (f_ "Don't know what to do with arguments: '%s'")) - (s_ "configure options:") - with - | Arg.Help txt -> - print_endline txt; - exit 0 - | Arg.Bad txt -> - prerr_endline txt; - exit 1 -end - -module BaseCheck = struct -(* # 22 "src/base/BaseCheck.ml" *) - - - open BaseEnv - open BaseMessage - open OASISUtils - open OASISGettext - - - let prog_best prg prg_lst = - var_redefine - prg - (fun () -> - let alternate = - List.fold_left - (fun res e -> - match res with - | Some _ -> - res - | None -> - try - Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) - with Not_found -> - None) - None - prg_lst - in - match alternate with - | Some prg -> prg - | None -> raise Not_found) - - - let prog prg = - prog_best prg [prg] - - - let prog_opt prg = - prog_best prg [prg^".opt"; prg] - - - let ocamlfind = - prog "ocamlfind" - - - let version - var_prefix - cmp - fversion - () = - (* Really compare version provided *) - let var = - var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) - in - var_redefine - ~hide:true - var - (fun () -> - let version_str = - match fversion () with - | "[Distributed with OCaml]" -> - begin - try - (var_get "ocaml_version") - with Not_found -> - warning - (f_ "Variable ocaml_version not defined, fallback \ - to default"); - Sys.ocaml_version - end - | res -> - res - in - let version = - OASISVersion.version_of_string version_str - in - if OASISVersion.comparator_apply version cmp then - version_str - else - failwithf - (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") - var_prefix - (OASISVersion.string_of_comparator cmp) - version_str) - () - - - let package_version pkg = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%v"; pkg] - - - let package ?version_comparator pkg () = - let var = - OASISUtils.varname_concat - "pkg_" - (OASISUtils.varname_of_string pkg) - in - let findlib_dir pkg = - let dir = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%d"; pkg] - in - if Sys.file_exists dir && Sys.is_directory dir then - dir - else - failwithf - (f_ "When looking for findlib package %s, \ - directory %s return doesn't exist") - pkg dir - in - let vl = - var_redefine - var - (fun () -> findlib_dir pkg) - () - in - ( - match version_comparator with - | Some ver_cmp -> - ignore - (version - var - ver_cmp - (fun _ -> package_version pkg) - ()) - | None -> - () - ); - vl -end - -module BaseOCamlcConfig = struct -(* # 22 "src/base/BaseOCamlcConfig.ml" *) - - - open BaseEnv - open OASISUtils - open OASISGettext - - - module SMap = Map.Make(String) - - - let ocamlc = - BaseCheck.prog_opt "ocamlc" - - - let ocamlc_config_map = - (* Map name to value for ocamlc -config output - (name ^": "^value) - *) - let rec split_field mp lst = - match lst with - | line :: tl -> - let mp = - try - let pos_semicolon = - String.index line ':' - in - if pos_semicolon > 1 then - ( - let name = - String.sub line 0 pos_semicolon - in - let linelen = - String.length line - in - let value = - if linelen > pos_semicolon + 2 then - String.sub - line - (pos_semicolon + 2) - (linelen - pos_semicolon - 2) - else - "" - in - SMap.add name value mp - ) - else - ( - mp - ) - with Not_found -> - ( - mp - ) - in - split_field mp tl - | [] -> - mp - in - - let cache = - lazy - (var_protect - (Marshal.to_string - (split_field - SMap.empty - (OASISExec.run_read_output - ~ctxt:!BaseContext.default - (ocamlc ()) ["-config"])) - [])) - in - var_redefine - "ocamlc_config_map" - ~hide:true - ~dump:false - (fun () -> - (* TODO: update if ocamlc change !!! *) - Lazy.force cache) - - - let var_define nm = - (* Extract data from ocamlc -config *) - let avlbl_config_get () = - Marshal.from_string - (ocamlc_config_map ()) - 0 - in - let chop_version_suffix s = - try - String.sub s 0 (String.index s '+') - with _ -> - s - in - - let nm_config, value_config = - match nm with - | "ocaml_version" -> - "version", chop_version_suffix - | _ -> nm, (fun x -> x) - in - var_redefine - nm - (fun () -> - try - let map = - avlbl_config_get () - in - let value = - SMap.find nm_config map - in - value_config value - with Not_found -> - failwithf - (f_ "Cannot find field '%s' in '%s -config' output") - nm - (ocamlc ())) - -end - -module BaseStandardVar = struct -(* # 22 "src/base/BaseStandardVar.ml" *) - - - open OASISGettext - open OASISTypes - open BaseCheck - open BaseEnv - - - let ocamlfind = BaseCheck.ocamlfind - let ocamlc = BaseOCamlcConfig.ocamlc - let ocamlopt = prog_opt "ocamlopt" - let ocamlbuild = prog "ocamlbuild" - - - (**/**) - let rpkg = - ref None - - - let pkg_get () = - match !rpkg with - | Some pkg -> pkg - | None -> failwith (s_ "OASIS Package is not set") - - - let var_cond = ref [] - - - let var_define_cond ~since_version f dflt = - let holder = ref (fun () -> dflt) in - let since_version = - OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) - in - var_cond := - (fun ver -> - if OASISVersion.comparator_apply ver since_version then - holder := f ()) :: !var_cond; - fun () -> !holder () - - - (**/**) - - - let pkg_name = - var_define - ~short_desc:(fun () -> s_ "Package name") - "pkg_name" - (fun () -> (pkg_get ()).name) - - - let pkg_version = - var_define - ~short_desc:(fun () -> s_ "Package version") - "pkg_version" - (fun () -> - (OASISVersion.string_of_version (pkg_get ()).version)) - - - let c = BaseOCamlcConfig.var_define - - - let os_type = c "os_type" - let system = c "system" - let architecture = c "architecture" - let ccomp_type = c "ccomp_type" - let ocaml_version = c "ocaml_version" - - - (* TODO: Check standard variable presence at runtime *) - - - let standard_library_default = c "standard_library_default" - let standard_library = c "standard_library" - let standard_runtime = c "standard_runtime" - let bytecomp_c_compiler = c "bytecomp_c_compiler" - let native_c_compiler = c "native_c_compiler" - let model = c "model" - let ext_obj = c "ext_obj" - let ext_asm = c "ext_asm" - let ext_lib = c "ext_lib" - let ext_dll = c "ext_dll" - let default_executable_name = c "default_executable_name" - let systhread_supported = c "systhread_supported" - - - let flexlink = - BaseCheck.prog "flexlink" - - - let flexdll_version = - var_define - ~short_desc:(fun () -> "FlexDLL version (Win32)") - "flexdll_version" - (fun () -> - let lst = - OASISExec.run_read_output ~ctxt:!BaseContext.default - (flexlink ()) ["-help"] - in - match lst with - | line :: _ -> - Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) - | [] -> - raise Not_found) - - - (**/**) - let p name hlp dflt = - var_define - ~short_desc:hlp - ~cli:CLIAuto - ~arg_help:"dir" - name - dflt - - - let (/) a b = - if os_type () = Sys.os_type then - Filename.concat a b - else if os_type () = "Unix" || os_type () = "Cygwin" then - OASISUnixPath.concat a b - else - OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") - (os_type ()) - (**/**) - - - let prefix = - p "prefix" - (fun () -> s_ "Install architecture-independent files dir") - (fun () -> - match os_type () with - | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) - | _ -> - "/usr/local") - - - let exec_prefix = - p "exec_prefix" - (fun () -> s_ "Install architecture-dependent files in dir") - (fun () -> "$prefix") - - - let bindir = - p "bindir" - (fun () -> s_ "User executables") - (fun () -> "$exec_prefix"/"bin") - - - let sbindir = - p "sbindir" - (fun () -> s_ "System admin executables") - (fun () -> "$exec_prefix"/"sbin") - - - let libexecdir = - p "libexecdir" - (fun () -> s_ "Program executables") - (fun () -> "$exec_prefix"/"libexec") - - - let sysconfdir = - p "sysconfdir" - (fun () -> s_ "Read-only single-machine data") - (fun () -> "$prefix"/"etc") - - - let sharedstatedir = - p "sharedstatedir" - (fun () -> s_ "Modifiable architecture-independent data") - (fun () -> "$prefix"/"com") - - - let localstatedir = - p "localstatedir" - (fun () -> s_ "Modifiable single-machine data") - (fun () -> "$prefix"/"var") - - - let libdir = - p "libdir" - (fun () -> s_ "Object code libraries") - (fun () -> "$exec_prefix"/"lib") - - - let datarootdir = - p "datarootdir" - (fun () -> s_ "Read-only arch-independent data root") - (fun () -> "$prefix"/"share") - - - let datadir = - p "datadir" - (fun () -> s_ "Read-only architecture-independent data") - (fun () -> "$datarootdir") - - - let infodir = - p "infodir" - (fun () -> s_ "Info documentation") - (fun () -> "$datarootdir"/"info") - - - let localedir = - p "localedir" - (fun () -> s_ "Locale-dependent data") - (fun () -> "$datarootdir"/"locale") - - - let mandir = - p "mandir" - (fun () -> s_ "Man documentation") - (fun () -> "$datarootdir"/"man") - - - let docdir = - p "docdir" - (fun () -> s_ "Documentation root") - (fun () -> "$datarootdir"/"doc"/"$pkg_name") - - - let htmldir = - p "htmldir" - (fun () -> s_ "HTML documentation") - (fun () -> "$docdir") - - - let dvidir = - p "dvidir" - (fun () -> s_ "DVI documentation") - (fun () -> "$docdir") - - - let pdfdir = - p "pdfdir" - (fun () -> s_ "PDF documentation") - (fun () -> "$docdir") - - - let psdir = - p "psdir" - (fun () -> s_ "PS documentation") - (fun () -> "$docdir") - - - let destdir = - p "destdir" - (fun () -> s_ "Prepend a path when installing package") - (fun () -> - raise - (PropList.Not_set - ("destdir", - Some (s_ "undefined by construct")))) - - - let findlib_version = - var_define - "findlib_version" - (fun () -> - BaseCheck.package_version "findlib") - - - let is_native = - var_define - "is_native" - (fun () -> - try - let _s: string = - ocamlopt () - in - "true" - with PropList.Not_set _ -> - let _s: string = - ocamlc () - in - "false") - - - let ext_program = - var_define - "suffix_program" - (fun () -> - match os_type () with - | "Win32" | "Cygwin" -> ".exe" - | _ -> "") - - - let rm = - var_define - ~short_desc:(fun () -> s_ "Remove a file.") - "rm" - (fun () -> - match os_type () with - | "Win32" -> "del" - | _ -> "rm -f") - - - let rmdir = - var_define - ~short_desc:(fun () -> s_ "Remove a directory.") - "rmdir" - (fun () -> - match os_type () with - | "Win32" -> "rd" - | _ -> "rm -rf") - - - let debug = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") - ~cli:CLIEnable - "debug" - (fun () -> "true") - - - let profile = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") - ~cli:CLIEnable - "profile" - (fun () -> "false") - - - let tests = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> - s_ "Compile tests executable and library and run them") - ~cli:CLIEnable - "tests" - (fun () -> "false")) - "true" - - - let docs = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> s_ "Create documentations") - ~cli:CLIEnable - "docs" - (fun () -> "true")) - "true" - - - let native_dynlink = - var_define - ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") - ~cli:CLINone - "native_dynlink" - (fun () -> - let res = - let ocaml_lt_312 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "3.12.0")) - in - let flexdll_lt_030 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (flexdll_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "0.30")) - in - let has_native_dynlink = - let ocamlfind = ocamlfind () in - try - let fn = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ocamlfind - ["query"; "-predicates"; "native"; "dynlink"; - "-format"; "%d/%a"] - in - Sys.file_exists fn - with _ -> - false - in - if not has_native_dynlink then - false - else if ocaml_lt_312 () then - false - else if (os_type () = "Win32" || os_type () = "Cygwin") - && flexdll_lt_030 () then - begin - BaseMessage.warning - (f_ ".cmxs generation disabled because FlexDLL needs to be \ - at least 0.30. Please upgrade FlexDLL from %s to 0.30.") - (flexdll_version ()); - false - end - else - true - in - string_of_bool res) - - - let init pkg = - rpkg := Some pkg; - List.iter (fun f -> f pkg.oasis_version) !var_cond - -end - -module BaseFileAB = struct -(* # 22 "src/base/BaseFileAB.ml" *) - - - open BaseEnv - open OASISGettext - open BaseMessage - open OASISContext - - - let to_filename fn = - if not (Filename.check_suffix fn ".ab") then - warning (f_ "File '%s' doesn't have '.ab' extension") fn; - OASISFileSystem.of_unix_filename (Filename.chop_extension fn) - - - let replace ~ctxt fn_lst = - let open OASISFileSystem in - let ibuf, obuf = Buffer.create 13, Buffer.create 13 in - List.iter - (fun fn -> - Buffer.clear ibuf; Buffer.clear obuf; - defer_close - (ctxt.srcfs#open_in (of_unix_filename fn)) - (read_all ibuf); - Buffer.add_string obuf (var_expand (Buffer.contents ibuf)); - defer_close - (ctxt.srcfs#open_out (to_filename fn)) - (fun wrtr -> wrtr#output obuf)) - fn_lst -end - -module BaseLog = struct -(* # 22 "src/base/BaseLog.ml" *) - - - open OASISUtils - open OASISContext - open OASISGettext - open OASISFileSystem - - - let default_filename = in_srcdir "setup.log" - - - let load ~ctxt () = - let module SetTupleString = - Set.Make - (struct - type t = string * string - let compare (s11, s12) (s21, s22) = - match String.compare s11 s21 with - | 0 -> String.compare s12 s22 - | n -> n - end) - in - if ctxt.srcfs#file_exists default_filename then begin - defer_close - (ctxt.srcfs#open_in default_filename) - (fun rdr -> - let line = ref 1 in - let lxr = Genlex.make_lexer [] (stream_of_reader rdr) in - let rec read_aux (st, lst) = - match Stream.npeek 2 lxr with - | [Genlex.String e; Genlex.String d] -> - let t = e, d in - Stream.junk lxr; Stream.junk lxr; - if SetTupleString.mem t st then - read_aux (st, lst) - else - read_aux (SetTupleString.add t st, t :: lst) - | [] -> List.rev lst - | _ -> - failwithf - (f_ "Malformed log file '%s' at line %d") - (ctxt.srcfs#string_of_filename default_filename) - !line - in - read_aux (SetTupleString.empty, [])) - end else begin - [] - end - - - let register ~ctxt event data = - defer_close - (ctxt.srcfs#open_out - ~mode:[Open_append; Open_creat; Open_text] - ~perm:0o644 - default_filename) - (fun wrtr -> - let buf = Buffer.create 13 in - Printf.bprintf buf "%S %S\n" event data; - wrtr#output buf) - - - let unregister ~ctxt event data = - let lst = load ~ctxt () in - let buf = Buffer.create 13 in - List.iter - (fun (e, d) -> - if e <> event || d <> data then - Printf.bprintf buf "%S %S\n" e d) - lst; - if Buffer.length buf > 0 then - defer_close - (ctxt.srcfs#open_out default_filename) - (fun wrtr -> wrtr#output buf) - else - ctxt.srcfs#remove default_filename - - - let filter ~ctxt events = - let st_events = SetString.of_list events in - List.filter - (fun (e, _) -> SetString.mem e st_events) - (load ~ctxt ()) - - - let exists ~ctxt event data = - List.exists - (fun v -> (event, data) = v) - (load ~ctxt ()) -end - -module BaseBuilt = struct -(* # 22 "src/base/BaseBuilt.ml" *) - - - open OASISTypes - open OASISGettext - open BaseStandardVar - open BaseMessage - - - type t = - | BExec (* Executable *) - | BExecLib (* Library coming with executable *) - | BLib (* Library *) - | BObj (* Library *) - | BDoc (* Document *) - - - let to_log_event_file t nm = - "built_"^ - (match t with - | BExec -> "exec" - | BExecLib -> "exec_lib" - | BLib -> "lib" - | BObj -> "obj" - | BDoc -> "doc")^ - "_"^nm - - - let to_log_event_done t nm = - "is_"^(to_log_event_file t nm) - - - let register ~ctxt t nm lst = - BaseLog.register ~ctxt (to_log_event_done t nm) "true"; - List.iter - (fun alt -> - let registered = - List.fold_left - (fun registered fn -> - if OASISFileUtil.file_exists_case fn then begin - BaseLog.register ~ctxt - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end else begin - registered - end) - false - alt - in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) - lst - - - let unregister ~ctxt t nm = - List.iter - (fun (e, d) -> BaseLog.unregister ~ctxt e d) - (BaseLog.filter ~ctxt [to_log_event_file t nm; to_log_event_done t nm]) - - - let fold ~ctxt t nm f acc = - List.fold_left - (fun acc (_, fn) -> - if OASISFileUtil.file_exists_case fn then begin - f acc fn - end else begin - warning - (f_ "File '%s' has been marked as built \ - for %s but doesn't exist") - fn - (Printf.sprintf - (match t with - | BExec | BExecLib -> (f_ "executable %s") - | BLib -> (f_ "library %s") - | BObj -> (f_ "object %s") - | BDoc -> (f_ "documentation %s")) - nm); - acc - end) - acc - (BaseLog.filter ~ctxt [to_log_event_file t nm]) - - - let is_built ~ctxt t nm = - List.fold_left - (fun _ (_, d) -> try bool_of_string d with _ -> false) - false - (BaseLog.filter ~ctxt [to_log_event_done t nm]) - - - let of_executable ffn (cs, bs, exec) = - let unix_exec_is, unix_dll_opt = - OASISExecutable.unix_exec_is - (cs, bs, exec) - (fun () -> - bool_of_string - (is_native ())) - ext_dll - ext_program - in - let evs = - (BExec, cs.cs_name, [[ffn unix_exec_is]]) - :: - (match unix_dll_opt with - | Some fn -> - [BExecLib, cs.cs_name, [[ffn fn]]] - | None -> - []) - in - evs, - unix_exec_is, - unix_dll_opt - - - let of_library ffn (cs, bs, lib) = - let unix_lst = - OASISLibrary.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - ~has_native_dynlink:(bool_of_string (native_dynlink ())) - ~ext_lib:(ext_lib ()) - ~ext_dll:(ext_dll ()) - (cs, bs, lib) - in - let evs = - [BLib, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - - - let of_object ffn (cs, bs, obj) = - let unix_lst = - OASISObject.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - (cs, bs, obj) - in - let evs = - [BObj, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - -end - -module BaseCustom = struct -(* # 22 "src/base/BaseCustom.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let run cmd args extra_args = - OASISExec.run ~ctxt:!BaseContext.default ~quote:false - (var_expand cmd) - (List.map - var_expand - (args @ (Array.to_list extra_args))) - - - let hook ?(failsafe=false) cstm f e = - let optional_command lst = - let printer = - function - | Some (cmd, args) -> String.concat " " (cmd :: args) - | None -> s_ "No command" - in - match - var_choose - ~name:(s_ "Pre/Post Command") - ~printer - lst with - | Some (cmd, args) -> - begin - try - run cmd args [||] - with e when failsafe -> - warning - (f_ "Command '%s' fail with error: %s") - (String.concat " " (cmd :: args)) - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - end - | None -> - () - in - let res = - optional_command cstm.pre_command; - f e - in - optional_command cstm.post_command; - res -end - -module BaseDynVar = struct -(* # 22 "src/base/BaseDynVar.ml" *) - - - open OASISTypes - open OASISGettext - open BaseEnv - open BaseBuilt - - - let init ~ctxt pkg = - (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) - (* TODO: provide compile option for library libary_byte_args_VARNAME... *) - List.iter - (function - | Executable (cs, bs, _) -> - if var_choose bs.bs_build then - var_ignore - (var_redefine - (* We don't save this variable *) - ~dump:false - ~short_desc:(fun () -> - Printf.sprintf - (f_ "Filename of executable '%s'") - cs.cs_name) - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - let fn_opt = - fold ~ctxt BExec cs.cs_name (fun _ fn -> Some fn) None - in - match fn_opt with - | Some fn -> fn - | None -> - raise - (PropList.Not_set - (cs.cs_name, - Some (Printf.sprintf - (f_ "Executable '%s' not yet built.") - cs.cs_name))))) - - | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> - ()) - pkg.sections -end - -module BaseTest = struct -(* # 22 "src/base/BaseTest.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let test ~ctxt lst pkg extra_args = - - let one_test (failure, n) (test_plugin, cs, test) = - if var_choose - ~name:(Printf.sprintf - (f_ "test %s run") - cs.cs_name) - ~printer:string_of_bool - test.test_run then - begin - let () = info (f_ "Running test '%s'") cs.cs_name in - let back_cwd = - match test.test_working_directory with - | Some dir -> - let cwd = Sys.getcwd () in - let chdir d = - info (f_ "Changing directory to '%s'") d; - Sys.chdir d - in - chdir dir; - fun () -> chdir cwd - - | None -> - fun () -> () - in - try - let failure_percent = - BaseCustom.hook - test.test_custom - (test_plugin ~ctxt pkg (cs, test)) - extra_args - in - back_cwd (); - (failure_percent +. failure, n + 1) - with e -> - begin - back_cwd (); - raise e - end - end - else - begin - info (f_ "Skipping test '%s'") cs.cs_name; - (failure, n) - end - in - let failed, n = List.fold_left one_test (0.0, 0) lst in - let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in - let msg = - Printf.sprintf - (f_ "Tests had a %.2f%% failure rate") - (100. *. failure_percent) - in - if failure_percent > 0.0 then - failwith msg - else - info "%s" msg; - - (* Possible explanation why the tests where not run. *) - if OASISFeatures.package_test OASISFeatures.flag_tests pkg && - not (bool_of_string (BaseStandardVar.tests ())) && - lst <> [] then - BaseMessage.warning - "Tests are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-tests'" -end - -module BaseDoc = struct -(* # 22 "src/base/BaseDoc.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let doc ~ctxt lst pkg extra_args = - - let one_doc (doc_plugin, cs, doc) = - if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") - cs.cs_name) - ~printer:string_of_bool - doc.doc_build then - begin - info (f_ "Building documentation '%s'") cs.cs_name; - BaseCustom.hook - doc.doc_custom - (doc_plugin ~ctxt pkg (cs, doc)) - extra_args - end - in - List.iter one_doc lst; - - if OASISFeatures.package_test OASISFeatures.flag_docs pkg && - not (bool_of_string (BaseStandardVar.docs ())) && - lst <> [] then - BaseMessage.warning - "Docs are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-docs'" -end - -module BaseSetup = struct -(* # 22 "src/base/BaseSetup.ml" *) - - open OASISContext - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - open OASISUtils - - - type std_args_fun = - ctxt:OASISContext.t -> package -> string array -> unit - - - type ('a, 'b) section_args_fun = - name * - (ctxt:OASISContext.t -> - package -> - (common_section * 'a) -> - string array -> - 'b) - - - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } - - - (* Associate a plugin function with data from package *) - let join_plugin_sections filter_map lst = - List.rev - (List.fold_left - (fun acc sct -> - match filter_map sct with - | Some e -> - e :: acc - | None -> - acc) - [] - lst) - - - (* Search for plugin data associated with a section name *) - let lookup_plugin_section plugin action nm lst = - try - List.assoc nm lst - with Not_found -> - failwithf - (f_ "Cannot find plugin %s matching section %s for %s action") - plugin - nm - action - - - let configure ~ctxt t args = - (* Run configure *) - BaseCustom.hook - t.package.conf_custom - (fun () -> - (* Reload if preconf has changed it *) - begin - try - unload (); - load ~ctxt (); - with _ -> - () - end; - - (* Run plugin's configure *) - t.configure ~ctxt t.package args; - - (* Dump to allow postconf to change it *) - dump ~ctxt ()) - (); - - (* Reload environment *) - unload (); - load ~ctxt (); - - (* Save environment *) - print (); - - (* Replace data in file *) - BaseFileAB.replace ~ctxt t.package.files_ab - - - let build ~ctxt t args = - BaseCustom.hook - t.package.build_custom - (t.build ~ctxt t.package) - args - - - let doc ~ctxt t args = - BaseDoc.doc - ~ctxt - (join_plugin_sections - (function - | Doc (cs, e) -> - Some - (lookup_plugin_section - "documentation" - (s_ "build") - cs.cs_name - t.doc, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let test ~ctxt t args = - BaseTest.test - ~ctxt - (join_plugin_sections - (function - | Test (cs, e) -> - Some - (lookup_plugin_section - "test" - (s_ "run") - cs.cs_name - t.test, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let all ~ctxt t args = - let rno_doc = ref false in - let rno_test = ref false in - let arg_rest = ref [] in - Arg.parse_argv - ~current:(ref 0) - (Array.of_list - ((Sys.executable_name^" all") :: - (Array.to_list args))) - [ - "-no-doc", - Arg.Set rno_doc, - s_ "Don't run doc target"; - - "-no-test", - Arg.Set rno_test, - s_ "Don't run test target"; - - "--", - Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), - s_ "All arguments for configure."; - ] - (failwithf (f_ "Don't know what to do with '%s'")) - ""; - - info "Running configure step"; - configure ~ctxt t (Array.of_list (List.rev !arg_rest)); - - info "Running build step"; - build ~ctxt t [||]; - - (* Load setup.log dynamic variables *) - BaseDynVar.init ~ctxt t.package; - - if not !rno_doc then begin - info "Running doc step"; - doc ~ctxt t [||] - end else begin - info "Skipping doc step" - end; - if not !rno_test then begin - info "Running test step"; - test ~ctxt t [||] - end else begin - info "Skipping test step" - end - - - let install ~ctxt t args = - BaseCustom.hook t.package.install_custom (t.install ~ctxt t.package) args - - - let uninstall ~ctxt t args = - BaseCustom.hook t.package.uninstall_custom (t.uninstall ~ctxt t.package) args - - - let reinstall ~ctxt t args = - uninstall ~ctxt t args; - install ~ctxt t args - - - let clean, distclean = - let failsafe f a = - try - f a - with e -> - warning - (f_ "Action fail with error: %s") - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - in - - let generic_clean ~ctxt t cstm mains docs tests args = - BaseCustom.hook - ~failsafe:true - cstm - (fun () -> - (* Clean section *) - List.iter - (function - | Test (cs, test) -> - let f = - try - List.assoc cs.cs_name tests - with Not_found -> - fun ~ctxt:_ _ _ _ -> () - in - failsafe (f ~ctxt t.package (cs, test)) args - | Doc (cs, doc) -> - let f = - try - List.assoc cs.cs_name docs - with Not_found -> - fun ~ctxt:_ _ _ _ -> () - in - failsafe (f ~ctxt t.package (cs, doc)) args - | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) - t.package.sections; - (* Clean whole package *) - List.iter (fun f -> failsafe (f ~ctxt t.package) args) mains) - () - in - - let clean ~ctxt t args = - generic_clean - ~ctxt - t - t.package.clean_custom - t.clean - t.clean_doc - t.clean_test - args - in - - let distclean ~ctxt t args = - (* Call clean *) - clean ~ctxt t args; - - (* Call distclean code *) - generic_clean - ~ctxt - t - t.package.distclean_custom - t.distclean - t.distclean_doc - t.distclean_test - args; - - (* Remove generated source files. *) - List.iter - (fun fn -> - if ctxt.srcfs#file_exists fn then begin - info (f_ "Remove '%s'") (ctxt.srcfs#string_of_filename fn); - ctxt.srcfs#remove fn - end) - ([BaseEnv.default_filename; BaseLog.default_filename] - @ (List.rev_map BaseFileAB.to_filename t.package.files_ab)) - in - - clean, distclean - - - let version ~ctxt:_ (t: t) _ = print_endline t.oasis_version - - - let update_setup_ml, no_update_setup_ml_cli = - let b = ref true in - b, - ("-no-update-setup-ml", - Arg.Clear b, - s_ " Don't try to update setup.ml, even if _oasis has changed.") - - (* TODO: srcfs *) - let default_oasis_fn = "_oasis" - - - let update_setup_ml t = - let oasis_fn = - match t.oasis_fn with - | Some fn -> fn - | None -> default_oasis_fn - in - let oasis_exec = - match t.oasis_exec with - | Some fn -> fn - | None -> "oasis" - in - let ocaml = - Sys.executable_name - in - let setup_ml, args = - match Array.to_list Sys.argv with - | setup_ml :: args -> - setup_ml, args - | [] -> - failwith - (s_ "Expecting non-empty command line arguments.") - in - let ocaml, setup_ml = - if Sys.executable_name = Sys.argv.(0) then - (* We are not running in standard mode, probably the script - * is precompiled. - *) - "ocaml", "setup.ml" - else - ocaml, setup_ml - in - let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in - let do_update () = - let oasis_exec_version = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | 1 -> - failwithf - (f_ "Executable '%s' is probably an old version \ - of oasis (< 0.3.0), please update to version \ - v%s.") - oasis_exec t.oasis_version - | 127 -> - failwithf - (f_ "Cannot find executable '%s', please install \ - oasis v%s.") - oasis_exec t.oasis_version - | n -> - failwithf - (f_ "Command '%s version' exited with code %d.") - oasis_exec n) - oasis_exec ["version"] - in - if OASISVersion.comparator_apply - (OASISVersion.version_of_string oasis_exec_version) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string t.oasis_version)) then - begin - (* We have a version >= for the executable oasis, proceed with - * update. - *) - (* TODO: delegate this check to 'oasis setup'. *) - if Sys.os_type = "Win32" then - failwithf - (f_ "It is not possible to update the running script \ - setup.ml on Windows. Please update setup.ml by \ - running '%s'.") - (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) - else - begin - OASISExec.run - ~ctxt:!BaseContext.default - ~f_exit_code: - (fun n -> - if n <> 0 then - failwithf - (f_ "Unable to update setup.ml using '%s', \ - please fix the problem and retry.") - oasis_exec) - oasis_exec ("setup" :: t.oasis_setup_args); - OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) - end - end - else - failwithf - (f_ "The version of '%s' (v%s) doesn't match the version of \ - oasis used to generate the %s file. Please install at \ - least oasis v%s.") - oasis_exec oasis_exec_version setup_ml t.oasis_version - in - - if !update_setup_ml then - begin - try - match t.oasis_digest with - | Some dgst -> - if Sys.file_exists oasis_fn && - dgst <> Digest.file default_oasis_fn then - begin - do_update (); - true - end - else - false - | None -> - false - with e -> - error - (f_ "Error when updating setup.ml. If you want to avoid this error, \ - you can bypass the update of %s by running '%s %s %s %s'") - setup_ml ocaml setup_ml no_update_setup_ml_cli - (String.concat " " args); - raise e - end - else - false - - - let setup t = - let catch_exn = ref true in - let act_ref = - ref (fun ~ctxt:_ _ -> - failwithf - (f_ "No action defined, run '%s %s -help'") - Sys.executable_name - Sys.argv.(0)) - - in - let extra_args_ref = ref [] in - let allow_empty_env_ref = ref false in - let arg_handle ?(allow_empty_env=false) act = - Arg.Tuple - [ - Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); - Arg.Unit - (fun () -> - allow_empty_env_ref := allow_empty_env; - act_ref := act); - ] - in - try - let () = - Arg.parse - (Arg.align - ([ - "-configure", - arg_handle ~allow_empty_env:true configure, - s_ "[options*] Configure the whole build process."; - - "-build", - arg_handle build, - s_ "[options*] Build executables and libraries."; - - "-doc", - arg_handle doc, - s_ "[options*] Build documents."; - - "-test", - arg_handle test, - s_ "[options*] Run tests."; - - "-all", - arg_handle ~allow_empty_env:true all, - s_ "[options*] Run configure, build, doc and test targets."; - - "-install", - arg_handle install, - s_ "[options*] Install libraries, data, executables \ - and documents."; - - "-uninstall", - arg_handle uninstall, - s_ "[options*] Uninstall libraries, data, executables \ - and documents."; - - "-reinstall", - arg_handle reinstall, - s_ "[options*] Uninstall and install libraries, data, \ - executables and documents."; - - "-clean", - arg_handle ~allow_empty_env:true clean, - s_ "[options*] Clean files generated by a build."; - - "-distclean", - arg_handle ~allow_empty_env:true distclean, - s_ "[options*] Clean files generated by a build and configure."; - - "-version", - arg_handle ~allow_empty_env:true version, - s_ " Display version of OASIS used to generate this setup.ml."; - - "-no-catch-exn", - Arg.Clear catch_exn, - s_ " Don't catch exception, useful for debugging."; - ] - @ - (if t.setup_update then - [no_update_setup_ml_cli] - else - []) - @ (BaseContext.args ()))) - (failwithf (f_ "Don't know what to do with '%s'")) - (s_ "Setup and run build process current package\n") - in - - (* Instantiate the context. *) - let ctxt = !BaseContext.default in - - (* Build initial environment *) - load ~ctxt ~allow_empty:!allow_empty_env_ref (); - - (** Initialize flags *) - List.iter - (function - | Flag (cs, {flag_description = hlp; - flag_default = choices}) -> - begin - let apply ?short_desc () = - var_ignore - (var_define - ~cli:CLIEnable - ?short_desc - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - string_of_bool - (var_choose - ~name:(Printf.sprintf - (f_ "default value of flag %s") - cs.cs_name) - ~printer:string_of_bool - choices))) - in - match hlp with - | Some hlp -> apply ~short_desc:(fun () -> hlp) () - | None -> apply () - end - | _ -> - ()) - t.package.sections; - - BaseStandardVar.init t.package; - - BaseDynVar.init ~ctxt t.package; - - if not (t.setup_update && update_setup_ml t) then - !act_ref ~ctxt t (Array.of_list (List.rev !extra_args_ref)) - - with e when !catch_exn -> - error "%s" (Printexc.to_string e); - exit 1 - - -end - -module BaseCompat = struct -(* # 22 "src/base/BaseCompat.ml" *) - - (** Compatibility layer to provide a stable API inside setup.ml. - This layer allows OASIS to change in between minor versions - (e.g. 0.4.6 -> 0.4.7) but still provides a stable API inside setup.ml. This - enables to write functions that manipulate setup_t inside setup.ml. See - deps.ml for an example. - - The module opened by default will depend on the version of the _oasis. E.g. - if we have "OASISFormat: 0.3", the module Compat_0_3 will be opened and - the function Compat_0_3 will be called. If setup.ml is generated with the - -nocompat, no module will be opened. - - @author Sylvain Le Gall - *) - - module Compat_0_4 = - struct - let rctxt = ref !BaseContext.default - - module BaseSetup = - struct - module Original = BaseSetup - - open OASISTypes - - type std_args_fun = package -> string array -> unit - type ('a, 'b) section_args_fun = - name * (package -> (common_section * 'a) -> string array -> 'b) - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } - - let setup t = - let mk_std_args_fun f = - fun ~ctxt pkg args -> rctxt := ctxt; f pkg args - in - let mk_section_args_fun l = - List.map - (fun (nm, f) -> - nm, - (fun ~ctxt pkg sct args -> - rctxt := ctxt; - f pkg sct args)) - l - in - let t' = - { - Original. - configure = mk_std_args_fun t.configure; - build = mk_std_args_fun t.build; - doc = mk_section_args_fun t.doc; - test = mk_section_args_fun t.test; - install = mk_std_args_fun t.install; - uninstall = mk_std_args_fun t.uninstall; - clean = List.map mk_std_args_fun t.clean; - clean_doc = mk_section_args_fun t.clean_doc; - clean_test = mk_section_args_fun t.clean_test; - distclean = List.map mk_std_args_fun t.distclean; - distclean_doc = mk_section_args_fun t.distclean_doc; - distclean_test = mk_section_args_fun t.distclean_test; - - package = t.package; - oasis_fn = t.oasis_fn; - oasis_version = t.oasis_version; - oasis_digest = t.oasis_digest; - oasis_exec = t.oasis_exec; - oasis_setup_args = t.oasis_setup_args; - setup_update = t.setup_update; - } - in - Original.setup t' - - end - - let adapt_setup_t setup_t = - let module O = BaseSetup.Original in - let mk_std_args_fun f = fun pkg args -> f ~ctxt:!rctxt pkg args in - let mk_section_args_fun l = - List.map - (fun (nm, f) -> nm, (fun pkg sct args -> f ~ctxt:!rctxt pkg sct args)) - l - in - { - BaseSetup. - configure = mk_std_args_fun setup_t.O.configure; - build = mk_std_args_fun setup_t.O.build; - doc = mk_section_args_fun setup_t.O.doc; - test = mk_section_args_fun setup_t.O.test; - install = mk_std_args_fun setup_t.O.install; - uninstall = mk_std_args_fun setup_t.O.uninstall; - clean = List.map mk_std_args_fun setup_t.O.clean; - clean_doc = mk_section_args_fun setup_t.O.clean_doc; - clean_test = mk_section_args_fun setup_t.O.clean_test; - distclean = List.map mk_std_args_fun setup_t.O.distclean; - distclean_doc = mk_section_args_fun setup_t.O.distclean_doc; - distclean_test = mk_section_args_fun setup_t.O.distclean_test; - - package = setup_t.O.package; - oasis_fn = setup_t.O.oasis_fn; - oasis_version = setup_t.O.oasis_version; - oasis_digest = setup_t.O.oasis_digest; - oasis_exec = setup_t.O.oasis_exec; - oasis_setup_args = setup_t.O.oasis_setup_args; - setup_update = setup_t.O.setup_update; - } - end - - - module Compat_0_3 = - struct - include Compat_0_4 - end - -end - - -# 5662 "setup.ml" -module InternalConfigurePlugin = struct -(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) - - - (** Configure using internal scheme - @author Sylvain Le Gall - *) - - - open BaseEnv - open OASISTypes - open OASISUtils - open OASISGettext - open BaseMessage - - - (** Configure build using provided series of check to be done - and then output corresponding file. - *) - let configure ~ctxt:_ pkg argv = - let var_ignore_eval var = let _s: string = var () in () in - let errors = ref SetString.empty in - let buff = Buffer.create 13 in - - let add_errors fmt = - Printf.kbprintf - (fun b -> - errors := SetString.add (Buffer.contents b) !errors; - Buffer.clear b) - buff - fmt - in - - let warn_exception e = - warning "%s" (Printexc.to_string e) - in - - (* Check tools *) - let check_tools lst = - List.iter - (function - | ExternalTool tool -> - begin - try - var_ignore_eval (BaseCheck.prog tool) - with e -> - warn_exception e; - add_errors (f_ "Cannot find external tool '%s'") tool - end - | InternalExecutable nm1 -> - (* Check that matching tool is built *) - List.iter - (function - | Executable ({cs_name = nm2; _}, - {bs_build = build; _}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal executable \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - lst - in - - let build_checks sct bs = - if var_choose bs.bs_build then - begin - if bs.bs_compiled_object = Native then - begin - try - var_ignore_eval BaseStandardVar.ocamlopt - with e -> - warn_exception e; - add_errors - (f_ "Section %s requires native compilation") - (OASISSection.string_of_section sct) - end; - - (* Check tools *) - check_tools bs.bs_build_tools; - - (* Check depends *) - List.iter - (function - | FindlibPackage (findlib_pkg, version_comparator) -> - begin - try - var_ignore_eval - (BaseCheck.package ?version_comparator findlib_pkg) - with e -> - warn_exception e; - match version_comparator with - | None -> - add_errors - (f_ "Cannot find findlib package %s") - findlib_pkg - | Some ver_cmp -> - add_errors - (f_ "Cannot find findlib package %s (%s)") - findlib_pkg - (OASISVersion.string_of_comparator ver_cmp) - end - | InternalLibrary nm1 -> - (* Check that matching library is built *) - List.iter - (function - | Library ({cs_name = nm2; _}, - {bs_build = build; _}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal library \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - bs.bs_build_depends - end - in - - (* Parse command line *) - BaseArgExt.parse argv (BaseEnv.args ()); - - (* OCaml version *) - begin - match pkg.ocaml_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "ocaml" - ver_cmp - BaseStandardVar.ocaml_version) - with e -> - warn_exception e; - add_errors - (f_ "OCaml version %s doesn't match version constraint %s") - (BaseStandardVar.ocaml_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* Findlib version *) - begin - match pkg.findlib_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "findlib" - ver_cmp - BaseStandardVar.findlib_version) - with e -> - warn_exception e; - add_errors - (f_ "Findlib version %s doesn't match version constraint %s") - (BaseStandardVar.findlib_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - (* Make sure the findlib version is fine for the OCaml compiler. *) - begin - let ocaml_ge4 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.ocaml_version ())) - (OASISVersion.version_of_string "4.0.0") >= 0 in - if ocaml_ge4 then - let findlib_lt132 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) - (OASISVersion.version_of_string "1.3.2") < 0 in - if findlib_lt132 then - add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" - end; - - (* FlexDLL *) - if BaseStandardVar.os_type () = "Win32" || - BaseStandardVar.os_type () = "Cygwin" then - begin - try - var_ignore_eval BaseStandardVar.flexlink - with e -> - warn_exception e; - add_errors (f_ "Cannot find 'flexlink'") - end; - - (* Check build depends *) - List.iter - (function - | Executable (_, bs, _) - | Library (_, bs, _) as sct -> - build_checks sct bs - | Doc (_, doc) -> - if var_choose doc.doc_build then - check_tools doc.doc_build_tools - | Test (_, test) -> - if var_choose test.test_run then - check_tools test.test_tools - | _ -> - ()) - pkg.sections; - - (* Check if we need native dynlink (presence of libraries that compile to - native) - *) - begin - let has_cmxa = - List.exists - (function - | Library (_, bs, _) -> - var_choose bs.bs_build && - (bs.bs_compiled_object = Native || - (bs.bs_compiled_object = Best && - bool_of_string (BaseStandardVar.is_native ()))) - | _ -> - false) - pkg.sections - in - if has_cmxa then - var_ignore_eval BaseStandardVar.native_dynlink - end; - - (* Check errors *) - if SetString.empty != !errors then - begin - List.iter - (fun e -> error "%s" e) - (SetString.elements !errors); - failwithf - (fn_ - "%d configuration error" - "%d configuration errors" - (SetString.cardinal !errors)) - (SetString.cardinal !errors) - end - - -end - -module InternalInstallPlugin = struct -(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) - - - (** Install using internal scheme - @author Sylvain Le Gall - *) - - - (* TODO: rewrite this module with OASISFileSystem. *) - - open BaseEnv - open BaseStandardVar - open BaseMessage - open OASISTypes - open OASISFindlib - open OASISGettext - open OASISUtils - - - let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) - let lib_hook = ref (fun (cs, bs, dn, lib) -> cs, bs, dn, lib, []) - let obj_hook = ref (fun (cs, bs, dn, obj) -> cs, bs, dn, obj, []) - let doc_hook = ref (fun (cs, doc) -> cs, doc) - - let install_file_ev = "install-file" - let install_dir_ev = "install-dir" - let install_findlib_ev = "install-findlib" - - - (* TODO: this can be more generic and used elsewhere. *) - let win32_max_command_line_length = 8000 - - - let split_install_command ocamlfind findlib_name meta files = - if Sys.os_type = "Win32" then - (* Arguments for the first command: *) - let first_args = ["install"; findlib_name; meta] in - (* Arguments for remaining commands: *) - let other_args = ["install"; findlib_name; "-add"] in - (* Extract as much files as possible from [files], [len] is - the current command line length: *) - let rec get_files len acc files = - match files with - | [] -> - (List.rev acc, []) - | file :: rest -> - let len = len + 1 + String.length file in - if len > win32_max_command_line_length then - (List.rev acc, files) - else - get_files len (file :: acc) rest - in - (* Split the command into several commands. *) - let rec split args files = - match files with - | [] -> - [] - | _ -> - (* Length of "ocamlfind install [META|-add]" *) - let len = - List.fold_left - (fun len arg -> - len + 1 (* for the space *) + String.length arg) - (String.length ocamlfind) - args - in - match get_files len [] files with - | ([], _) -> - failwith (s_ "Command line too long.") - | (firsts, others) -> - let cmd = args @ firsts in - (* Use -add for remaining commands: *) - let () = - let findlib_ge_132 = - OASISVersion.comparator_apply - (OASISVersion.version_of_string - (BaseStandardVar.findlib_version ())) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string "1.3.2")) - in - if not findlib_ge_132 then - failwithf - (f_ "Installing the library %s require to use the \ - flag '-add' of ocamlfind because the command \ - line is too long. This flag is only available \ - for findlib 1.3.2. Please upgrade findlib from \ - %s to 1.3.2") - findlib_name (BaseStandardVar.findlib_version ()) - in - let cmds = split other_args others in - cmd :: cmds - in - (* The first command does not use -add: *) - split first_args files - else - ["install" :: findlib_name :: meta :: files] - - - let install = - - let in_destdir fn = - try - (* Practically speaking destdir is prepended at the beginning of the - target filename - *) - (destdir ())^fn - with PropList.Not_set _ -> - fn - in - - let install_file ~ctxt ?(prepend_destdir=true) ?tgt_fn src_file envdir = - let tgt_dir = - if prepend_destdir then in_destdir (envdir ()) else envdir () - in - let tgt_file = - Filename.concat - tgt_dir - (match tgt_fn with - | Some fn -> - fn - | None -> - Filename.basename src_file) - in - (* Create target directory if needed *) - OASISFileUtil.mkdir_parent - ~ctxt - (fun dn -> - info (f_ "Creating directory '%s'") dn; - BaseLog.register ~ctxt install_dir_ev dn) - (Filename.dirname tgt_file); - - (* Really install files *) - info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - OASISFileUtil.cp ~ctxt src_file tgt_file; - BaseLog.register ~ctxt install_file_ev tgt_file - in - - (* Install the files for a library. *) - - let install_lib_files ~ctxt findlib_name files = - let findlib_dir = - let dn = - let findlib_destdir = - OASISExec.run_read_one_line ~ctxt (ocamlfind ()) - ["printconf" ; "destdir"] - in - Filename.concat findlib_destdir findlib_name - in - fun () -> dn - in - let () = - if not (OASISFileUtil.file_exists_case (findlib_dir ())) then - failwithf - (f_ "Directory '%s' doesn't exist for findlib library %s") - (findlib_dir ()) findlib_name - in - let f dir file = - let basename = Filename.basename file in - let tgt_fn = Filename.concat dir basename in - (* Destdir is already include in printconf. *) - install_file ~ctxt ~prepend_destdir:false ~tgt_fn file findlib_dir - in - List.iter (fun (dir, files) -> List.iter (f dir) files) files ; - in - - (* Install data into defined directory *) - let install_data ~ctxt srcdir lst tgtdir = - let tgtdir = - OASISHostPath.of_unix (var_expand tgtdir) - in - List.iter - (fun (src, tgt_opt) -> - let real_srcs = - OASISFileUtil.glob - ~ctxt:!BaseContext.default - (Filename.concat srcdir src) - in - if real_srcs = [] then - failwithf - (f_ "Wildcard '%s' doesn't match any files") - src; - List.iter - (fun fn -> - install_file ~ctxt - fn - (fun () -> - match tgt_opt with - | Some s -> - OASISHostPath.of_unix (var_expand s) - | None -> - tgtdir)) - real_srcs) - lst - in - - let make_fnames modul sufx = - List.fold_right - begin fun sufx accu -> - (OASISString.capitalize_ascii modul ^ sufx) :: - (OASISString.uncapitalize_ascii modul ^ sufx) :: - accu - end - sufx - [] - in - - (** Install all libraries *) - let install_libs ~ctxt pkg = - - let find_first_existing_files_in_path bs lst = - let path = OASISHostPath.of_unix bs.bs_path in - List.find - OASISFileUtil.file_exists_case - (List.map (Filename.concat path) lst) - in - - let files_of_modules new_files typ cs bs modules = - List.fold_left - (fun acc modul -> - begin - try - (* Add uncompiled header from the source tree *) - [find_first_existing_files_in_path - bs (make_fnames modul [".mli"; ".ml"])] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in %s %s") - typ modul cs.cs_name; - [] - end - @ - List.fold_left - (fun acc fn -> - try - find_first_existing_files_in_path bs [fn] :: acc - with Not_found -> - acc) - acc (make_fnames modul [".annot";".cmti";".cmt"])) - new_files - modules - in - - let files_of_build_section (f_data, new_files) typ cs bs = - let extra_files = - List.map - (fun fn -> - try - find_first_existing_files_in_path bs [fn] - with Not_found -> - failwithf - (f_ "Cannot find extra findlib file %S in %s %s ") - fn - typ - cs.cs_name) - bs.bs_findlib_extra_files - in - let f_data () = - (* Install data associated with the library *) - install_data - ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - f_data, new_files @ extra_files - in - - let files_of_library (f_data, acc) data_lib = - let cs, bs, lib, dn, lib_extra = !lib_hook data_lib in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BLib cs.cs_name then begin - (* Start with lib_extra *) - let new_files = lib_extra in - let new_files = - files_of_modules new_files "library" cs bs lib.lib_modules - in - let f_data, new_files = - files_of_build_section (f_data, new_files) "library" cs bs - in - let new_files = - (* Get generated files *) - BaseBuilt.fold - ~ctxt - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - new_files - in - let acc = (dn, new_files) :: acc in - - let f_data () = - (* Install data associated with the library *) - install_data - ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end else begin - (f_data, acc) - end - and files_of_object (f_data, acc) data_obj = - let cs, bs, obj, dn, obj_extra = !obj_hook data_obj in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BObj cs.cs_name then begin - (* Start with obj_extra *) - let new_files = obj_extra in - let new_files = - files_of_modules new_files "object" cs bs obj.obj_modules - in - let f_data, new_files = - files_of_build_section (f_data, new_files) "object" cs bs - in - - let new_files = - (* Get generated files *) - BaseBuilt.fold - ~ctxt - BaseBuilt.BObj - cs.cs_name - (fun acc fn -> fn :: acc) - new_files - in - let acc = (dn, new_files) :: acc in - - let f_data () = - (* Install data associated with the object *) - install_data - ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat (datarootdir ()) pkg.name); - f_data () - in - (f_data, acc) - end else begin - (f_data, acc) - end - in - - (* Install one group of library *) - let install_group_lib grp = - (* Iterate through all group nodes *) - let rec install_group_lib_aux data_and_files grp = - let data_and_files, children = - match grp with - | Container (_, children) -> - data_and_files, children - | Package (_, cs, bs, `Library lib, dn, children) -> - files_of_library data_and_files (cs, bs, lib, dn), children - | Package (_, cs, bs, `Object obj, dn, children) -> - files_of_object data_and_files (cs, bs, obj, dn), children - in - List.fold_left - install_group_lib_aux - data_and_files - children - in - - (* Findlib name of the root library *) - let findlib_name = findlib_of_group grp in - - (* Determine root library *) - let root_lib = root_of_group grp in - - (* All files to install for this library *) - let f_data, files = install_group_lib_aux (ignore, []) grp in - - (* Really install, if there is something to install *) - if files = [] then begin - warning - (f_ "Nothing to install for findlib library '%s'") findlib_name - end else begin - let meta = - (* Search META file *) - let _, bs, _ = root_lib in - let res = Filename.concat bs.bs_path "META" in - if not (OASISFileUtil.file_exists_case res) then - failwithf - (f_ "Cannot find file '%s' for findlib library %s") - res - findlib_name; - res - in - let files = - (* Make filename shorter to avoid hitting command max line length - * too early, esp. on Windows. - *) - (* TODO: move to OASISHostPath as make_relative. *) - let remove_prefix p n = - let plen = String.length p in - let nlen = String.length n in - if plen <= nlen && String.sub n 0 plen = p then begin - let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in - let cutpoint = - plen + - (if plen < nlen && n.[plen] = fn_sep then 1 else 0) - in - String.sub n cutpoint (nlen - cutpoint) - end else begin - n - end - in - List.map - (fun (dir, fn) -> - (dir, List.map (remove_prefix (Sys.getcwd ())) fn)) - files - in - let ocamlfind = ocamlfind () in - let nodir_files, dir_files = - List.fold_left - (fun (nodir, dir) (dn, lst) -> - match dn with - | Some dn -> nodir, (dn, lst) :: dir - | None -> lst @ nodir, dir) - ([], []) - (List.rev files) - in - info (f_ "Installing findlib library '%s'") findlib_name; - List.iter - (OASISExec.run ~ctxt ocamlfind) - (split_install_command ocamlfind findlib_name meta nodir_files); - install_lib_files ~ctxt findlib_name dir_files; - BaseLog.register ~ctxt install_findlib_ev findlib_name - end; - - (* Install data files *) - f_data (); - in - - let group_libs, _, _ = findlib_mapping pkg in - - (* We install libraries in groups *) - List.iter install_group_lib group_libs - in - - let install_execs ~ctxt pkg = - let install_exec data_exec = - let cs, bs, _ = !exec_hook data_exec in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BExec cs.cs_name then begin - let exec_libdir () = Filename.concat (libdir ()) pkg.name in - BaseBuilt.fold - ~ctxt - BaseBuilt.BExec - cs.cs_name - (fun () fn -> - install_file ~ctxt - ~tgt_fn:(cs.cs_name ^ ext_program ()) - fn - bindir) - (); - BaseBuilt.fold - ~ctxt - BaseBuilt.BExecLib - cs.cs_name - (fun () fn -> install_file ~ctxt fn exec_libdir) - (); - install_data ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat (datarootdir ()) pkg.name) - end - in - List.iter - (function - | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) - | _ -> ()) - pkg.sections - in - - let install_docs ~ctxt pkg = - let install_doc data = - let cs, doc = !doc_hook data in - if var_choose doc.doc_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BDoc cs.cs_name then begin - let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in - BaseBuilt.fold - ~ctxt - BaseBuilt.BDoc - cs.cs_name - (fun () fn -> install_file ~ctxt fn (fun () -> tgt_dir)) - (); - install_data ~ctxt - Filename.current_dir_name - doc.doc_data_files - doc.doc_install_dir - end - in - List.iter - (function - | Doc (cs, doc) -> install_doc (cs, doc) - | _ -> ()) - pkg.sections - in - fun ~ctxt pkg _ -> - install_libs ~ctxt pkg; - install_execs ~ctxt pkg; - install_docs ~ctxt pkg - - - (* Uninstall already installed data *) - let uninstall ~ctxt _ _ = - let uninstall_aux (ev, data) = - if ev = install_file_ev then begin - if OASISFileUtil.file_exists_case data then begin - info (f_ "Removing file '%s'") data; - Sys.remove data - end else begin - warning (f_ "File '%s' doesn't exist anymore") data - end - end else if ev = install_dir_ev then begin - if Sys.file_exists data && Sys.is_directory data then begin - if Sys.readdir data = [||] then begin - info (f_ "Removing directory '%s'") data; - OASISFileUtil.rmdir ~ctxt data - end else begin - warning - (f_ "Directory '%s' is not empty (%s)") - data - (String.concat ", " (Array.to_list (Sys.readdir data))) - end - end else begin - warning (f_ "Directory '%s' doesn't exist anymore") data - end - end else if ev = install_findlib_ev then begin - info (f_ "Removing findlib library '%s'") data; - OASISExec.run ~ctxt (ocamlfind ()) ["remove"; data] - end else begin - failwithf (f_ "Unknown log event '%s'") ev; - end; - BaseLog.unregister ~ctxt ev data - in - (* We process event in reverse order *) - List.iter uninstall_aux - (List.rev - (BaseLog.filter ~ctxt [install_file_ev; install_dir_ev])); - List.iter uninstall_aux - (List.rev (BaseLog.filter ~ctxt [install_findlib_ev])) - -end - - -# 6465 "setup.ml" -module OCamlbuildCommon = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) - - - (** Functions common to OCamlbuild build and doc plugin - *) - - - open OASISGettext - open BaseEnv - open BaseStandardVar - open OASISTypes - - - type args = - { - plugin_tags: string option; - extra: string list; - } - - - let ocamlbuild_clean_ev = "ocamlbuild-clean" - - - let ocamlbuildflags = - var_define - ~short_desc:(fun () -> "OCamlbuild additional flags") - "ocamlbuildflags" - (fun () -> "") - - - (** Fix special arguments depending on environment *) - let fix_args args extra_argv = - List.flatten - [ - if (os_type ()) = "Win32" then - [ - "-classic-display"; - "-no-log"; - "-no-links"; - ] - else - []; - - if OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser (OASISVersion.version_of_string "3.11.1")) then - [ - "-install-lib-dir"; - (Filename.concat (standard_library ()) "ocamlbuild") - ] - else - []; - - if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then - [ - "-byte-plugin" - ] - else - []; - - args.extra; - - begin - match args.plugin_tags with - | Some t -> ["-plugin-tag"; Filename.quote t] - | None -> [] - end; - - if bool_of_string (debug ()) then - ["-tag"; "debug"] - else - []; - - if bool_of_string (tests ()) then - ["-tag"; "tests"] - else - []; - - if bool_of_string (profile ()) then - ["-tag"; "profile"] - else - []; - - OASISString.nsplit (ocamlbuildflags ()) ' '; - - Array.to_list extra_argv; - ] - - - (** Run 'ocamlbuild -clean' if not already done *) - let run_clean ~ctxt extra_argv = - let extra_cli = - String.concat " " (Array.to_list extra_argv) - in - (* Run if never called with these args *) - if not (BaseLog.exists ~ctxt ocamlbuild_clean_ev extra_cli) then - begin - OASISExec.run - ~ctxt (ocamlbuild ()) - (fix_args {extra = ["-clean"]; plugin_tags = None} extra_argv); - BaseLog.register ~ctxt ocamlbuild_clean_ev extra_cli; - at_exit - (fun () -> - try - BaseLog.unregister ~ctxt ocamlbuild_clean_ev extra_cli - with _ -> ()) - end - - - (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild ~ctxt args extra_argv = - (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - OASISExec.run ~ctxt (ocamlbuild ()) (fix_args args extra_argv); - (* Remove any clean event, we must run it again *) - List.iter - (fun (e, d) -> BaseLog.unregister ~ctxt e d) - (BaseLog.filter ~ctxt [ocamlbuild_clean_ev]) - - - (** Determine real build directory *) - let build_dir extra_argv = - let rec search_args dir = - function - | "-build-dir" :: dir :: tl -> - search_args dir tl - | _ :: tl -> - search_args dir tl - | [] -> - dir - in - search_args "_build" (fix_args {extra = []; plugin_tags = None} extra_argv) - - -end - -module OCamlbuildPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) - - - (** Build using ocamlbuild - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OASISUtils - open OASISString - open BaseEnv - open OCamlbuildCommon - open BaseStandardVar - - - let cond_targets_hook = ref (fun lst -> lst) - - - let build ~ctxt args pkg argv = - (* Return the filename in build directory *) - let in_build_dir fn = - Filename.concat - (build_dir argv) - fn - in - - (* Return the unix filename in host build directory *) - let in_build_dir_of_unix fn = - in_build_dir (OASISHostPath.of_unix fn) - in - - let cond_targets = - List.fold_left - (fun acc -> - function - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_library - in_build_dir_of_unix - (cs, bs, lib) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ~what:".cma" fn - || ends_with ~what:".cmxs" fn - || ends_with ~what:".cmxa" fn - || ends_with ~what:(ext_lib ()) fn - || ends_with ~what:(ext_dll ()) fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for library %s") - cs.cs_name - end - - | Object (cs, bs, obj) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_object - in_build_dir_of_unix - (cs, bs, obj) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ~what:".cmo" fn - || ends_with ~what:".cmx" fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for object %s") - cs.cs_name - end - - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, _, _ = - BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) - in - - let target ext = - let unix_tgt = - (OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.chop_extension - exec.exec_main_is))^ext - in - let evs = - (* Fix evs, we want to use the unix_tgt, without copying *) - List.map - (function - | BaseBuilt.BExec, nm, _ when nm = cs.cs_name -> - BaseBuilt.BExec, nm, - [[in_build_dir_of_unix unix_tgt]] - | ev -> - ev) - evs - in - evs, [unix_tgt] - in - - (* Add executable *) - let acc = - match bs.bs_compiled_object with - | Native -> - (target ".native") :: acc - | Best when bool_of_string (is_native ()) -> - (target ".native") :: acc - | Byte - | Best -> - (target ".byte") :: acc - in - acc - end - - | Library _ | Object _ | Executable _ | Test _ - | SrcRepo _ | Flag _ | Doc _ -> - acc) - [] - (* Keep the pkg.sections ordered *) - (List.rev pkg.sections); - in - - (* Check and register built files *) - let check_and_register (bt, bnm, lst) = - List.iter - (fun fns -> - if not (List.exists OASISFileUtil.file_exists_case fns) then - failwithf - (fn_ - "Expected built file %s doesn't exist." - "None of expected built files %s exists." - (List.length fns)) - (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) - lst; - (BaseBuilt.register ~ctxt bt bnm lst) - in - - (* Run the hook *) - let cond_targets = !cond_targets_hook cond_targets in - - (* Run a list of target... *) - run_ocamlbuild - ~ctxt - {args with extra = List.flatten (List.map snd cond_targets) @ args.extra} - argv; - (* ... and register events *) - List.iter check_and_register (List.flatten (List.map fst cond_targets)) - - - let clean ~ctxt pkg args = - run_clean ~ctxt args; - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - -end - -module OCamlbuildDocPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) - - - (* Create documentation using ocamlbuild .odocl files - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OCamlbuildCommon - - - type run_t = - { - args: args; - run_path: unix_filename; - } - - - let doc_build ~ctxt run _ (cs, _) argv = - let index_html = - OASISUnixPath.make - [ - run.run_path; - cs.cs_name^".docdir"; - "index.html"; - ] - in - let tgt_dir = - OASISHostPath.make - [ - build_dir argv; - OASISHostPath.of_unix run.run_path; - cs.cs_name^".docdir"; - ] - in - run_ocamlbuild ~ctxt - {run.args with extra = index_html :: run.args.extra} argv; - List.iter - (fun glb -> - match OASISFileUtil.glob ~ctxt (Filename.concat tgt_dir glb) with - | (_ :: _) as filenames -> - BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [filenames] - | [] -> ()) - ["*.html"; "*.css"] - - - let doc_clean ~ctxt _ _ (cs, _) argv = - run_clean ~ctxt argv; - BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name - - -end - - -# 6851 "setup.ml" -module CustomPlugin = struct -(* # 22 "src/plugins/custom/CustomPlugin.ml" *) - - - (** Generate custom configure/build/doc/test/install system - @author - *) - - - open BaseEnv - open OASISGettext - open OASISTypes - - type t = - { - cmd_main: command_line conditional; - cmd_clean: (command_line option) conditional; - cmd_distclean: (command_line option) conditional; - } - - - let run = BaseCustom.run - - - let main ~ctxt:_ t _ extra_args = - let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in - run cmd args extra_args - - - let clean ~ctxt:_ t _ extra_args = - match var_choose t.cmd_clean with - | Some (cmd, args) -> run cmd args extra_args - | _ -> () - - - let distclean ~ctxt:_ t _ extra_args = - match var_choose t.cmd_distclean with - | Some (cmd, args) -> run cmd args extra_args - | _ -> () - - - module Build = - struct - let main ~ctxt t pkg extra_args = - main ~ctxt t pkg extra_args; - List.iter - (fun sct -> - let evs = - match sct with - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, _ = - BaseBuilt.of_library - OASISHostPath.of_unix - (cs, bs, lib) - in - evs - end - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, _, _ = - BaseBuilt.of_executable - OASISHostPath.of_unix - (cs, bs, exec) - in - evs - end - | _ -> - [] - in - List.iter - (fun (bt, bnm, lst) -> BaseBuilt.register ~ctxt bt bnm lst) - evs) - pkg.sections - - let clean ~ctxt t pkg extra_args = - clean ~ctxt t pkg extra_args; - (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild - * considering moving this to BaseSetup? - *) - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - let distclean ~ctxt t pkg extra_args = distclean ~ctxt t pkg extra_args - end - - - module Test = - struct - let main ~ctxt t pkg (cs, _) extra_args = - try - main ~ctxt t pkg extra_args; - 0.0 - with Failure s -> - BaseMessage.warning - (f_ "Test '%s' fails: %s") - cs.cs_name - s; - 1.0 - - let clean ~ctxt t pkg _ extra_args = clean ~ctxt t pkg extra_args - - let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args - end - - - module Doc = - struct - let main ~ctxt t pkg (cs, _) extra_args = - main ~ctxt t pkg extra_args; - BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [] - - let clean ~ctxt t pkg (cs, _) extra_args = - clean ~ctxt t pkg extra_args; - BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name - - let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args - end - - -end - - -# 6983 "setup.ml" -open OASISTypes;; - -let setup_t = - { - BaseSetup.configure = InternalConfigurePlugin.configure; - build = - OCamlbuildPlugin.build - {OCamlbuildCommon.plugin_tags = None; extra = []}; - test = - [ - ("main", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("$test", - [ - "-xmllint"; - "$xmllint"; - "\\\n-testFakeHTML"; - "$testfakehtml"; - "\\\n-testFakeRunner"; - "$testfakerunner"; - "\\\n-testFakeShared"; - "$testfakeshared" - ])) - ]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - doc = - [ - ("api-ounit", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.args = - {OCamlbuildCommon.plugin_tags = None; extra = []}; - run_path = "src/" - }) - ]; - install = InternalInstallPlugin.install; - uninstall = InternalInstallPlugin.uninstall; - clean = [OCamlbuildPlugin.clean]; - clean_test = - [ - ("main", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("$test", - [ - "-xmllint"; - "$xmllint"; - "\\\n-testFakeHTML"; - "$testfakehtml"; - "\\\n-testFakeRunner"; - "$testfakerunner"; - "\\\n-testFakeShared"; - "$testfakeshared" - ])) - ]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - clean_doc = - [ - ("api-ounit", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.args = - {OCamlbuildCommon.plugin_tags = None; extra = []}; - run_path = "src/" - }) - ]; - distclean = []; - distclean_test = - [ - ("main", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("$test", - [ - "-xmllint"; - "$xmllint"; - "\\\n-testFakeHTML"; - "$testfakehtml"; - "\\\n-testFakeRunner"; - "$testfakerunner"; - "\\\n-testFakeShared"; - "$testfakeshared" - ])) - ]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - distclean_doc = []; - package = - { - oasis_version = "0.3"; - ocaml_version = Some (OASISVersion.VGreaterEqual "3.11.0"); - version = "2.0.8"; - license = - OASISLicense.DEP5License - (OASISLicense.DEP5Unit - { - OASISLicense.license = "MIT"; - excption = None; - version = OASISLicense.NoVersion - }); - findlib_version = None; - alpha_features = []; - beta_features = []; - name = "ounit"; - license_file = Some "LICENSE.txt"; - copyrights = - ["(C) 2002-2008 Maas-Maarten Zeeman"; "(C) 2010 OCamlCore SARL"]; - maintainers = []; - authors = ["Maas-Maarten Zeeman"; "Sylvain Le Gall"]; - homepage = Some "http://ounit.forge.ocamlcore.org"; - bugreports = None; - synopsis = "Unit testing framework"; - description = - Some - [ - OASISText.Para - "OUnit is a unit testing framework for OCaml, inspired by the JUnit tool for Java, and the HUnit tool for Haskell."; - OASISText.Para - "More information on [HUnit](http://hunit.sourceforge.net)" - ]; - tags = []; - categories = []; - files_ab = []; - sections = - [ - Library - ({ - cs_name = "oUnitAdvanced"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src"; - bs_compiled_object = Best; - bs_build_depends = [FindlibPackage ("bytes", None)]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - [ - "OUnitUtils"; - "OUnitPropList"; - "OUnitPlugin"; - "OUnitChooser"; - "OUnitResultSummary"; - "OUnitLoggerStd"; - "OUnitLoggerHTML"; - "OUnitLoggerHTMLData"; - "OUnitLoggerJUnit"; - "OUnitAssert"; - "OUnitBracket"; - "OUnitTest"; - "OUnitState"; - "OUnitRunner"; - "OUnitRunnerProcesses"; - "OUnitCore"; - "OUnitLogger"; - "OUnitConf"; - "OUnitShared"; - "OUnitCache"; - "OUnitTestData"; - "OUnitCheckEnv"; - "OUnitDiff" - ]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "oUnit"; - lib_findlib_name = Some "advanced"; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "oUnit"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("unix", None); - InternalLibrary "oUnitAdvanced" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["OUnit"; "OUnit2"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = None; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "oUnitThreads"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("threads", None); - InternalLibrary "oUnit" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["OUnitThreads"]; - lib_pack = false; - lib_internal_modules = ["OUnitRunnerThreads"]; - lib_findlib_parent = Some "oUnit"; - lib_findlib_name = Some "threads"; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Executable - ({ - cs_name = "testFakeHTML"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "tests", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "test"; - bs_compiled_object = Byte; - bs_build_depends = [InternalLibrary "oUnit"]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "testFakeHTML.ml"}); - Executable - ({ - cs_name = "testFakeRunner"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "tests", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "test"; - bs_compiled_object = Byte; - bs_build_depends = - [ - InternalLibrary "oUnit"; - InternalLibrary "oUnitThreads" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "testFakeRunner.ml"}); - Executable - ({ - cs_name = "testFakeShared"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "tests", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "test"; - bs_compiled_object = Byte; - bs_build_depends = - [ - InternalLibrary "oUnit"; - InternalLibrary "oUnitThreads" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "testFakeShared.ml"}); - Executable - ({ - cs_name = "test"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "tests", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "test"; - bs_compiled_object = Byte; - bs_build_depends = - [ - InternalLibrary "oUnit"; - InternalLibrary "oUnitAdvanced"; - FindlibPackage ("str", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "test.ml"}); - Test - ({ - cs_name = "main"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - test_type = (`Test, "custom", Some "0.4"); - test_command = - [ - (OASISExpr.EBool true, - ("$test", - [ - "-xmllint"; - "$xmllint"; - "\\\n-testFakeHTML"; - "$testfakehtml"; - "\\\n-testFakeRunner"; - "$testfakerunner"; - "\\\n-testFakeShared"; - "$testfakeshared" - ])) - ]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); - (OASISExpr.EFlag "tests", true) - ]; - test_tools = - [ - ExternalTool "ocamlbuild"; - InternalExecutable "test"; - InternalExecutable "testFakeHTML"; - InternalExecutable "testFakeRunner"; - ExternalTool "xmllint" - ] - }); - Doc - ({ - cs_name = "api-ounit"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.2"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "API reference for OUnit"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - SrcRepo - ({ - cs_name = "head"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - src_repo_type = Git; - src_repo_location = - "https://github.com/gildor478/ounit.git"; - src_repo_browser = - Some "https://github.com/gildor478/ounit"; - src_repo_module = None; - src_repo_branch = Some "master"; - src_repo_tag = None; - src_repo_subdir = None - }) - ]; - disable_oasis_section = []; - conf_type = (`Configure, "internal", Some "0.4"); - conf_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - build_type = (`Build, "ocamlbuild", Some "0.4"); - build_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - install_type = (`Install, "internal", Some "0.4"); - install_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - uninstall_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - clean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - distclean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - plugins = - [ - (`Extra, "META", Some "0.2"); - (`Extra, "StdFiles", Some "0.2"); - (`Extra, "DevFiles", Some "0.2") - ]; - schema_data = PropList.Data.create (); - plugin_data = [] - }; - oasis_fn = None; - oasis_version = "0.4.11~HEAD"; - oasis_digest = None; - oasis_exec = None; - oasis_setup_args = []; - setup_update = false - };; - -let setup () = BaseSetup.setup setup_t;; - -# 8294 "setup.ml" -let setup_t = BaseCompat.Compat_0_3.adapt_setup_t setup_t -open BaseCompat.Compat_0_3 -(* OASIS_STOP *) -let () = setup ();; diff -Nru ounit-2.0.8/src/api-ounit.odocl ounit-2.2.3/src/api-ounit.odocl --- ounit-2.0.8/src/api-ounit.odocl 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/src/api-ounit.odocl 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 1852896df1df5ea91216b5992e35cb92) -OUnit -OUnit2 -OUnitThreads -OUnitUtils -OUnitPropList -OUnitPlugin -OUnitChooser -OUnitResultSummary -OUnitLoggerStd -OUnitLoggerHTML -OUnitLoggerHTMLData -OUnitLoggerJUnit -OUnitAssert -OUnitBracket -OUnitTest -OUnitState -OUnitRunner -OUnitRunnerProcesses -OUnitCore -OUnitLogger -OUnitConf -OUnitShared -OUnitCache -OUnitTestData -OUnitCheckEnv -OUnitDiff -# OASIS_STOP diff -Nru ounit-2.0.8/src/lib/oUnit/dune ounit-2.2.3/src/lib/oUnit/dune --- ounit-2.0.8/src/lib/oUnit/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/oUnit/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,3 @@ +(documentation + (package ounit) + (mld_files index)) diff -Nru ounit-2.0.8/src/lib/oUnit/index.mld ounit-2.2.3/src/lib/oUnit/index.mld --- ounit-2.0.8/src/lib/oUnit/index.mld 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/oUnit/index.mld 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,4 @@ +{1 OUnit transitional package} + +This is a transitional package for ounit2. Use +{{: ../ounit2/index.html} ounit2 package}. diff -Nru ounit-2.0.8/src/lib/oUnit/META ounit-2.2.3/src/lib/oUnit/META --- ounit-2.0.8/src/lib/oUnit/META 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/oUnit/META 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,13 @@ +description = "Transition package to ounit2" +requires = "ounit2" + +package "threads" ( + description = "Transition package to ounit2.threads" + requires = "ounit2.threads" +) + +package "advanced" ( + description = "Transition package to ounit2.advanced" + requires = "ounit2.advanced" +) + diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/dune ounit-2.2.3/src/lib/ounit2/advanced/dune --- ounit-2.0.8/src/lib/ounit2/advanced/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,10 @@ +(rule + (target oUnitLoggerHTMLData.ml) + (deps (:data_gen ../../../tools/data_gen/data_gen.exe) oUnit.css oUnit.js) + (action (run %{data_gen}))) + +(library + (name oUnitAdvanced) + (public_name ounit2.advanced) + (wrapped false) + (libraries unix bytes stdlib-shims)) diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitAssert.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitAssert.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitAssert.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitAssert.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,350 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open OUnitUtils +open OUnitBracket +open OUnitTest + +let skip_if b msg = + if b then + raise (Skip msg) + +let todo msg = + raise (Todo msg) + +let assert_failure msg = + raise (OUnit_failure msg) + +let assert_bool msg b = + if not b then assert_failure msg + +let assert_string str = + if not (str = "") then assert_failure str + +let assert_equal ?ctxt ?(cmp = ( = )) ?printer ?pp_diff ?msg expected actual = + let get_error_string () = + let res = + buff_format_printf + (fun fmt -> + Format.pp_open_vbox fmt 0; + begin + match msg with + | Some s -> + Format.pp_open_box fmt 0; + Format.pp_print_string fmt s; + Format.pp_close_box fmt (); + Format.pp_print_cut fmt () + | None -> + () + end; + + begin + match printer with + | Some p -> + Format.fprintf fmt + "@[expected: @[%s@]@ but got: @[%s@]@]@," + (p expected) + (p actual) + + | None -> + Format.fprintf fmt "@[not equal@]@," + end; + + begin + match pp_diff with + | Some d -> + Format.fprintf fmt + "@[differences: %a@]@," + d (expected, actual) + + | None -> + () + end; + Format.pp_close_box fmt ()) + in + let len = + String.length res + in + if len > 0 && res.[len - 1] = '\n' then + String.sub res 0 (len - 1) + else + res + in + let logf fmt = + match ctxt with + | Some ctxt -> + OUnitLogger.Test.logf ctxt.test_logger `Info fmt + | None -> + Printf.ksprintf ignore fmt + in + begin + match msg with + | Some str -> + logf "%s" str; + | _ -> + () + end; + begin + match printer with + | Some p -> + logf "Expected: %s" (p expected); + logf "Actual: %s" (p actual) + | _ -> + () + end; + + if not (cmp expected actual) then + assert_failure (get_error_string ()) + +let assert_command + ?(exit_code=Unix.WEXITED 0) + ?(sinput=Stream.of_list []) + ?(foutput=ignore) + ?(use_stderr=true) + ?(backtrace=true) + ?chdir + ?env + ~ctxt + prg args = + + let log_environment_diff () = + let module SetString = Set.Make(struct + type t = string + let compare = String.compare + end) + in + let set_of_array a = + let ss = ref SetString.empty in + for i = 0 to (Array.length a) - 1 do + ss := SetString.add (Array.get a i) !ss + done; + !ss + in + let current_environment = set_of_array (Unix.environment ()) in + let initial_environment = set_of_array ctxt.initial_environment in + if SetString.equal current_environment initial_environment then begin + OUnitLogger.Test.logf ctxt.test_logger `Info + "Environment is the same as original environment."; + end else begin + OUnitLogger.Test.logf ctxt.test_logger `Info + "Environment (diff with original environment):"; + SetString.iter + (fun s -> OUnitLogger.Test.logf ctxt.test_logger `Info "+%s" s) + (SetString.diff current_environment initial_environment); + SetString.iter + (fun s -> OUnitLogger.Test.logf ctxt.test_logger `Info "-%s" s) + (SetString.diff current_environment initial_environment); + end + in + begin + match env with + | Some a when Array.length a = 0 && Sys.os_type = "Win32" -> + OUnitLogger.Test.logf ctxt.test_logger `Info "%s" + ("Using an empty environment on Windows could cause "^ + "failure when running command.") + | _ -> () + end; + + OUnitTest.section_ctxt ctxt + (fun ctxt -> + let (fn_out, chn_out) = bracket_tmpfile ctxt in + let cmd_print fmt = + Format.pp_print_string fmt prg; + List.iter (Format.fprintf fmt "@ %s") args + in + + (* Start the process *) + let in_write = + Unix.dup (Unix.descr_of_out_channel chn_out) + in + let (out_read, out_write) = + Unix.pipe () + in + let err = + if use_stderr then + in_write + else + Unix.stderr + in + let args = + Array.of_list (prg :: args) + in + let env = + let param = "OCAMLRUNPARAM" in + let analyse_and_fix env = + let arr = Array.copy env in + let fixed = ref false in + let new_var = ref "" in + for i = 0 to (Array.length arr) - 1 do + let really_starts, current_value = + OUnitUtils.start_substr ~prefix:(param^"=") arr.(i) + in + if really_starts then begin + (* Rewrite the params. *) + if not (String.contains current_value 'b') then begin + arr.(i) <- param^"="^current_value^"b" + end; + new_var := arr.(i); + fixed := true + end + done; + if !fixed then + arr + else + Array.append arr [|param^"=b"|] + in + if backtrace then begin + (* Analyse of the provided environment. *) + match env with + | Some env -> Some (analyse_and_fix env) + | None -> Some (analyse_and_fix (Unix.environment ())) + end else begin + env + end + in + let command_chdir, in_chdir = + match chdir with + | Some dn -> + dn, + fun f -> + with_bracket ctxt (bracket_chdir dn) + (fun _ _ -> f ()) + | None -> + Sys.getcwd (), fun f -> f () + in + let pid = + OUnitLogger.Test.logf ctxt.test_logger `Info "%s" + (buff_format_printf + (fun fmt -> + Format.fprintf fmt "Starting command '%t'." cmd_print)); + OUnitLogger.Test.logf ctxt.test_logger `Info "Working directory: %S" + command_chdir; + log_environment_diff (); + Unix.set_close_on_exec out_write; + match env with + | Some e -> + in_chdir + (fun () -> + Unix.create_process_env prg args e out_read in_write err) + | None -> + in_chdir + (fun () -> + Unix.create_process prg args out_read in_write err) + in + let () = + Unix.close out_read; + Unix.close in_write + in + let () = + (* Dump sinput into the process stdin *) + let buff = Bytes.make 1 ' ' in + Stream.iter + (fun c -> + let _i : int = + Bytes.set buff 0 c; + Unix.write out_write buff 0 1 + in + ()) + sinput; + Unix.close out_write + in + let _, real_exit_code = + let rec wait_intr () = + try + Unix.waitpid [] pid + with Unix.Unix_error (Unix.EINTR, _, _) -> + wait_intr () + in + wait_intr () + in + (* Dump process output to stderr *) + begin + let chn = open_in fn_out in + let buff = Bytes.make 4096 'X' in + let len = ref (-1) in + while !len <> 0 do + len := input chn buff 0 (Bytes.length buff); + OUnitLogger.Test.raw_printf + ctxt.test_logger "%s" Bytes.(to_string (sub buff 0 !len)); + done; + close_in chn + end; + + (* Check process status *) + assert_equal + ~msg:(buff_format_printf + (fun fmt -> + Format.fprintf fmt + "@[Exit status of command '%t'@]" cmd_print)) + ~printer:string_of_process_status + exit_code + real_exit_code; + + begin + let chn = open_in fn_out in + try + foutput (Stream.of_channel chn) + with e -> + close_in chn; + raise e + end) + +let raises f = + try + let _ = f () in None + with e -> + Some e + +let assert_raises ?msg exn (f: unit -> 'a) = + let pexn = + Printexc.to_string + in + let get_error_string () = + let str = + Format.sprintf + "expected exception %s, but no exception was raised." + (pexn exn) + in + match msg with + | None -> + assert_failure str + + | Some s -> + assert_failure (s^"\n"^str) + in + match raises f with + | None -> + assert_failure (get_error_string ()) + + | Some e -> + assert_equal ?msg ~printer:pexn exn e + diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitBracket.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitBracket.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitBracket.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitBracket.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,145 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open OUnitTest + +type t = (unit -> unit) list + +let create set_up tear_down test_ctxt = + let fixture = set_up test_ctxt in + let tear_down test_ctxt = + tear_down fixture test_ctxt + in + OUnitShared.Mutex.with_lock + test_ctxt.shared test_ctxt.tear_down_mutex + (fun () -> + test_ctxt.tear_down <- tear_down :: test_ctxt.tear_down); + fixture + +let logf logger lvl fmt = OUnitLogger.Test.logf logger lvl fmt + +let bracket_tmpfile ?(prefix="ounit-") ?(suffix=".txt") ?mode test_ctxt = + create + (fun test_ctxt -> + let suffix = "-"^(OUnitTest.get_shard_id test_ctxt)^suffix in + let (fn, chn) = Filename.open_temp_file ?mode prefix suffix in + logf test_ctxt.test_logger `Info "Created a temporary file: %S." fn; + (fn, chn)) + (fun (fn, chn) test_ctxt -> + (try close_out chn with _ -> ()); + try + Sys.remove fn; + logf test_ctxt.test_logger `Info "Removed a temporary file: %S." fn + with _ -> + ()) + test_ctxt + + +let bracket_tmpdir ?(prefix="ounit-") ?(suffix=".dir") test_ctxt = + let max_attempt = 10 in + let rec try_hard_mkdir attempt = + if max_attempt = attempt then begin + OUnitUtils.failwithf + "Unable to create temporary directory after %d attempts." + attempt + end else begin + try + let suffix = "-"^(OUnitTest.get_shard_id test_ctxt)^suffix in + let tmpdn = Filename.temp_file prefix suffix in + Sys.remove tmpdn; + Unix.mkdir tmpdn 0o755; + tmpdn + with Unix.Unix_error (Unix.EEXIST, "mkdir", _) -> + try_hard_mkdir (max_attempt + 1) + end + in + create + (fun test_ctxt -> + let tmpdn = try_hard_mkdir 0 in + logf test_ctxt.test_logger `Info + "Create a temporary directory: %S." tmpdn; + tmpdn) + (fun tmpdn test_ctxt -> + let log_delete fn = + logf test_ctxt.test_logger `Info + "Delete in a temporary directory: %S." fn + in + let safe_run f a = try f a with _ -> () in + let rec rmdir fn = + Array.iter + (fun bn -> + let fn' = Filename.concat fn bn in + let is_dir = + try + let st = Unix.lstat fn' in + st.Unix.st_kind = Unix.S_DIR + with _ -> false + in + if is_dir then begin + rmdir fn'; + safe_run Unix.rmdir fn'; + log_delete fn' + end else begin + safe_run Sys.remove fn'; + log_delete fn' + end) + (try Sys.readdir fn with _ -> [||]) + in + rmdir tmpdn; + safe_run Unix.rmdir tmpdn; + log_delete tmpdn) + test_ctxt + +let chdir_mutex = OUnitShared.Mutex.create OUnitShared.ScopeProcess + +let bracket_chdir dir = + create + (fun test_ctxt -> + let () = + OUnitLogger.infof test_ctxt.logger "Change directory to %S" dir; + try + OUnitShared.Mutex.lock test_ctxt.shared chdir_mutex; + with OUnitShared.Lock_failure -> + failwith "Trying to do a nested chdir." + in + let cur_pwd = Sys.getcwd () in + Unix.chdir dir; + cur_pwd) + (fun cur_pwd test_ctxt -> + Unix.chdir cur_pwd; + OUnitShared.Mutex.unlock test_ctxt.shared chdir_mutex) + +let with_bracket test_ctxt bracket f = + section_ctxt test_ctxt + (fun test_ctxt -> + let res = bracket test_ctxt in + f res test_ctxt) diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitCache.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitCache.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitCache.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitCache.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,89 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open OUnitTest + +type cache = OUnitTest.result MapPath.t + +let cache_filename = + OUnitConf.make_string_subst_opt + "cache_filename" + (* TODO: oUnit-$(name).cache *) + (Some (Filename.concat OUnitUtils.buildir "oUnit-$(suite_name).cache")) + "Cache file to store previous results." + +let default = MapPath.empty + +let load conf = + match cache_filename conf with + | Some fn -> + begin + try + let chn = open_in fn in + let cache : cache = + try + Marshal.from_channel chn + with _ -> + default + in + close_in chn; + cache + with _ -> + default + end + + | None -> + default + +let dump conf cache = + match cache_filename conf with + | Some fn -> + begin + try + let chn = open_out fn in + Marshal.to_channel chn cache []; + close_out chn + with _ -> + () + end + + | None -> + () + +let get_result path cache = + try + Some (MapPath.find path cache) + with Not_found -> + None + +let add_result path result cache = + MapPath.add path result cache diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitCheckEnv.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitCheckEnv.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitCheckEnv.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitCheckEnv.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,109 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + + +(* Check environment after and before tests, to check isolation. *) + +open OUnitTest +open OUnitAssert + +type t = + { + pwd: string; + env: string array; + } + +let create () = + { + pwd = Sys.getcwd (); + env = + let e = Unix.environment () in + if Sys.os_type = "Win32" then begin + let lst = + Array.fold_right + (fun v lst -> + (* On Win32, sometimes an environment variable like: + "=C:=C:\\foobar" will be added. AFAIU, this is the absolute + location in the drive C: and it helps to resolve relative root + path. For example, "C:" which is relative will translate to + "C:\\foobar" in this case. + + We don't take this into account because using "chdir" elsewhere + will change this value in the environment. + + https://devblogs.microsoft.com/oldnewthing/20100506-00/?p=14133 + *) + if OUnitUtils.starts_with ~prefix:"=" v then + lst + else + v :: lst) + e [] + in + Array.of_list lst + end else begin + e + end; + } + +module EnvElement = +struct + type t = string + + let pp_printer = Format.pp_print_string + + let compare = String.compare + + let pp_print_sep = OUnitDiff.pp_comma_separator +end + +module SetEnv = OUnitDiff.SetMake(EnvElement) + +let check test_ctxt t = + let t' = create () in + List.iter + (fun f -> non_fatal test_ctxt (fun _ -> f ())) + [ + (fun () -> + assert_equal + ~msg:"Check that the current working dir hasn't changed during the \ + test." + ~printer:(fun s -> s) + t.pwd + t'.pwd); + (fun () -> + let convert t = SetEnv.of_list (Array.to_list t.env) in + SetEnv.assert_equal + ~msg:"Check that the environment variables haven't changed during \ + the test." + (convert t) + (convert t')); + ] diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitChooser.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitChooser.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitChooser.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitChooser.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,136 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(** + Heuristic to pick a test to run. + + @author Sylvain Le Gall + *) + +open OUnitTest + +type t = + { + tests_planned: path list; + tests_running: path list; + tests_passed: result_list; + cache: OUnitCache.cache; + } + +type choice = + | ChooseToSkip of path + | ChooseToPostpone + | Choose of path + | NoChoice + +let string_of_choice = + function + | ChooseToSkip path -> + Printf.sprintf "ChooseToSkip %S" (string_of_path path) + | ChooseToPostpone -> "ChooseToPostpone" + | Choose path -> + Printf.sprintf "Choose %S" (string_of_path path) + | NoChoice -> "NoChoice" + + +type chooser = t -> choice + +(** Most simple heuristic, just pick the first test. *) +let simple t = + match t.tests_planned with + | hd :: _ -> Choose hd + | [] -> NoChoice + +module Plugin = + OUnitPlugin.Make + (struct + type t = chooser + let name = "chooser" + let conf_help = + "Select the method to choose tests to run." + let default_name = "simple" + let default_value = simple + end) + +include Plugin + +let allskip t = + match t.tests_planned with + | hd :: _ -> ChooseToSkip hd + | [] -> NoChoice + +let failfirst t = + let was_successful = OUnitResultSummary.was_successful in + let rec find_failing = + function + | path :: tl -> + begin + match OUnitCache.get_result path t.cache with + | Some result -> + (* Find the first formerly failing test. *) + if was_successful [path, result, None] then + find_failing tl + else + Choose path + | None -> + Choose path + end + | [] -> + begin + let wait_results_running = + List.fold_left + (fun wait path -> + match OUnitCache.get_result path t.cache with + | Some result -> + (not (was_successful [path, result, None])) || wait + | None -> + (* No former result, we need the result of + * this test. + *) + true) + false t.tests_running + in + if wait_results_running then + (* We need more data about currently running tests. *) + ChooseToPostpone + else if was_successful t.tests_passed then + (* All tests that were red has become green, continue. *) + simple t + else + (* Some tests still fail, skip the rest. *) + allskip t + end + in + find_failing t.tests_planned + +let () = + register "failfirst" ~-1 failfirst diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitConf.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitConf.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitConf.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitConf.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,429 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open OUnitUtils + +exception Parse_error of string + +type conf = OUnitPropList.t + +type 'a var = conf -> 'a + +type metadata = + { + help: string; + get_print: conf -> string; + parse_set: string -> conf -> unit; + cli: conf -> (string * Arg.spec * string) list; + } + +let metaconf = Hashtbl.create 13 + +let check_variable_name str = + let () = + if String.length str = 0 then + failwith "'' is not a valid name." + in + let () = + match str.[0] with + | '0' .. '9' | '_' -> + failwithf + "%S is not a valid variable name. It must not start with %C." + str str.[0] + | _ -> + () + in + String.iter + (function + | 'A' .. 'Z' | 'a' .. 'z' | '_' | '0' .. '9' -> + () + | c -> + failwithf + "%S is not a valid variable name. It must not contain %C." + str c) + str + +let cli_name name = + let replace_underscores str = + let b = Buffer.create (String.length str) in + String.iter + (function + | '_' -> Buffer.add_char b '-' + | c -> Buffer.add_char b c) + str; + Buffer.contents b + in + "-" ^ replace_underscores name + +let subst conf extra_subst str = + let substitutions = Hashtbl.create (Hashtbl.length metaconf) in + let () = + (* Fill the substitutions table. *) + Hashtbl.iter + (fun name metadata -> + Hashtbl.add substitutions name (metadata.get_print conf)) + metaconf; + List.iter (fun (k, v) -> Hashtbl.add substitutions k v) extra_subst + in + let buff = Buffer.create (String.length str) in + Buffer.add_substitute buff + (fun var -> + try + Hashtbl.find substitutions var + with Not_found -> + failwithf "Unknown substitution variable %S in %S." var str) + str; + Buffer.contents buff + +let make ~name ~parse ~print ~default ~help ~fcli () = + let () = + check_variable_name name; + if Hashtbl.mem metaconf name then + failwithf + "Duplicate definition for configuration variable %S." name + in + let set, get = OUnitPropList.new_property default in + let parse_set str conf = set conf (parse str) in + let get_print conf = print (get conf) in + Hashtbl.add metaconf name + {help = help; + get_print = get_print; + parse_set = parse_set; + cli = (fun conf -> fcli (get conf) (set conf))}; + (get: 'a var) + +let make_string name default help = + make + ~name + ~parse:(fun s -> s) + ~print:(fun s -> s) + ~default + ~help + ~fcli: + (fun _ set -> + [cli_name name, + Arg.String set, + "str "^help]) + () + +let make_string_subst name default help = + let get = make_string name default help in + (fun ?(extra_subst=[]) conf -> + subst conf extra_subst (get conf)) + +let make_string_opt name default help = + make + ~name + ~parse: + (function + | "none" -> None + | str -> Some str) + ~print: + (function + | Some x -> x + | None -> "none") + ~default + ~help + ~fcli: + (fun _ set -> + [cli_name name, + Arg.String (fun str -> set (Some str)), + "str "^help; + + cli_name ("no_"^name), + Arg.Unit (fun () -> set None), + Printf.sprintf " Reset value of %s." name]) + () + +let make_string_subst_opt name default opt = + let get = make_string_opt name default opt in + (fun ?(extra_subst=[]) conf -> + match get conf with + | Some str -> Some (subst conf extra_subst str) + | None -> None) + +let make_int name default help = + make + ~name + ~parse: + (fun str -> + try + int_of_string str + with Failure _ -> + raise + (Parse_error + (Printf.sprintf "%S is not an integer." str))) + ~print:string_of_int + ~default + ~help + ~fcli: + (fun _ set -> + [cli_name name, + Arg.Int set, + "i "^help]) + () + +let make_float name default help = + make + ~name + ~parse: + (fun str -> + try + float_of_string str + with Failure _ -> + raise + (Parse_error + (Printf.sprintf "%S is not a float." str))) + ~print:string_of_float + ~default + ~help + ~fcli: + (fun _ set -> + [cli_name name, + Arg.Float set, + "f "^help]) + () + +let make_bool name default help = + make + ~name + ~parse: + (fun str -> + try + bool_of_string str + with Failure _ -> + raise + (Parse_error + (Printf.sprintf "%S is not a boolean (true or false)." str))) + ~print:string_of_bool + ~default + ~help + ~fcli: + (fun _ set -> + [cli_name name, + Arg.Bool set, + "{true|false} "^help]) + () + +let make_enum name get_enums default help = + let parse str = + let enum_lst = get_enums () in + if not (List.exists (fun (str', _) -> str = str') enum_lst) then + raise + (Parse_error + (Printf.sprintf + "%S is not an allowed value for %s." + str name)); + str + in + let get = + make + ~name + ~parse + ~print:(fun s -> s) + ~default + ~help + ~fcli: + (fun _ set -> + [cli_name name, + Arg.Symbol (List.map fst (get_enums ()), set), + " "^help]) + () + in + fun conf -> + try + get conf, List.assoc (get conf) (get_enums ()) + with Not_found -> + failwithf + "Enums list for %s has changed during execution." name + +let make_exec name = + let default = + let pwd = Sys.getcwd () in + let bn = Filename.concat pwd name in + if Sys.file_exists (bn^".native") then + bn^".native" + else if Sys.file_exists (bn^".byte") then + bn^".byte" + else + name + in + make_string name default (Printf.sprintf "Executable %s." name) + +let set ~origin conf name value = + try + (Hashtbl.find metaconf name).parse_set value conf + with + | Not_found -> + failwithf + "Variable %S is not defined in the application.\n%s" name origin + | Parse_error str -> + failwith (str ^ "\n" ^ origin) + +let file_parse conf fn = + let parse lineno line = + let origin = + Printf.sprintf + "File \"%s\", line %d." + fn lineno + in + match trim (trim_comment line) with + | "" -> + () + | str -> + begin + let name, value = + try + Scanf.sscanf str "%s = %S" (fun name value -> name, value) + with Scanf.Scan_failure _ -> + begin + try + Scanf.sscanf str "%s = %s" (fun name value -> name, value) + with Scanf.Scan_failure _ -> + failwithf "Unparseable line: %s\n%s" line origin + end + in + set ~origin conf name value + end + in + let chn = open_in fn in + let lineno = ref 0 in + try + while true do + let line = input_line chn in + incr lineno; + parse !lineno line + done; + () + with + | End_of_file -> + close_in chn + | e -> + close_in chn; + raise e + +let env_parse conf = + let parse name = + let uppercase_name = + let b = Buffer.create (String.length name) in + String.iter + (function + | 'a' .. 'z' as c -> + Buffer.add_char b (Char.chr ((Char.code c) - 32)) + | c -> Buffer.add_char b c) + name; + Buffer.contents b + in + let env_name = "OUNIT_" ^ uppercase_name in + try + let value = Sys.getenv env_name in + (* Check and translate double quoted variable. *) + let value = + try + Scanf.sscanf value "%S" (fun s -> s) + with Scanf.Scan_failure _ -> + value + in + let origin = + Printf.sprintf "Environment variable %s=%S." env_name value + in + set ~origin conf name value + with Not_found -> + () + in + Hashtbl.iter (fun name _ -> parse name) metaconf + +let cli_parse ?argv extra_specs conf = + let specs = + Hashtbl.fold + (fun _ metadata lst -> + let cli_lst = + match metadata.cli conf with + | (key, spec, doc) :: tl -> + (key, spec, doc ^ + (Printf.sprintf " (default: %s)" + (metadata.get_print conf))) + :: tl + | [] -> [] + in + cli_lst @ lst) + metaconf + [] + in + let all_specs = + Arg.align + ([ + "-conf", + Arg.String (file_parse conf), + "fn Read configuration file." + ] + @ (List.sort Stdlib.compare specs) + @ extra_specs) + in + let arg_parse = + match argv with + | Some arr -> + Arg.parse_argv ~current:(ref 0) arr + | None -> + Arg.parse + in + arg_parse + all_specs + (fun x -> raise (Arg.Bad ("Unexpected argument: " ^ x))) + ("usage: " ^ Sys.argv.(0) ^ " options*") + +let default ?(preset=[]) () = + let conf = OUnitPropList.create () in + List.iter + (fun (name, value) -> + set ~origin:"Preset by program." conf name value) + preset; + conf + +(** Load test options from file, environment and command line (in this order). + Not that [extra_specs] is here for historical reason, better use [make] to + create command line options. + *) +let load ?preset ?argv extra_specs = + let conf = default ?preset () in + if Sys.file_exists "ounit.conf" then + file_parse conf "ounit.conf"; + env_parse conf; + cli_parse ?argv extra_specs conf; + conf + +let dump conf = + Hashtbl.fold + (fun name metadata lst -> + (name, metadata.get_print conf) :: lst) + metaconf + [] diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitCore.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitCore.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitCore.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitCore.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,177 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open OUnitUtils +open OUnitTest +open OUnitLogger + +(* Plugin initialisation. *) +let () = + OUnitRunnerProcesses.init () + +(* + * Types and global states. + *) + +(* Run all tests, report starts, errors, failures, and return the results *) +let perform_test conf logger runner chooser test = + let rec flatten_test path acc = + function + | TestCase(l, f) -> + (path, l, f) :: acc + + | TestList (tests) -> + fold_lefti + (fun acc t cnt -> + flatten_test + ((ListItem cnt)::path) + acc t) + acc tests + | TestLabel (label, t) -> + flatten_test ((Label label)::path) acc t + in + let test_cases = + List.rev (flatten_test [] [] test) + in + runner conf logger chooser test_cases + +(* A simple (currently too simple) text based test runner *) +let run_test_tt conf logger runner chooser test = + let () = + Printexc.record_backtrace true + in + + let () = + (* TODO: move into perform test. *) + List.iter + (fun (k, v) -> + OUnitLogger.report logger (GlobalEvent (GConf (k, v)))) + (OUnitConf.dump conf) + in + + (* Now start the test *) + let running_time, test_results = + time_fun (perform_test conf logger runner chooser) test + in + + (* TODO: move into perform test. *) + (* Print test report *) + OUnitLogger.report logger + (GlobalEvent + (GResults (running_time, + test_results, + OUnitTest.test_case_count test))); + + (* Reset logger. *) + OUnitLogger.close logger; + + (* Return the results possibly for further processing *) + test_results + +(* Test-only override. *) +let run_test_tt_main_conf = + ref (fun ?(preset=[]) ?argv extra_specs -> + OUnitConf.load + ?argv + ~preset:(OUnitChooser.preset (OUnitRunner.preset preset)) + extra_specs) + +let suite_name = + OUnitConf.make_string + "suite_name" + "anon" + "The name of the test suite running." + +(* Call this one to act as your main() function. *) +let run_test_tt_main ?(exit=Stdlib.exit) suite = + let only_test = ref [] in + let list_test = ref false in + let extra_specs = + [ + "-only-test", + Arg.String (fun str -> only_test := str :: !only_test), + "path Run only the selected tests."; + + "-list-test", + Arg.Set list_test, + " List tests"; + ] + in + let preset = + match suite with + | OUnitTest.TestLabel (suite_name, _) -> ["suite_name", suite_name] + | OUnitTest.TestCase _ | OUnitTest.TestList _ -> [] + in + let conf = !run_test_tt_main_conf ~preset extra_specs in + if !list_test then + begin + List.iter + (fun pth -> print_endline (OUnitTest.string_of_path pth)) + (OUnitTest.test_case_paths suite) + end + else + begin + let nsuite = + if !only_test = [] then + suite + else + begin + match OUnitTest.test_filter ~skip:true !only_test suite with + | Some test -> + test + | None -> + failwithf + "Filtering test %s lead to no tests." + (String.concat ", " !only_test) + end + in + + let logger = + OUnitLogger.combine + [ + OUnitLoggerStd.create conf shard_default; + OUnitLoggerHTML.create conf; + OUnitLoggerJUnit.create conf; + OUnitLoggerCI.create conf; + ] + in + + let runner_name, runner = OUnitRunner.choice conf in + let chooser_name, chooser = OUnitChooser.choice conf in + let test_results = + OUnitLogger.infof logger "Runner: %s" runner_name; + OUnitLogger.infof logger "Chooser: %s" chooser_name; + run_test_tt conf logger runner chooser nsuite + in + if not (OUnitResultSummary.was_successful test_results) then + exit 1 + end diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnit.css ounit-2.2.3/src/lib/ounit2/advanced/oUnit.css --- ounit-2.0.8/src/lib/ounit2/advanced/oUnit.css 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnit.css 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,145 @@ +/**************************************************************************/ +/* The OUnit library */ +/* */ +/* Copyright (C) 2002-2008 Maas-Maarten Zeeman. */ +/* Copyright (C) 2010 OCamlCore SARL */ +/* Copyright (C) 2013 Sylvain Le Gall */ +/* */ +/* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL */ +/* and Sylvain Le Gall. */ +/* */ +/* Permission is hereby granted, free of charge, to any person obtaining */ +/* a copy of this document and the OUnit software ("the Software"), to */ +/* deal in the Software without restriction, including without limitation */ +/* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages */ +/* or other liability, whether in an action of contract, tort or */ +/* otherwise, arising from, out of or in connection with the Software or */ +/* the use or other dealings in the software. */ +/* */ +/* See LICENSE.txt for details. */ +/**************************************************************************/ + +h1 { + font-size: 26px; + margin-right: 15px; + padding-left: 0px; +} + +h2 { + font-size: 20px; + margin-right: 15px; + padding-left: 5px; +} + +#ounit-current h2 { + text-decoration: underline; +} + +#ounit-results-started-at { + width: 100%; +} + +.ounit-results-content div { + width: 150px; + margin-top: 1px; +} + +.ounit-results-content .number { + text-align: right; + display: inline-block; + float: right; + width: 50px; +} + +.ounit-results-verdict.ounit-failure { + color: red; +} + +.ounit-success h2, +.ounit-results-successes .number { + background-color: #4a4; +} + +.ounit-failure h2, +.ounit-results-failures .number { + background-color: #f66; +} + +.ounit-error h2, +.ounit-results-errors .number { + background-color: #000; + color: #fff; +} + +.ounit-skip h2, +.ounit-results-skips .number { + background-color: #fd0; +} + +.ounit-todo h2, +.ounit-results-todos .number { + background-color: #aaf; +} + +.ounit-timeout h2, +.ounit-results-timeouts .number { + background-color: #888; +} + +.ounit-conf h2, +.ounit-results h2 { + background-color: #aaa; +} + +.ounit-log, +.ounit-conf-content { + font-family: Lucida Console, Monaco, Courier New, monospace; + white-space: nowrap; + font-size: 16px; + color: #666; + margin-left: 20px; +} + +.ounit-duration, +.ounit-started-at, +.ounit-results-content { + margin-bottom: 10px; + margin-left: 15px; +} + +.ounit-started-at { + margin-bottom: 0; +} + +span.ounit-timestamp { + display: inline-block; + width: 70px; +} + +.ounit-log .ounit-result, +.ounit-results-verdict { + font-weight: bold; + margin-top: 5px; +} + +#navigation { + position: fixed; + top: 0; + right: 0; + background-color: #fff; + padding: 9px; + border: 1px solid #000; + border-top: none; + border-right: none; +}; diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitDiff.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitDiff.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitDiff.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitDiff.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,227 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open Format + +module type DIFF_ELEMENT = +sig + type t + + val pp_printer: Format.formatter -> t -> unit + + val compare: t -> t -> int + + val pp_print_sep: Format.formatter -> unit -> unit +end + +module type S = +sig + type e + + type t + + val compare: t -> t -> int + + val pp_printer: Format.formatter -> t -> unit + + val pp_diff: Format.formatter -> (t * t) -> unit + + val assert_equal: ?msg:string -> t -> t -> unit + + val of_list: e list -> t +end + +let assert_equal ?msg compare pp_printer pp_diff exp act = + OUnitAssert.assert_equal + ~cmp:(fun t1 t2 -> (compare t1 t2) = 0) + ~printer:(fun t -> + let buff = Buffer.create 13 in + let fmt = formatter_of_buffer buff in + pp_printer fmt t; + pp_print_flush fmt (); + Buffer.contents buff) + ~pp_diff + ?msg + exp act + +module SetMake (D: DIFF_ELEMENT) : S with type e = D.t = +struct + module Set = Set.Make(D) + + type e = D.t + + type t = Set.t + + let compare = + Set.compare + + let pp_printer fmt t = + let first = ref true in + pp_open_box fmt 0; + Set.iter + (fun e -> + if not !first then + D.pp_print_sep fmt (); + D.pp_printer fmt e; + first := false) + t; + pp_close_box fmt () + + let pp_diff fmt (t1, t2) = + let first = ref true in + let print_list c t = + Set.iter + (fun e -> + if not !first then + D.pp_print_sep fmt (); + pp_print_char fmt c; + D.pp_printer fmt e; + first := false) + t + in + pp_open_box fmt 0; + print_list '+' (Set.diff t2 t1); + print_list '-' (Set.diff t1 t2); + pp_close_box fmt () + + let assert_equal ?msg exp act = + assert_equal ?msg compare pp_printer pp_diff exp act + + let of_list lst = + List.fold_left + (fun acc e -> + Set.add e acc) + Set.empty + lst + +end + +module ListSimpleMake (D: DIFF_ELEMENT) : S + with type e = D.t and type t = D.t list = +struct + type e = D.t + + type t = e list + + let rec compare t1 t2 = + match t1, t2 with + | e1 :: tl1, e2 :: tl2 -> + begin + match D.compare e1 e2 with + | 0 -> + compare tl1 tl2 + | n -> + n + end + + | [], [] -> + 0 + + | _, [] -> + -1 + + | [], _ -> + 1 + + let pp_print_gen pre fmt t = + let first = ref true in + pp_open_box fmt 0; + List.iter + (fun e -> + if not !first then + D.pp_print_sep fmt (); + fprintf fmt "%s%a" pre D.pp_printer e; + first := false) + t; + pp_close_box fmt () + + let pp_printer fmt t = + pp_print_gen "" fmt t + + let pp_diff fmt (t1, t2) = + let rec pp_diff' n t1 t2 = + match t1, t2 with + | e1 :: tl1, e2 :: tl2 -> + begin + match D.compare e1 e2 with + | 0 -> + pp_diff' (n + 1) tl1 tl2 + | _ -> + fprintf fmt + "element number %d differ (%a <> %a)" + n + D.pp_printer e1 + D.pp_printer e2 + end + + | [], [] -> + () + + | [], lst -> + fprintf fmt "at end,@ "; + pp_print_gen "+" fmt lst + + | lst, [] -> + fprintf fmt "at end,@ "; + pp_print_gen "-" fmt lst + in + pp_open_box fmt 0; + pp_diff' 0 t1 t2; + pp_close_box fmt () + + let assert_equal ?msg exp act = + assert_equal ?msg compare pp_printer pp_diff exp act + + let of_list lst = + lst +end + +let pp_comma_separator fmt () = + fprintf fmt ",@ " + +module EString = + struct + type t = string + let compare = String.compare + let pp_printer = Format.pp_print_string + let pp_print_sep = pp_comma_separator +end + +module EInt = +struct + type t = int + let compare = ( - ) + let pp_printer = Format.pp_print_int + let pp_print_sep = pp_comma_separator +end + + diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitDiff.mli ounit-2.2.3/src/lib/ounit2/advanced/oUnitDiff.mli --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitDiff.mli 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitDiff.mli 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,139 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(** Unit tests for collection of elements + + This module allows to define a more precise way to display differences + between collection of elements. When collection differ, the tester is + interested by what are the missing/extra elements. This module provides + a [diff] operation to spot the difference quickly between two sets of + elements. + + Example: +{[ +open OUnit;; + +module EInt = +struct + type t = int + let compare = ( - ) + let pp_printer = Format.pp_print_int + let pp_print_sep = OUnitDiff.pp_comma_separator +end + +module ListInt = OUnitDiff.ListSimpleMake(EInt);; + +let test_diff () = + ListInt.assert_equal + [1; 2; 3; 4; 5] + [1; 2; 5; 4] +;; + +let _ = + run_test_tt_main ("test_diff" >:: test_diff) +;; +]} + +when run this test outputs: +{[ +OUnit: expected: 1, 2, 3, 4, 5 but got: 1, 2, 5, 4 +differences: element number 2 differ (3 <> 5) +]} + + @since 1.1.0 + @author Sylvain Le Gall + *) + +(** {2 Signatures} *) + +(** Definition of an element + *) +module type DIFF_ELEMENT = + sig + (** Type of an element *) + type t + + (** Pretty printer for an element *) + val pp_printer : Format.formatter -> t -> unit + + (** Element comparison *) + val compare : t -> t -> int + + (** Pretty print element separator *) + val pp_print_sep : Format.formatter -> unit -> unit + end + +(** Definition of standard operations + *) +module type S = + sig + (** Type of an element *) + type e + + (** Type of a collection of element *) + type t + + (** Compare a collection of element *) + val compare : t -> t -> int + + (** Pretty printer a collection of element *) + val pp_printer : Format.formatter -> t -> unit + + (** Pretty printer for collection differences *) + val pp_diff : Format.formatter -> t * t -> unit + + (** {!assert_equal} with [~diff], [~cmp] and [~printer] predefined for + this collection events + *) + val assert_equal : ?msg:string -> t -> t -> unit + + (** Create [t] using of list *) + val of_list : e list -> t + end + +(** {2 Implementations} *) + +(** Collection of elements based on a Set, elements order doesn't matter *) +module SetMake : functor (D : DIFF_ELEMENT) -> S + with type e = D.t + +(** Collection of elements based on a List, order matters but difference display + is very simple. It stops at the first element which differs. + *) +module ListSimpleMake : functor (D: DIFF_ELEMENT) -> S + with type e = D.t and type t = D.t list + +val pp_comma_separator : Format.formatter -> unit -> unit + +module EString : DIFF_ELEMENT with type t = string +module EInt : DIFF_ELEMENT with type t = int + diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnit.js ounit-2.2.3/src/lib/ounit2/advanced/oUnit.js --- ounit-2.0.8/src/lib/ounit2/advanced/oUnit.js 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnit.js 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,97 @@ +/**************************************************************************/ +/* The OUnit library */ +/* */ +/* Copyright (C) 2002-2008 Maas-Maarten Zeeman. */ +/* Copyright (C) 2010 OCamlCore SARL */ +/* Copyright (C) 2013 Sylvain Le Gall */ +/* */ +/* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL */ +/* and Sylvain Le Gall. */ +/* */ +/* Permission is hereby granted, free of charge, to any person obtaining */ +/* a copy of this document and the OUnit software ("the Software"), to */ +/* deal in the Software without restriction, including without limitation */ +/* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages */ +/* or other liability, whether in an action of contract, tort or */ +/* otherwise, arising from, out of or in connection with the Software or */ +/* the use or other dealings in the software. */ +/* */ +/* See LICENSE.txt for details. */ +/**************************************************************************/ + +var successHidden = true; + +function displaySuccess(display) { + var div = document.getElementsByClassName('ounit-success'); + for (var i = 0; i < div.length; i++) { + div[i].style.display = display; + }; +}; + +function toggleSuccess() { + if (successHidden) { + displaySuccess('block'); + } else { + displaySuccess('none'); + }; + successHidden = ! successHidden; + var button = document.getElementById('toggleVisibiltySuccess'); + if (successHidden) { + button.textContent = 'Show success'; + } else { + button.textContent = 'Hide success'; + }; +}; + +function resetTestCurrent() { + var div = document.getElementById('ounit-current'); + if (div) { + div.removeAttribute('id'); + }; +}; + +function setTestCurrent(div) { + resetTestCurrent(); + div.id = "ounit-current"; + div.scrollIntoView(true); +}; + +function nextTest() { + var div = document.getElementsByClassName('ounit-test'); + var found = false; + var foundCurrent = false; + var idx = 0; + if (div) { + for (; !found && idx < div.length; idx++) { + if (foundCurrent && div[idx].style.display != 'none') { + found = true; + }; + if (div[idx].id == "ounit-current") { + foundCurrent = true; + }; + }; + if (!foundCurrent && div.length > 0) { + setTestCurrent(div[0]); + } else if (found) { + setTestCurrent(div[idx - 1]); + } else { + resetTestCurrent(); + }; + }; +}; + +function gotoTop() { + window.scrollTo(0,0); + resetTestCurrent(); +}; diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitLoggerCI.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitLoggerCI.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitLoggerCI.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitLoggerCI.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,135 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(* + CI logger for OUnit (Travis, AppVeyor...). + + This logger allows to print results and logs in CI tools like Travis and + AppVeyor. + *) + +open OUnitLogger +open OUnitResultSummary +open OUnitTest + +let printlf color fmt = + let ansi_color = + match color with + | `Red -> "31" + | `Green -> "32" + | `Yellow -> "33" + | `None -> "" + in + Printf.fprintf stdout "\027[%sm" ansi_color; + Printf.kfprintf (fun chn -> Printf.fprintf chn "\027[0m\n") stdout fmt + +let successes_color = `None +let errors_color = `Red +let failures_color = `Red +let skips_color = `Yellow +let todos_color = `Yellow +let timeouts_color = `Red + +let severity = + function + | Some `Error -> `Red, "E" + | Some `Warning -> `Yellow, "W" + | Some `Info -> `None, "I" + | None -> `None, "I" + +let print_separator () = printlf `None "=========================" + +let render conf events = + let smr = OUnitResultSummary.of_log_events conf events in + List.iter + (fun test_data -> + print_separator (); + printlf `None "%s" test_data.test_name; + begin + match test_data.test_result with + | RSuccess -> + printlf successes_color "Success" + | RFailure (str, _, backtrace) -> + printlf failures_color "Failure: %s" str; + begin + match backtrace with + | Some txt -> printlf failures_color "Backtrace: %s" txt + | None -> () + end + | RError (str, backtrace) -> + printlf errors_color "Error: %s" str; + begin + match backtrace with + | Some txt -> printlf errors_color "Backtrace: %s" txt + | None -> () + end + | RSkip str -> + printlf skips_color "Skipped: %s" str; + | RTodo str -> + printlf todos_color "TODO: %s" str; + | RTimeout test_length -> + printlf timeouts_color + "Timeout %.1fs" (delay_of_length test_length) + end; + printlf `None "Logs:"; + List.iter + (fun (tmstp, svrt, str) -> + let color, prefix = severity svrt in + printlf color "%04.1fs %s: %s" tmstp prefix str) + test_data.log_entries; + if List.length test_data.log_entries <> 0 then + printlf `None "%04.1fs I: End" + (test_data.timestamp_end -. test_data.timestamp_start); + ) + (List.filter + (fun test_data -> test_data.test_result <> RSuccess) smr.tests); + print_separator (); + printlf `None "Summary:"; + printlf `None "Tried tests: %d" smr.test_case_count; + printlf `Red "Errors: %d" smr.errors; + printlf `Red "Failures: %d" smr.failures; + printlf `Yellow "Skipped tests: %d" smr.skips; + printlf `Yellow "TODO tests: %d" smr.todos; + printlf `Red "Timed-out tests: %d" smr.timeouts; + () + +let ci = + OUnitConf.make_bool + "ci" + false + "Display logs for CI, like Travis and AppVeyor, in the console with colors." + +let create conf = + if ci conf then + post_logger (render conf) + else + null_logger diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitLoggerHTML.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitLoggerHTML.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitLoggerHTML.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitLoggerHTML.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,256 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(* + HTML logger for OUnit. + *) + +open OUnitLogger +open OUnitUtils +open OUnitTest +open OUnitResultSummary + +let html_escaper str = + let buffer = Buffer.create (String.length str) in + let addc = Buffer.add_char buffer in + let addse se = + addc '&'; + Buffer.add_string buffer se; + addc ';' + in + String.iter + (function + | '"' -> addse "quot" + | '&' -> addse "amp" + | '<' -> addse "lt" + | '>' -> addse "gt" +(* + | 'Œ' -> addse "OElig" + | 'œ' -> addse "oelig" + | 'Š' -> addse "Scaron" + | 'š' -> addse "scaron" + | 'Ÿ' -> addse "Yuml" + | 'ˆ' -> addse "circ" + | '˜' -> addse "tilde" + | ' ' -> addse "ensp" + | ' ' -> addse "emsp" + | ' ' -> addse "thinsp" + | '–' -> addse "ndash" + | '—' -> addse "mdash" + | '‘' -> addse "lsquo" + | '’' -> addse "rsquo" + | '‚' -> addse "sbquo" + | '“' -> addse "ldquo" + | '”' -> addse "rdquo" + | '„' -> addse "bdquo" + | '†' -> addse "dagger" + | '‡' -> addse "Dagger" + | '‰' -> addse "permil" + | '‹' -> addse "lsaquo" + | '›' -> addse "rsaquo" + | '€' -> addse "euro" + *) + | '\'' -> addse "#39" + | c -> addc c) + str; + Buffer.contents buffer + +let render conf dn events = + let smr = + OUnitResultSummary.of_log_events conf events + in + let () = + if not (Sys.file_exists dn) then + Unix.handle_unix_error (fun () -> Unix.mkdir dn 0o755) () + in + + let chn = open_out (Filename.concat dn "oUnit.css") in + let () = + output_string chn OUnitLoggerHTMLData.oUnit_css; + close_out chn + in + + let chn = open_out (Filename.concat dn "oUnit.js") in + let () = + output_string chn OUnitLoggerHTMLData.oUnit_js; + close_out chn + in + + let chn = open_out (Filename.concat dn "index.html") in + let printf fmt = Printf.fprintf chn fmt in + printf "\ + + + Test suite %s + + + + + + +

Test suite %s

+
+

Results

+
\n" + (html_escaper smr.suite_name) smr.charset (html_escaper smr.suite_name); + begin + let printf_result clss label num = + printf + "
\n\ + %s: %d\n\ +
\n" + clss label num + in + let printf_non0_result clss label num = + if num > 0 then + printf_result clss label num + in + printf + "
\ + Started at: %s +
" (date_iso8601 smr.start_at); + printf + "
\ + Total duration: %.3fs\ +
" smr.running_time; + printf_result "test-count" "Tests count" smr.test_case_count; + printf_non0_result "errors" "Errors" smr.errors; + printf_non0_result "failures" "Failures" smr.failures; + printf_non0_result "skips" "Skipped" smr.skips; + printf_non0_result "todos" "TODO" smr.todos; + printf_non0_result "timeouts" "Timed out" smr.timeouts; + printf_result "successes" "Successes" smr.successes; + + (* Print final verdict *) + if was_successful smr.global_results then + printf "
Success
" + else + printf "
Failure
" + end; + + printf "\ +
+
+
+

Configuration

+
\n"; + List.iter + (fun (k, v) -> printf "%s=%S
\n" + (html_escaper k) (html_escaper v)) + smr.conf; + printf ("\ +
+
+"); + List.iter + (fun test_data -> + let class_result, text_result = + match test_data.test_result with + | RSuccess -> "ounit-success", "succeed" + | RFailure _ -> "ounit-failure", "failed" + | RError _ -> "ounit-error", "error" + | RSkip _ -> "ounit-skip", "skipped" + | RTodo _ -> "ounit-todo", "TODO" + | RTimeout _ -> "ounit-timeout", "timeout" + in + let class_severity_opt = + function + | Some `Error -> "ounit-log-error" + | Some `Warning -> "ounit-log-warning" + | Some `Info -> "ounit-log-info" + | None -> "" + in + printf " +
+

%s (%s)

+
Started at: %s
+
Test duration: %.3fs
+
\n" + class_result + (html_escaper test_data.test_name) + (html_escaper text_result) + (date_iso8601 test_data.timestamp_start) + (test_data.timestamp_end -. test_data.timestamp_start); + printf "%.3fsStart
\n" + 0.0; + List.iter (fun (tmstp, svrt, str) -> + printf "\ + + %.3fs%s
\n" + (class_severity_opt svrt) tmstp (html_escaper str)) + test_data.log_entries; + printf "%.3fsEnd
\n" + (test_data.timestamp_end -. test_data.timestamp_start); + printf "
"; + begin + (* TODO: use backtrace *) + match test_data.test_result with + | RSuccess -> printf "Success." + | RFailure (str, _, _) -> + printf "Failure:
%s" (html_escaper str) + | RError (str, _) -> + printf "Error:
%s" (html_escaper str) + | RSkip str -> + printf "Skipped:
%s" (html_escaper str) + | RTodo str -> + printf "Todo:
%s" (html_escaper str) + | RTimeout test_length -> + printf "Timeout after %.1fs
" + (delay_of_length test_length) + end; + printf "
"; + printf "\ +
+
\n"; (* TODO: results, end timestamp *)) + smr.tests; + printf "\ + +"; + close_out chn + +let output_html_dir = + OUnitConf.make_string_subst_opt + "output_html_dir" + None + "Output directory of the HTML files." + +let create conf = + match output_html_dir conf with + | Some dn -> + post_logger (render conf dn) + | None -> + null_logger diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitLoggerJUnit.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitLoggerJUnit.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitLoggerJUnit.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitLoggerJUnit.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,149 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(* + JUnit logger for OUnit. + *) + +open OUnitLogger +open OUnitUtils +open OUnitTest +open OUnitResultSummary + + +let xml_escaper = OUnitLoggerHTML.html_escaper + +let render conf fn events = + let smr = + OUnitResultSummary.of_log_events conf events + in + let chn = open_out fn in + let string_of_failure = + function + | msg, None -> + msg^"\nNo backtrace." + | msg, Some backtrace -> + msg^"\n"^backtrace + in + let printf fmt = Printf.fprintf chn fmt in + printf "\ + + + \n" + smr.charset + (xml_escaper smr.suite_name) + (xml_escaper smr.suite_name) + (xml_escaper (date_iso8601 ~tz:false smr.start_at)) + (xml_escaper (fqdn ())) + smr.test_case_count + (smr.failures + smr.todos) + smr.errors + smr.running_time; + printf "\ +\ \n"; + List.iter + (fun (k, v) -> + printf "\ +\ \n" + (xml_escaper k) (xml_escaper v)) + smr.conf; + printf "\ +\ \n"; + List.iter + (fun test_data -> + printf "\ +\ \n" + (xml_escaper test_data.test_name) + (xml_escaper test_data.test_name) + (test_data.timestamp_end -. test_data.timestamp_start); + begin + match test_data.test_result with + | RSuccess | RSkip _ -> + () + | RError (msg, backtrace) -> + printf "\ +\ %s\n" + (xml_escaper msg) + (xml_escaper (string_of_failure (msg, backtrace))) + | RFailure (msg, _, backtrace) -> + printf "\ +\ %s\n" + (xml_escaper msg) + (xml_escaper (string_of_failure (msg, backtrace))) + | RTodo msg -> + printf "\ +\ \n" + (xml_escaper msg) + | RTimeout test_length -> + printf "\ +\ \n" + (delay_of_length test_length) + end; + printf "\ +\ \n") + smr.tests; + printf "\ +\ \n"; + List.iter + (fun log_event -> + List.iter (fun s -> printf "%s\n" (xml_escaper s)) + (OUnitLoggerStd.format_log_event log_event)) + events; + printf "\ +\ + + + +"; + close_out chn + +let output_junit_file = + OUnitConf.make_string_subst_opt + "output_junit_file" + None + "Output file for JUnit." + +let create conf = + match output_junit_file conf with + | Some fn -> + post_logger (render conf fn) + | None -> + null_logger diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitLogger.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitLogger.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitLogger.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitLogger.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,235 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(* + Logger for information and various OUnit events. + *) + +open OUnitUtils + +(* See OUnit.mli. *) +type position = + { + filename: string; + line: int; + } + +(** See OUnit.mli. *) +type log_severity = [`Error | `Warning | `Info] + +(** See OUnit.mli. *) +type 'result test_event = + | EStart + | EEnd + | EResult of 'result + | ELog of log_severity * string + | ELogRaw of string + +type ('path, 'result) result_full = ('path * 'result * position option) + +(** Events which occur at the global level. *) +type ('path, 'result) global_event = + | GConf of string * string (** Dump a configuration options. *) + | GLog of log_severity * string + | GStart (** Start running the tests. *) + | GEnd (** Finish running the tests. *) + | GResults of (float * ('path, 'result) result_full list * int) + +type ('path, 'result) log_event_t = + | GlobalEvent of ('path, 'result) global_event + | TestEvent of 'path * 'result test_event + +type ('path, 'result) log_event = + { + shard: string; + timestamp: float; + event: ('path, 'result) log_event_t; + } + +type ('path, 'result) logger = + { + lshard: string; + fwrite: ('path, 'result) log_event -> unit; + fpos: unit -> position option; + fclose: unit -> unit; + } + +let shard_default = OUnitUtils.shardf 0 + +let string_of_event ev = + let spf fmt = Printf.sprintf fmt in + let string_of_log_severity = + function + | `Error -> "`Error" + | `Warning -> "`Warning" + | `Info -> "`Info" + in + match ev with + | GlobalEvent e -> + begin + match e with + | GConf (k, v) -> spf "GConf (%S, %S)" k v + | GLog (lvl, s) -> + spf "GLog (%s, %S)" (string_of_log_severity lvl) s + | GStart -> "GStart" + | GEnd -> "GEnd" + | GResults _ -> "GResults" + end + | TestEvent (_, e) -> + begin + match e with + | EStart -> + "EStart" + | EEnd -> + "EEnd" + | EResult _ -> + "EResult (_)" + | ELog (lvl, str) -> + spf "ELog (%s, %S)" (string_of_log_severity lvl) str + | ELogRaw str -> + spf "ELogRaw %S" str + end + + +let null_logger = + { + lshard = shard_default; + fwrite = ignore; + fpos = (fun () -> None); + fclose = ignore; + } + + +let fun_logger fwrite fclose = + { + lshard = shard_default; + fwrite = (fun log_ev -> fwrite log_ev); + fpos = (fun () -> None); + fclose = fclose; + } + +let post_logger fpost = + let data = ref [] in + let fwrite ev = data := ev :: !data in + let fclose () = fpost (List.rev !data) in + { + lshard = shard_default; + fwrite = fwrite; + fpos = (fun () -> None); + fclose = fclose; + } + +let set_shard shard logger = + {logger with lshard = shard} + +let report logger ev = + logger.fwrite + { + shard = logger.lshard; + timestamp = now (); + event = ev; + } + +let infof logger fmt = + Printf.ksprintf + (fun str -> report logger (GlobalEvent (GLog (`Info, str)))) + fmt + +let warningf logger fmt = + Printf.ksprintf + (fun str -> report logger (GlobalEvent (GLog (`Warning, str)))) + fmt + +let errorf logger fmt = + Printf.ksprintf + (fun str -> report logger (GlobalEvent (GLog (`Error, str)))) + fmt + +let position logger = + logger.fpos () + +let close logger = + logger.fclose () + +let combine lst = + let rec fpos = + function + | logger :: tl -> + begin + match position logger with + | Some _ as pos -> + pos + | None -> + fpos tl + end + | [] -> + None + in + let lshard = + match lst with hd :: _ -> hd.lshard | [] -> shard_default + in + { + lshard = lshard; + fwrite = + (fun log_ev -> + List.iter + (fun logger -> + logger.fwrite log_ev) lst); + fpos = (fun () -> fpos lst); + fclose = + (fun () -> + List.iter (fun logger -> close logger) (List.rev lst)); + } + +module Test = +struct + type 'result t = 'result test_event -> unit + + let create logger path = + fun ev -> + logger.fwrite + { + shard = logger.lshard; + timestamp = now (); + event = TestEvent (path, ev) + } + + let raw_printf t fmt = + Printf.ksprintf + (fun s -> t (ELogRaw s)) + fmt + + let logf t lvl fmt = + Printf.ksprintf + (fun s -> t (ELog (lvl, s))) + fmt +end diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitLoggerStd.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitLoggerStd.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitLoggerStd.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitLoggerStd.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,325 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open OUnitLogger +open OUnitTest +open OUnitResultSummary + +let ocaml_position pos = + Printf.sprintf + "File \"%s\", line %d, characters 1-1:" + pos.filename pos.line + +let multiline f str = + if String.length str > 0 then + let buf = Buffer.create 80 in + let flush () = f (Buffer.contents buf); Buffer.clear buf in + String.iter + (function '\n' -> flush () | c -> Buffer.add_char buf c) + str; + flush () + +let count results f = + List.fold_left + (fun count (_, test_result, _) -> + if f test_result then count + 1 else count) + 0 results + +(* TODO: deprecate in 2.1.0. *) +let results_style_1_X = + OUnitConf.make_bool + "results_style_1_X" + false + "Use OUnit 1.X results printer (will be deprecated in 2.1.0+)." + +let format_display_event conf log_event = + match log_event.event with + | GlobalEvent e -> + begin + match e with + | GConf (_, _) | GLog _ | GStart | GEnd -> "" + | GResults (running_time, results, test_case_count) -> + let separator1 = String.make (Format.get_margin ()) '=' in + let separator2 = String.make (Format.get_margin ()) '-' in + let buf = Buffer.create 1024 in + let bprintf fmt = Printf.bprintf buf fmt in + let print_results = + List.iter + (fun (path, test_result, pos_opt) -> + bprintf "%s\n" separator1; + if results_style_1_X conf then begin + bprintf "%s: %s\n\n" + (result_flavour test_result) + (string_of_path path); + end else begin + bprintf "Error: %s.\n\n" (string_of_path path); + begin + match pos_opt with + | Some pos -> + bprintf "%s\nError: %s (in the log).\n\n" + (ocaml_position pos) + (string_of_path path) + | None -> + () + end; + begin + match test_result with + | RError (_, Some backtrace) -> + bprintf "%s\n" backtrace + | RFailure (_, Some pos, _) -> + bprintf "%s\nError: %s (in the code).\n\n" + (ocaml_position pos) + (string_of_path path) + | RFailure (_, _, Some backtrace) -> + bprintf "%s\n" backtrace + | _ -> + () + end; + end; + bprintf "%s\n" (result_msg test_result); + bprintf "%s\n" separator2) + in + let filter f = + let lst = + List.filter + (fun (_, test_result, _) -> f test_result) + results + in + lst, List.length lst + in + let errors, nerrors = filter is_error in + let failures, nfailures = filter is_failure in + let skips, nskips = filter is_skip in + let _, ntodos = filter is_todo in + let timeouts, ntimeouts = filter is_timeout in + bprintf "\n"; + print_results errors; + print_results failures; + print_results timeouts; + bprintf "Ran: %d tests in: %.2f seconds.\n" + (List.length results) running_time; + + (* Print final verdict *) + if was_successful results then + begin + if skips = [] then + bprintf "OK" + else + bprintf "OK: Cases: %d Skip: %d" + test_case_count nskips + end + else + begin + bprintf + "FAILED: Cases: %d Tried: %d Errors: %d \ + Failures: %d Skip: %d Todo: %d \ + Timeouts: %d." + test_case_count + (List.length results) + nerrors + nfailures + nskips + ntodos + ntimeouts; + end; + bprintf "\n"; + Buffer.contents buf + end + + | TestEvent (_, e) -> + begin + match e with + | EStart | EEnd | ELog _ | ELogRaw _ -> "" + | EResult RSuccess -> "." + | EResult (RFailure _) -> "F" + | EResult (RError _) -> "E" + | EResult (RSkip _) -> "S" + | EResult (RTodo _) -> "T" + | EResult (RTimeout _) -> "~" + end + +let format_log_event ev = + let rlst = ref [] in + let timestamp_str = OUnitUtils.date_iso8601 ev.timestamp in + let spf pre fmt = + Printf.ksprintf + (multiline + (fun l -> + rlst := (timestamp_str^" "^ev.shard^" "^pre^": "^l) :: !rlst)) + fmt + in + let ispf fmt = spf "I" fmt in + let wspf fmt = spf "W" fmt in + let espf fmt = spf "E" fmt in + let format_result path result = + let path_str = string_of_path path in + match result with + | RTimeout test_length -> + espf "Test %s timed out after %.1fs" + path_str (delay_of_length test_length) + | RError (msg, backtrace_opt) -> + espf "Test %s exited with an error." path_str; + espf "%s in test %s." msg path_str; + OUnitUtils.opt (espf "%s") backtrace_opt + | RFailure (msg, _, backtrace_opt) -> + espf "Test %s has failed." path_str; + espf "%s in test %s." msg path_str; + OUnitUtils.opt (espf "%s") backtrace_opt + | RTodo msg -> wspf "TODO test %s: %s." path_str msg + | RSkip msg -> wspf "Skip test %s: %s." path_str msg + | RSuccess -> ispf "Test %s is successful." path_str + in + + begin + match ev.event with + | GlobalEvent e -> + begin + match e with + | GConf (k, v) -> ispf "Configuration %s = %S" k v + | GLog (`Error, str) -> espf "%s" str + | GLog (`Warning, str) -> wspf "%s" str + | GLog (`Info, str) -> ispf "%s" str + | GStart -> ispf "Start testing." + | GEnd -> ispf "End testing." + | GResults (running_time, results, test_case_count) -> + let countr = count results in + ispf "=============="; + ispf "Summary:"; + List.iter + (fun (path, test_result, _) -> + format_result path test_result) + results; + (* Print final verdict *) + ispf "Ran: %d tests in: %.2f seconds." + (List.length results) running_time; + ispf "Cases: %d." test_case_count; + ispf "Tried: %d." (List.length results); + ispf "Errors: %d." (countr is_error); + ispf "Failures: %d." (countr is_failure); + ispf "Skip: %d." (countr is_skip); + ispf "Todo: %d." (countr is_todo); + ispf "Timeout: %d." (countr is_timeout) + end + + | TestEvent (path, e) -> + begin + let path_str = string_of_path path in + match e with + | EStart -> ispf "Start test %s." path_str + | EEnd -> ispf "End test %s." path_str + | EResult result -> format_result path result + | ELog (`Error, str) -> espf "%s" str + | ELog (`Warning, str) -> wspf "%s" str + | ELog (`Info, str) -> ispf "%s" str + | ELogRaw str -> ispf "%s" str + end + end; + List.rev !rlst + +let file_logger _ shard_id fn = + let chn = open_out fn in + let line = ref 1 in + + let fwrite ev = + List.iter + (fun l -> output_string chn l; output_char chn '\n'; incr line) + (format_log_event ev); + flush chn + in + let fpos () = + Some { filename = fn; line = !line } + in + let fclose () = + close_out chn + in + { + lshard = shard_id; + fwrite = fwrite; + fpos = fpos; + fclose = fclose; + } + +let verbose = + OUnitConf.make_bool + "verbose" + false + "Run test in verbose mode." + +let display = + OUnitConf.make_bool + "display" + true + "Output logs on screen." + +let std_logger conf shard_id = + if display conf then + let verbose = verbose conf in + let fwrite log_ev = + if verbose then + List.iter print_endline (format_log_event log_ev) + else + print_string (format_display_event conf log_ev); + flush stdout + in + { + lshard = shard_id; + fwrite = fwrite; + fpos = (fun () -> None); + fclose = ignore; + } + else + null_logger + +let output_file = + OUnitConf.make_string_subst_opt + "output_file" + (Some (Filename.concat + OUnitUtils.buildir + "oUnit-$(suite_name)-$(shard_id).log")) + "Output verbose log in the given file." + +let is_output_file_shard_dependent conf = + let fn1 = output_file ~extra_subst:["shard_id", "foo"] conf in + let fn2 = output_file ~extra_subst:["shard_id", "bar"] conf in + fn1 <> fn2 + +let create_file_logger conf shard_id = + match output_file ~extra_subst:["shard_id", shard_id] conf with + | Some fn -> + file_logger conf shard_id fn + | None -> + null_logger + +let create conf shard_id = + let std_logger = std_logger conf shard_id in + let file_logger = create_file_logger conf shard_id in + combine [std_logger; file_logger] diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitPlugin.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitPlugin.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitPlugin.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitPlugin.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,73 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(** Standard functions for plugin (register, choose). *) + + +type name = string + +module type SETTINGS = +sig + type t + val name: name + val conf_help: string + val default_name: name + val default_value: t +end + +module Make(Settings: SETTINGS) = +struct + let all = ref [0, (Settings.default_name, Settings.default_value)] + + let register name pref f = + all := (pref, (name, f)) :: !all + + let of_name s = + try + List.assoc s (List.map snd !all) + with Not_found -> + OUnitUtils.failwithf "Unable to find %s '%s'." Settings.name s + + let choice = + OUnitConf.make_enum + Settings.name + (fun () -> List.map snd !all) + Settings.default_name + Settings.conf_help + + let preset lst = + let _, (default, _) = + List.fold_left max (List.hd !all) (List.tl !all) + in + (Settings.name, default) :: lst + +end diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitPropList.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitPropList.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitPropList.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitPropList.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,59 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(** Property list. + + @see MLton property list. + *) + +type t = (int, unit -> unit) Hashtbl.t + +let create () = Hashtbl.create 13 + +let new_property default = + let id = Oo.id (object end) in + let v = ref default in + let set t x = + Hashtbl.replace t id (fun () -> v := x) + in + let get t = + try + let x = + (Hashtbl.find t id) (); + !v + in + v := default; + x + with Not_found -> + default + in + (set, get) diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitResultSummary.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitResultSummary.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitResultSummary.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitResultSummary.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,322 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(* + Summary of the results, based on captured log events. + *) + +open OUnitUtils +open OUnitTest +open OUnitLogger + +type log_entry = + float (* time since start of the test *) * + log_severity option * + string (* log entry without \n *) + +type test_data = + { + test_name: string; + timestamp_start: float; (* UNIX timestamp *) + timestamp_end: float; (* UNIX timestamp *) + log_entries: log_entry list; (* time sorted log entry, timestamp from + timestamp_start *) + test_result: OUnitTest.result; + } + +type t = + { + suite_name: string; + start_at: float; + charset: string; + conf: (string * string) list; + running_time: float; + global_results: OUnitTest.result_list; + test_case_count: int; + tests: test_data list; + errors: int; + failures: int; + skips: int; + todos: int; + timeouts: int; + successes: int; + } + +let is_success = + function + | RSuccess -> true + | RFailure _ | RError _ | RSkip _ | RTodo _ | RTimeout _ -> false + +let is_failure = + function + | RFailure _ -> true + | RSuccess | RError _ | RSkip _ | RTodo _ | RTimeout _ -> false + +let is_error = + function + | RError _ -> true + | RSuccess | RFailure _ | RSkip _ | RTodo _ | RTimeout _ -> false + +let is_skip = + function + | RSkip _ -> true + | RSuccess | RFailure _ | RError _ | RTodo _ | RTimeout _ -> false + +let is_todo = + function + | RTodo _ -> true + | RSuccess | RFailure _ | RError _ | RSkip _ | RTimeout _ -> false + +let is_timeout = + function + | RTimeout _ -> true + | RSuccess | RFailure _ | RError _ | RSkip _ | RTodo _ -> false + +let result_flavour = + function + | RError _ -> "Error" + | RFailure _ -> "Failure" + | RSuccess -> "Success" + | RSkip _ -> "Skip" + | RTodo _ -> "Todo" + | RTimeout _ -> "Timeout" + +let result_msg = + function + | RSuccess -> "Success" + | RError (msg, _) + | RFailure (msg, _, _) + | RSkip msg + | RTodo msg -> msg + | RTimeout test_length -> + Printf.sprintf "Timeout after %.1fs" (delay_of_length test_length) + +let worst_cmp result1 result2 = + let rank = + function + | RSuccess -> 0 + | RSkip _ -> 1 + | RTodo _ -> 2 + | RFailure _ -> 3 + | RError _ -> 4 + | RTimeout _ -> 5 + in + (rank result1) - (rank result2) + +let worst_result_full result_full lst = + let worst = + List.fold_left + (fun ((_, result1, _) as result_full1) + ((_, result2, _) as result_full2) -> + if worst_cmp result1 result2 < 0 then + result_full2 + else + result_full1) + result_full lst + in + worst, + List.filter + (fun result_full -> not (result_full == worst)) + (result_full :: lst) + +let was_successful lst = + List.for_all + (fun (_, rslt, _) -> + match rslt with + | RSuccess | RSkip _ -> true + | _ -> false) + lst + +let encoding = + OUnitConf.make_string + "log_encoding" + "utf-8" + "Encoding of the log." + +let of_log_events conf events = + let global_conf = + List.fold_left + (fun acc log_ev -> + match log_ev.event with + | GlobalEvent (GConf (k, v)) -> (k, v) :: acc + | _ -> acc) + [] + (List.rev events) + in + let running_time, global_results, test_case_count = + let rec find_results = + function + | {event = + GlobalEvent + (GResults (running_time, results, test_case_count)); _} :: _ -> + running_time, results, test_case_count + | _ :: tl -> + find_results tl + | [] -> + failwith "Cannot find results in OUnitResult.of_log_events." + in + find_results events + in + let tests = + let rec split_raw tmstp str lst = + try + let idx = String.index str '\n' in + split_raw tmstp + (String.sub str (idx + 1) (String.length str - idx - 1)) + ((tmstp, None, String.sub str 0 idx) :: lst) + with Not_found -> + (tmstp, None, str) :: lst + in + + let finalize t = + let log_entries = + List.sort + (fun (f1, _, _) (f2, _, _) -> Stdlib.compare f2 f1) + t.log_entries + in + let log_entries = + List.rev_map + (fun (f, a, b) -> f -. t.timestamp_start, a, b) + log_entries + in + {t with log_entries = log_entries} + in + + let default_timestamp = 0.0 in + let rec process_log_event tests log_event = + let timestamp = log_event.timestamp in + match log_event.event with + | GlobalEvent _ -> + tests + | TestEvent (path, ev) -> + begin + let t = + try + MapPath.find path tests + with Not_found -> + { + test_name = string_of_path path; + timestamp_start = default_timestamp; + timestamp_end = default_timestamp; + log_entries = []; + test_result = RFailure ("Not finished", None, None); + } + in + let alt0 t1 t2 = + if t1 = default_timestamp then + t2 + else + t1 + in + let t' = + match ev with + | EStart -> + {t with + timestamp_start = timestamp; + timestamp_end = alt0 t.timestamp_end timestamp} + | EEnd -> + {t with + timestamp_end = timestamp; + timestamp_start = alt0 t.timestamp_start timestamp} + | EResult rslt -> + {t with test_result = rslt} + | ELog (svrt, str) -> + {t with log_entries = (timestamp, Some svrt, str) + :: t.log_entries} + | ELogRaw str -> + {t with log_entries = + split_raw timestamp str t.log_entries} + in + MapPath.add path t' tests + end + and group_test tests = + function + | hd :: tl -> + group_test + (process_log_event tests hd) + tl + | [] -> + let lst = + MapPath.fold + (fun _ test lst -> + finalize test :: lst) + tests [] + in + List.sort + (fun t1 t2 -> + Stdlib.compare t1.timestamp_start t2.timestamp_start) + lst + in + group_test MapPath.empty events + in + let start_at = + List.fold_left + (fun start_at log_ev -> + min start_at log_ev.timestamp) + (now ()) + events + in + let suite_name = + match global_results with + | (path, _, _) :: _ -> + List.fold_left + (fun acc nd -> + match nd with + | ListItem _ -> acc + | Label str -> str) + "noname" + path + | [] -> + "noname" + in + let count f = + List.length + (List.filter (fun (_, test_result, _) -> f test_result) + global_results) + in + let charset = encoding conf in + { + suite_name = suite_name; + start_at = start_at; + charset = charset; + conf = global_conf; + running_time = running_time; + global_results = global_results; + test_case_count = test_case_count; + tests = tests; + errors = count is_error; + failures = count is_failure; + skips = count is_skip; + todos = count is_todo; + timeouts = count is_timeout; + successes = count is_success; + } diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitRunner.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitRunner.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitRunner.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitRunner.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,577 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open OUnitTest +open OUnitLogger + +(** Number of shards to use. The way the shards are used depends on the type of + runner. + *) +let shards = + let shards = ref 2 in + if Sys.os_type = "Unix" then begin + if Sys.file_exists "/proc/cpuinfo" then begin + let chn_in = open_in "/proc/cpuinfo" in + let () = + try + while true do + try + let line = input_line chn_in in + Scanf.sscanf line "cpu cores : %d" (fun i -> shards := max i 2) + with Scanf.Scan_failure _ -> + () + done + with End_of_file -> + () + in + close_in chn_in + end + end; + OUnitConf.make_int + "shards" + !shards + "Number of shards to use as worker (threads or processes)." + +(** Whether or not run a Gc.full_major in between tests. This adds time + when running tests, but helps to avoid unexpected error due to finalisation + of values allocated during a test. + *) +let run_gc_full_major = + OUnitConf.make_bool + "run_gc_full_major" true + "Run a Gc.full_major in between tests." + +(** Common utilities to run test. *) +let run_one_test conf logger shared test_path (test_fun: OUnitTest.test_fun) = + let () = OUnitLogger.report logger (TestEvent (test_path, EStart)) in + let non_fatal = ref [] in + let main_result_full = + with_ctxt conf logger shared non_fatal test_path + (fun ctxt -> + let check_env = OUnitCheckEnv.create () in + let result_full = + try + test_fun ctxt; + OUnitCheckEnv.check ctxt check_env; + if run_gc_full_major conf then begin + Gc.full_major (); + end; + test_path, RSuccess, None + with e -> + OUnitTest.result_full_of_exception ctxt e + in + report_result_full ctxt result_full) + in + let result_full, other_result_fulls = + match main_result_full, List.rev !non_fatal with + | (_, RSuccess, _), [] -> + main_result_full, [] + | (_, RSuccess, _), hd :: tl -> + OUnitResultSummary.worst_result_full hd tl + | _, lst -> + OUnitResultSummary.worst_result_full main_result_full lst + in + OUnitLogger.report logger (TestEvent (test_path, EEnd)); + result_full, other_result_fulls + +type runner = + OUnitConf.conf -> + OUnitTest.logger -> + OUnitChooser.chooser -> + (path * test_length * test_fun) list -> + OUnitTest.result_list + +(* The simplest runner possible, run test one after the other in a single + * process, without threads. + *) + +(* Run all tests, sequential version *) +let sequential_runner: runner = fun conf logger chooser test_cases -> + let shared = OUnitShared.create () in + let rec iter state = + match OUnitState.next_test_case conf logger state with + | OUnitState.Finished, state -> + OUnitState.get_results state + | OUnitState.Next_test_case (test_path, test_fun, worker), state -> + iter + (OUnitState.test_finished conf + (run_one_test conf logger shared test_path test_fun) + worker state) + | (OUnitState.Try_again | OUnitState.Not_enough_worker), _ -> + assert false + in + let state = + OUnitState.add_worker () (OUnitState.create conf chooser test_cases) + in + iter state + +(**/**) +(* Plugin interface. *) +module Plugin = + OUnitPlugin.Make + (struct + type t = runner + let name = "runner" + let conf_help = + "Select a the method to run tests." + let default_name = "sequential" + let default_value = sequential_runner + end) +(**/**) + +include Plugin + + +(** Build worker based runner. *) +module GenericWorker = +struct + open OUnitState + + type message_to_worker = + | Exit + | AckLock of bool + | RunTest of path + + let string_of_message_to_worker = + function + | Exit -> "Exit" + | AckLock _ -> "AckLock _" + | RunTest _ -> "RunTest _" + + type message_from_worker = + | AckExit + | Log of OUnitTest.log_event_t + | Lock of int + | Unlock of int + | TestDone of (OUnitTest.result_full * OUnitTest.result_list) + + let string_of_message_from_worker = + function + | AckExit -> "AckExit" + | Log _ -> "Log _" + | Lock _ -> "Lock _" + | Unlock _ -> "Unlock _" + | TestDone _ -> "TestDone _" + + module MapPath = + Map.Make + (struct + type t = path + let rec compare lst1 lst2 = + match lst1, lst2 with + | hd1 :: tl1, hd2 :: tl2 -> + begin + match Stdlib.compare hd1 hd2 with + | 0 -> compare tl1 tl2 + | n -> n + end + | [], _ :: _ -> -1 + | _ :: _, [] -> 1 + | [], [] -> 0 + end) + + + type map_test_cases = + (OUnitTest.path * OUnitTest.test_length * (OUnitTest.ctxt -> unit)) MapPath.t + + type ('a, 'b) channel = + { + send_data: 'a -> unit; + receive_data: unit -> 'b; + close: unit -> unit; + } + + type worker_channel = (message_from_worker, message_to_worker) channel + + (* Add some extra feature to channel. *) + let wrap_channel + shard_id + string_of_read_message + string_of_written_message + channel = + (* Turn on to debug communication in channel. *) + let debug_communication = false in + if debug_communication then begin + let debugf fmt = + Printf.ksprintf + (fun s -> + if debug_communication then + prerr_endline ("D("^shard_id^"): "^s)) + fmt + in + let send_data msg = + debugf "Sending message %S" (string_of_written_message msg); + channel.send_data msg; + debugf "Message transmitted, continuing." + in + + let receive_data () = + let () = debugf "Waiting to receive data." in + let msg = channel.receive_data () in + debugf "Received message %S" (string_of_read_message msg); + msg + in + { + send_data = send_data; + receive_data = receive_data; + close = channel.close; + } + end else begin + channel + end + + + (* Run a worker, react to message receive from parent. *) + let main_worker_loop + ~yield + ~shard_id + ~worker_log_file + (conf: OUnitConf.conf) + (channel: worker_channel) + (map_test_cases: map_test_cases) = + let logger = + let master_logger = + set_shard shard_id + (OUnitLogger.fun_logger + (fun {event = log_ev; _} -> channel.send_data (Log log_ev)) + ignore) + in + let base_logger = + if worker_log_file then + OUnitLoggerStd.create_file_logger conf shard_id + else + OUnitLogger.null_logger + in + OUnitLogger.combine [base_logger; master_logger] + in + + let shared = + let try_lock id = + channel.send_data (Lock id); + match channel.receive_data () with + | AckLock b -> + b + | Exit | RunTest _ -> + assert false + in + let rec lock id = + if not (try_lock id) then begin + yield (); + lock id + end else begin + () + end + in + let unlock id = + channel.send_data (Unlock id); + in + let global = + { + OUnitShared. + lock = lock; + try_lock = try_lock; + unlock = unlock; + } + in + { + OUnitShared. + global = global; + process = OUnitShared.noscope_create (); + } + in + + let rec loop () = + match channel.receive_data () with + | Exit -> + channel.send_data AckExit + + | RunTest test_path -> + let test_path, _, test_fun = + MapPath.find test_path map_test_cases + in + let res = run_one_test conf logger shared test_path test_fun in + channel.send_data (TestDone res); + loop () + + | AckLock _ -> + loop () + in + loop () + + type 'a worker = + { + channel: (message_to_worker, message_from_worker) channel; + close_worker: unit -> string option; + select_fd: 'a; + shard_id: string; + is_running: unit -> bool; + } + + type 'a worker_creator = + shard_id:string -> master_id:string -> worker_log_file:bool -> + OUnitConf.conf -> map_test_cases -> 'a worker + + type 'a workers_waiting_selector = + timeout:float -> 'a worker list -> 'a worker list + + (* Run all tests. *) + let runner + (create_worker: 'a worker_creator) + (workers_waiting: 'a workers_waiting_selector) : runner = + fun (conf: OUnitConf.conf) logger chooser test_cases -> + let map_test_cases = + List.fold_left + (fun mp ((test_path, _, _) as test_case) -> + MapPath.add test_path test_case mp) + MapPath.empty + test_cases + in + + let state = OUnitState.create conf chooser test_cases in + + let shards = max (shards conf) 1 in + + let master_id = logger.OUnitLogger.lshard in + + let worker_idx = ref 1 in + + let test_per_worker, incr_tests_per_worker = + OUnitUtils.make_counter () + in + let health_check_per_worker, incr_health_check_per_worker = + OUnitUtils.make_counter () + in + + let () = infof logger "Using %d workers maximum." shards; in + + let worker_log_file = + if not (OUnitLoggerStd.is_output_file_shard_dependent conf) then begin + warningf logger + "-output-file doesn't include $(shard_id), \ + shards won't have file log."; + false + end else begin + true + end + in + + let master_shared = OUnitShared.noscope_create () in + + (* Act depending on the received message. *) + let process_message worker msg state = + match msg with + | AckExit -> + let msg_opt = + infof logger "Worker %s has ended." worker.shard_id; + worker.close_worker () + in + OUnitUtils.opt + (errorf logger "Worker return status: %s") + msg_opt; + remove_idle_worker worker state + + | Log log_ev -> + OUnitLogger.report (set_shard worker.shard_id logger) log_ev; + state + + | Lock id -> + worker.channel.send_data + (AckLock (master_shared.OUnitShared.try_lock id)); + state + + | Unlock id -> + master_shared.OUnitShared.unlock id; + state + + | TestDone test_result -> + OUnitState.test_finished conf test_result worker state + in + + (* Report a worker dead and unregister it. *) + let declare_dead_worker test_path worker result state = + let log_pos = position logger in + report logger (TestEvent (test_path, EResult result)); + report logger (TestEvent (test_path, EEnd)); + remove_idle_worker + worker + (test_finished conf + ((test_path, result, log_pos), []) + worker state) + in + + let declare_dead_idle_worker worker state = + let msg = + Printf.sprintf "Worker %s died unexpectedly." worker.shard_id + in + report logger (GlobalEvent (GLog (`Info, msg))); + remove_idle_worker worker state + in + + (* Kill the worker that has timed out. *) + let kill_timeout state = + List.fold_left + (fun state (test_path, test_length, worker) -> + let _msg : string option = + errorf logger "Worker %s, running test %s has timed out." + worker.shard_id (string_of_path test_path); + worker.close_worker () + in + declare_dead_worker test_path worker (RTimeout test_length) state) + state + (get_worker_timed_out state) + in + + (* Check that worker are healthy (i.e. still running). *) + let check_health state = + List.fold_left + (fun state (test_path_opt, worker) -> + incr_health_check_per_worker worker.shard_id; + if worker.is_running () then begin + match test_path_opt with + | Some test_path -> update_test_activity test_path state + | None -> state + end else begin + match test_path_opt with + | Some test_path -> + begin + (* Argh, a test failed badly! *) + let result_msg = + errorf logger + "Worker %s, running test %s is not running anymore." + worker.shard_id (string_of_path test_path); + match worker.close_worker () with + | Some msg -> + Printf.sprintf "Worker stops running: %s" msg + | None -> + "Worker stops running for unknown reason." + in + declare_dead_worker test_path worker + (RError (result_msg, None)) + state + end + | None -> + declare_dead_idle_worker worker state + end) + state + (get_worker_need_health_check state) + in + + (* Main wait loop. *) + let wait_test_done state = + let state = (check_health (kill_timeout state)) in + if get_workers state <> [] then begin + let workers_waiting_lst = + infof logger "%d tests running: %s." + (count_tests_running state) + (String.concat ", " + (List.map string_of_path (get_tests_running state))); + workers_waiting ~timeout:(timeout state) (get_workers state) + in + List.fold_left + (fun state worker -> + process_message worker (worker.channel.receive_data ()) state) + state + workers_waiting_lst + + end else begin + state + end + in + + (* Wait for every worker to stop. *) + let rec wait_stopped state = + if OUnitState.get_workers state = [] then + state + else + wait_stopped (wait_test_done state) + in + + let rec iter state = + match OUnitState.next_test_case conf logger state with + | Not_enough_worker, state -> + if OUnitState.count_worker state < shards then begin + (* Start a worker. *) + let shard_id = OUnitUtils.shardf !worker_idx in + let () = infof logger "Starting worker number %s." shard_id in + let worker = + create_worker + ~shard_id ~master_id ~worker_log_file conf map_test_cases + in + let () = infof logger "Worker %s started." worker.shard_id in + let state = add_worker worker state in + incr worker_idx; + iter state + end else begin + iter (wait_test_done state) + end + + | Try_again, state -> + iter (wait_test_done state) + + | Next_test_case (test_path, _, worker), state -> + incr_tests_per_worker worker.shard_id; + worker.channel.send_data (RunTest test_path); + iter state + + | Finished, state -> + let count_tests_running = OUnitState.count_tests_running state in + if count_tests_running = 0 then begin + let state = + List.iter + (fun worker -> worker.channel.send_data Exit) + (OUnitState.get_workers state); + wait_stopped state + in + infof logger "Used %d worker during test execution." + (!worker_idx - 1); + List.iter + (fun (shard_id, count) -> + infof logger "Run %d tests with shard %s." + count shard_id) + (test_per_worker ()); + List.iter + (fun (shard_id, count) -> + infof logger "Check health of shard %s, %d times." + shard_id count) + (health_check_per_worker ()); + OUnitState.get_results state + end else begin + infof logger "Still %d tests running : %s." count_tests_running + (String.concat ", " + (List.map string_of_path + (get_tests_running state))); + iter (wait_test_done state) + end + in + iter state + +end diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitRunnerProcesses.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitRunnerProcesses.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitRunnerProcesses.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitRunnerProcesses.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,267 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(** Use processes to run several tests in parallel. + * + * Run processes that handle running tests. The processes read test, execute + * it, and communicate back to the master the log. + * + * This need to be done in another process because OCaml Threads are not truly + * running in parallel. Moreover we cannot use Unix.fork because it's not + * portable + *) + +open Unix +open OUnitRunner.GenericWorker + + +let unix_fork = ref Unix.fork + +(* Create functions to handle sending and receiving data over a file descriptor. + *) +let make_channel + shard_id + string_of_read_message + string_of_written_message + fd_read + fd_write = + let () = + set_nonblock fd_read; + set_close_on_exec fd_read; + set_close_on_exec fd_write + in + + let chn_write = out_channel_of_descr fd_write in + + let really_read fd str = + let off = ref 0 in + let read = ref 0 in + while !read < Bytes.length str do + try + let one_read = + Unix.read fd str !off (Bytes.length str - !off) + in + read := !read + one_read; + off := !off + one_read + with Unix_error(EAGAIN, _, _) -> + () + done; + str + in + + let header_str = Bytes.create Marshal.header_size in + + let send_data msg = + Marshal.to_channel chn_write msg []; + Stdlib.flush chn_write + in + + let receive_data () = + try + let data_size = Marshal.data_size (really_read fd_read header_str) 0 in + let data_str = really_read fd_read (Bytes.create data_size) in + let msg = + (* TODO: use Marshal.from_bytes when OCaml requirement is > 4.01. *) + Marshal.from_string + (Bytes.unsafe_to_string (Bytes.cat header_str data_str)) + 0 + in + msg + with Failure(msg) -> + OUnitUtils.failwithf "Communication error with worker processes: %s" msg + in + + let close () = + close_out chn_write; + in + wrap_channel + shard_id + string_of_read_message + string_of_written_message + { + send_data = send_data; + receive_data = receive_data; + close = close + } + +let processes_grace_period = + OUnitConf.make_float + "processes_grace_period" + 5.0 + "Delay to wait for a process to stop." + +let processes_kill_period = + OUnitConf.make_float + "processes_kill_period" + 5.0 + "Delay to wait for a process to stop after killing it." + +let rec select_no_interrupt read_descrs write_descrs except_descrs timeout = + if timeout < 0.0 then begin + [], [], [] + end else begin + try + Unix.select read_descrs write_descrs except_descrs 0.1 + with Unix.Unix_error (Unix.EINTR, "select", "") -> + select_no_interrupt + read_descrs write_descrs except_descrs (timeout -. 0.1) + end + +let create_worker ~shard_id ~master_id ~worker_log_file conf map_test_cases = + let safe_close fd = try close fd with Unix_error _ -> () in + let pipe_read_from_worker, pipe_write_to_master = Unix.pipe () in + let pipe_read_from_master, pipe_write_to_worker = Unix.pipe () in + match !unix_fork () with + | 0 -> + (* Child process. *) + let () = + safe_close pipe_read_from_worker; + safe_close pipe_write_to_worker; + (* stdin/stdout/stderr remain open and shared with master. *) + () + in + let channel = + make_channel + shard_id + string_of_message_to_worker + string_of_message_from_worker + pipe_read_from_master + pipe_write_to_master + in + main_worker_loop + conf + ~yield:ignore + channel + ~shard_id + map_test_cases + ~worker_log_file; + channel.close (); + safe_close pipe_read_from_master; + safe_close pipe_write_to_master; + exit 0 + + | pid -> + let channel = + make_channel + master_id + string_of_message_from_worker + string_of_message_to_worker + pipe_read_from_worker + pipe_write_to_worker + in + + let rstatus = ref None in + + let msg_of_process_status status = + if status = WEXITED 0 then + None + else + Some (OUnitUtils.string_of_process_status status) + in + + let is_running () = + match !rstatus with + | None -> + let pid, status = waitpid [WNOHANG] pid in + if pid <> 0 then begin + rstatus := Some status; + false + end else begin + true + end + | Some _ -> + false + in + + let close_worker () = + let rec wait_end timeout = + if timeout < 0.0 then begin + false, None + end else begin + if is_running () then + let _, _, _ = select_no_interrupt [] [] [] 0.1 in + wait_end (timeout -. 0.1) + else + match !rstatus with + | Some status -> true, msg_of_process_status status + | None -> true, None + end + in + + let ended, msg_opt = + channel.close (); + safe_close pipe_read_from_worker; + safe_close pipe_write_to_worker; + (* Recovery for worker going wild and not dying. *) + List.fold_left + (fun (ended, msg_opt) signal -> + if ended then begin + ended, msg_opt + end else begin + kill pid signal; + wait_end (processes_kill_period conf) + end) + (wait_end (processes_grace_period conf)) + [15 (* SIGTERM *); 9 (* SIGKILL *)] + in + if ended then + msg_opt + else + Some (Printf.sprintf "unable to kill process %d" pid) + in + { + channel = channel; + close_worker = close_worker; + select_fd = pipe_read_from_worker; + shard_id = shard_id; + is_running = is_running; + } + +(* Filter running workers waiting data. *) +let workers_waiting ~timeout workers = + let workers_fd_lst = + List.rev_map (fun worker -> worker.select_fd) workers + in + let workers_fd_waiting_lst, _, _ = + select_no_interrupt workers_fd_lst [] [] timeout + in + List.filter + (fun workers -> List.memq workers.select_fd workers_fd_waiting_lst) + workers + +let init () = + if Sys.os_type = "Unix" then + match Sys.backend_type with + | Native | Bytecode -> + OUnitRunner.register "processes" 100 + (runner create_worker workers_waiting) + | Other _ -> () diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitShared.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitShared.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitShared.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitShared.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,159 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +exception Lock_failure + +type scope = ScopeGlobal | ScopeProcess + +type 'a shared_noscope = + { + lock: 'a -> unit; + unlock: 'a -> unit; + try_lock: 'a -> bool; + } + +type shared = + { + global: int shared_noscope; + process: int shared_noscope; + } + +let get_scoped shared = + function + | ScopeGlobal -> shared.global + | ScopeProcess -> shared.process + + +(* Global variable that need to be set for threads. *) +let mutex_create = + ref (fun () -> + let r = ref false in + + let try_lock () = + if !r then begin + false + end else begin + r := true; + true + end + in + + let lock () = + if not (try_lock ()) then + raise Lock_failure + in + + let unlock () = + r := false + in + + { + lock = lock; + try_lock = try_lock; + unlock = unlock; + }) + +module Mutex = +struct + + type t = int * scope + + let create scope = + (Oo.id (object end), scope) + + let lock shared (id, scope) = + (get_scoped shared scope).lock id + + let try_lock shared (id, scope) = + (get_scoped shared scope).try_lock id + + let unlock shared (id, scope) = + (get_scoped shared scope).unlock id + + let with_lock shared mutex f = + try + let res = + lock shared mutex; + f () + in + unlock shared mutex; + res + with e -> + unlock shared mutex; + raise e + + +end + +(* A simple shared_noscope that works only for 1 process. *) +let noscope_create () = + let state = Hashtbl.create 13 in + let state_mutex = !mutex_create () in + + let get_mutex id = + let mutex = + state_mutex.lock (); + try + Hashtbl.find state id + with Not_found -> + let mutex = !mutex_create () in + Hashtbl.add state id mutex; + mutex + in + state_mutex.unlock (); + mutex + in + + let try_lock id = + (get_mutex id).try_lock () + in + + let lock id = + (get_mutex id).lock () + in + + let unlock id = + (get_mutex id).unlock () + in + { + lock = lock; + unlock = unlock; + try_lock = try_lock; + } + +(* Create a shared, for 1 process. *) +let create () = + let scoped = noscope_create () in + { + global = scoped; + process = scoped; + } diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitState.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitState.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitState.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitState.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,288 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(** Manipulate the state of OUnit runner. + *) + +open OUnitLogger +open OUnitTest +open OUnitChooser + +type 'worker next_test_case_t = + | Not_enough_worker + | Try_again + | Next_test_case of path * test_fun * 'worker + | Finished + +type time = float + +type 'worker test_running = + { + test_length: test_length; + deadline: time; + next_health_check: time; + worker: 'worker; + } + +type 'worker t = + { + tests_planned: (path * (test_length * test_fun)) list; + tests_running: (path * ('worker test_running)) list; + tests_passed: (OUnitTest.result_full * OUnitTest.result_list) list; + idle_workers: 'worker list; + chooser: OUnitChooser.chooser; + cache: OUnitCache.cache; + health_check_interval: time; + } + +let health_check_interval = + OUnitConf.make_float + "health_check_interval" + 1.0 + "Seconds between checking health of workers." + +let create conf chooser test_cases = + { + tests_passed = []; + tests_planned = List.map + (fun (test_path, test_length, test_fun) -> + test_path, (test_length, test_fun)) + test_cases; + tests_running = []; + idle_workers = []; + chooser = chooser; + cache = OUnitCache.load conf; + health_check_interval = health_check_interval conf; + } + +let filter_out e lst = List.filter (fun (e', _) -> e <> e') lst + +let maybe_dump_cache conf state = + if state.tests_running = [] && state.tests_planned = [] then + (* We are finished, all results are in, flush the cache. *) + OUnitCache.dump conf + (List.fold_left + (fun cache (path, test_result, _) -> + OUnitCache.add_result path test_result cache) + state.cache + (List.map fst state.tests_passed)); + state + +let add_test_results conf all_test_results state = + let ((test_path, _, _), _) = all_test_results in + let state = + {state with + tests_passed = all_test_results :: state.tests_passed; + tests_planned = filter_out test_path state.tests_planned}; + in + maybe_dump_cache conf state + +let test_finished conf all_test_results worker state = + let ((test_path, _, _), _) = all_test_results in + let state = + {(add_test_results conf all_test_results state) with + tests_running = filter_out test_path state.tests_running; + idle_workers = worker :: state.idle_workers} + in + maybe_dump_cache conf state + +let add_worker worker state = + {state with idle_workers = worker :: state.idle_workers} + +let remove_idle_worker worker state = + let found, idle_workers = + List.fold_left + (fun (found, lst) worker' -> + if worker' == worker then + true, lst + else + found, worker' :: lst) + (false, []) + state.idle_workers + in + if not found then + raise Not_found; + {state with idle_workers = idle_workers} + +let count_worker state = + List.length state.idle_workers + List.length state.tests_running + +let count_tests_running state = + List.length state.tests_running + +let get_workers state = + List.rev_append state.idle_workers + (List.rev_map (fun (_, {worker = worker; _}) -> worker) state.tests_running) + +let get_idle_workers state = + state.idle_workers + +let is_idle_worker worker state = + List.exists (fun worker' -> worker == worker') state.idle_workers + +let get_tests_running state = + List.map fst state.tests_running + +let rec next_test_case conf logger state = + match state.tests_planned, state.idle_workers with + | [], _ -> + Finished, state + | _, worker :: tl_workers -> + begin + let choice = + state.chooser + { + OUnitChooser. + tests_planned = List.map fst state.tests_planned; + tests_running = List.map fst state.tests_running; + tests_passed = List.map fst state.tests_passed; + cache = state.cache; + } + in + match choice with + | Choose test_path -> + begin + try + let test_length, test_fun = + List.assoc test_path state.tests_planned + in + let now = OUnitUtils.now () in + Next_test_case (test_path, test_fun, worker), + {state with + tests_running = + (test_path, + { + test_length = test_length; + deadline = now +. delay_of_length test_length; + next_health_check = + now +. state.health_check_interval; + worker = worker; + }) :: state.tests_running; + tests_planned = + filter_out test_path state.tests_planned; + idle_workers = + tl_workers} + with Not_found -> + assert false + end + + | ChooseToPostpone -> + Try_again, state + + | ChooseToSkip path -> + let skipped_result = RSkip "Skipped by the chooser." in + OUnitLogger.report logger (TestEvent (path, EStart)); + OUnitLogger.report + logger (TestEvent (path, EResult skipped_result)); + OUnitLogger.report logger (TestEvent (path, EEnd)); + next_test_case + conf logger + (add_test_results conf + ((path, skipped_result, None), []) state) + + | NoChoice -> + Finished, state + + end + | _, [] -> + Not_enough_worker, state + +(** Get all the results. *) +let get_results state = + List.fold_right + (fun (result, other_results) res -> + result :: other_results @ res) + state.tests_passed [] + +(** Get all the workers that need to be checked for their health. *) +let get_worker_need_health_check state = + let now = OUnitUtils.now () in + let running_workers = + List.fold_left + (fun lst (test_path, test_running) -> + if test_running.next_health_check <= now then + (Some test_path, test_running.worker) :: lst + else + lst) + [] + state.tests_running + in + let idle_workers = + List.map (fun worker -> (None, worker)) state.idle_workers + in + running_workers @ idle_workers + +(** Update the activity of a worker, this postpone the next health check. *) +let update_test_activity test_path state = + let now = OUnitUtils.now () in + let tests_running = + List.fold_right + (fun (test_path', test_running) lst -> + let test_running = + if test_path' = test_path then + {test_running with + next_health_check = now +. state.health_check_interval} + else + test_running + in + (test_path', test_running) :: lst) + state.tests_running + [] + in + {state with tests_running = tests_running} + +(** Get all the workers that are timed out, i.e. that need to be stopped. *) +let get_worker_timed_out state = + let now = OUnitUtils.now () in + List.fold_left + (fun lst (test_path, test_running) -> + if test_running.deadline <= now then + (test_path, test_running.test_length, test_running.worker) :: lst + else + lst) + [] + state.tests_running + +(** Compute when is the next time, we should either run health check or timeout + a test. + *) +let timeout state = + let now = OUnitUtils.now () in + let next_event_time = + List.fold_left + (fun next_event_time (_, test_running) -> + min test_running.next_health_check + (min test_running.deadline next_event_time)) + (now +. state.health_check_interval) + state.tests_running + in + max 0.1 (next_event_time -. now) diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitTestData.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitTestData.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitTestData.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitTestData.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,64 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +let make_filename = List.fold_left Filename.concat + +let testdata_default = + let pwd = Sys.getcwd () in + let is_dir lst = + let dn = make_filename pwd lst in + Sys.file_exists dn && Sys.is_directory dn + in + try + let path = + List.find is_dir + [ + ["test"; "data"]; + ["tests"; "data"]; + ["data"] + ] + in + Some (make_filename pwd path) + with Not_found -> + None + +let testdata_dir = + OUnitConf.make_string_opt + "testdata_dir" + testdata_default + "Location of the test data directory (absolute path)." + +let in_testdata_dir conf path = + match testdata_dir conf with + | Some fn -> make_filename fn path + | None -> + failwith "Test data dir not defined." diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitTest.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitTest.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitTest.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitTest.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,411 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open OUnitUtils + +exception Skip of string +exception Todo of string +exception OUnit_failure of string + +(** See OUnit.mli. *) +type node = ListItem of int | Label of string + +(** See OUnit.mli. *) +type path = node list + +(** See OUnit2.mli. *) +type backtrace = string option + +(* The type of length of a test. *) +type test_length = + | Immediate (* < 1s *) + | Short (* < 1min *) + | Long (* < 10min *) + | Huge (* < 30min *) + | Custom_length of float + +(** See OUnit.mli. *) +type result = + | RSuccess + | RFailure of string * OUnitLogger.position option * backtrace + | RError of string * backtrace + | RSkip of string + | RTodo of string + | RTimeout of test_length + +(* See OUnit.mli. *) +type result_full = (path * result * OUnitLogger.position option) + +type result_list = result_full list + +type log_event_t = (path, result) OUnitLogger.log_event_t +type logger = (path, result) OUnitLogger.logger + +type ctxt = + (* TODO: hide this to avoid building a context outside. *) + { + conf: OUnitConf.conf; + logger: logger; + shared: OUnitShared.shared; + path: path; + test_logger: result OUnitLogger.Test.t; + (* TODO: Still a race condition possible, what if another threads + * modify anything during the process (e.g. register tear down). + *) + mutable tear_down: (ctxt -> unit) list; + tear_down_mutex: OUnitShared.Mutex.t; + non_fatal: result_full list ref; + non_fatal_mutex: OUnitShared.Mutex.t; + initial_environment: string array; + } + +type test_fun = ctxt -> unit + +(* The type of tests. *) +type test = + | TestCase of test_length * test_fun + | TestList of test list + | TestLabel of string * test + +let delay_of_length = + function + | Immediate -> 20.0 (* 20 seconds *) + | Short -> 600.0 (* 10 minutes *) + | Long -> 1800.0 (* 30 minutes *) + | Huge -> 3600.0 (* 1 hour *) + | Custom_length f -> f + +let get_shard_id test_ctxt = + test_ctxt.logger.OUnitLogger.lshard + +(** Isolate a function inside a context. All the added tear down will run before + returning. + *) +let section_ctxt ctxt f = + let old_tear_down = + OUnitShared.Mutex.with_lock + ctxt.shared ctxt.tear_down_mutex + (fun () -> ctxt.tear_down) + in + let clean_exit () = + OUnitShared.Mutex.with_lock + ctxt.shared ctxt.tear_down_mutex + (fun () -> + List.iter (fun tear_down -> tear_down ctxt) ctxt.tear_down; + ctxt.tear_down <- old_tear_down) + in + OUnitShared.Mutex.with_lock + ctxt.shared ctxt.tear_down_mutex + (fun () -> ctxt.tear_down <- []); + try + let res = f ctxt in + clean_exit (); + res + with e -> + clean_exit (); + raise e + +(** Create a context and run the function. *) +let with_ctxt conf logger shared non_fatal test_path f = + let ctxt = + { + conf = conf; + logger = logger; + path = test_path; + shared = shared; + test_logger = OUnitLogger.Test.create logger test_path; + tear_down = []; + tear_down_mutex = OUnitShared.Mutex.create OUnitShared.ScopeProcess; + non_fatal = non_fatal; + non_fatal_mutex = OUnitShared.Mutex.create OUnitShared.ScopeProcess; + initial_environment = Unix.environment (); + } + in + section_ctxt ctxt f + +let standard_modules = + [ + "arg.ml"; + "arrayLabels.ml"; + "array.ml"; + "buffer.ml"; + "callback.ml"; + "camlinternalLazy.ml"; + "camlinternalMod.ml"; + "camlinternalOO.ml"; + "char.ml"; + "complex.ml"; + "digest.ml"; + "filename.ml"; + "format.ml"; + "gc.ml"; + "genlex.ml"; + "hashtbl.ml"; + "int32.ml"; + "int64.ml"; + "lazy.ml"; + "lexing.ml"; + "listLabels.ml"; + "list.ml"; + "map.ml"; + "marshal.ml"; + "moreLabels.ml"; + "nativeint.ml"; + "obj.ml"; + "oo.ml"; + "parsing.ml"; + "pervasives.ml"; + "printexc.ml"; + "printf.ml"; + "queue.ml"; + "random.ml"; + "scanf.ml"; + "set.ml"; + "sort.ml"; + "stack.ml"; + "std_exit.ml"; + "stdLabels.ml"; + "stream.ml"; + "stringLabels.ml"; + "string.ml"; + "sys.ml"; + "weak.ml"; + "unix.ml"; + ] + +(** Transform an exception in a result. *) +let result_full_of_exception ctxt e = + let backtrace () = + if Printexc.backtrace_status () then + Some (Printexc.get_backtrace ()) + else + None + in + let locate_exn () = + if Printexc.backtrace_status () then + begin + let lst = + extract_backtrace_position (Printexc.get_backtrace ()) + in + let pos_opt = + try + List.find + (function + | None -> false + | Some (fn, _) -> + not (starts_with ~prefix:"oUnit" (Filename.basename fn)) && + not (List.mem fn standard_modules)) + lst + with Not_found -> + None + in + match pos_opt with + | Some (filename, line) -> + Some {OUnitLogger.filename = filename; line = line} + | None -> + None + end + else + None + in + let result = + match e with + | OUnit_failure s -> RFailure (s, locate_exn (), backtrace ()) + | Skip s -> RSkip s + | Todo s -> RTodo s + | s -> RError (Printexc.to_string s, backtrace ()) + in + let position = + match result with + | RSuccess | RSkip _ | RTodo _ | RTimeout _ -> + None + | RFailure _ | RError _ -> + OUnitLogger.position ctxt.logger + in + ctxt.path, result, position + +let report_result_full ctxt result_full = + let test_path, result, _ = result_full in + OUnitLogger.report ctxt.logger + (OUnitLogger.TestEvent (test_path, OUnitLogger.EResult result)); + result_full + +(** Isolate a function inside a context, just as [!section_ctxt] but don't + propagate a failure, register it for later. + *) +let non_fatal ctxt f = + try + section_ctxt ctxt f + with e -> + let result_full = + report_result_full ctxt (result_full_of_exception ctxt e) + in + OUnitShared.Mutex.with_lock + ctxt.shared ctxt.non_fatal_mutex + (fun () -> + ctxt.non_fatal := result_full :: !(ctxt.non_fatal)) + +(* Some shorthands which allows easy test construction *) +let (>:) s t = TestLabel(s, t) (* infix *) +let (>::) s f = TestLabel(s, TestCase(Short, f)) (* infix *) +let (>:::) s l = TestLabel(s, TestList(l)) (* infix *) + +(* Utility function to manipulate test *) +let rec test_decorate g = + function + | TestCase(l, f) -> + TestCase (l, g f) + | TestList tst_lst -> + TestList (List.map (test_decorate g) tst_lst) + | TestLabel (str, tst) -> + TestLabel (str, test_decorate g tst) + +(* Return the number of available tests *) +let rec test_case_count = + function + | TestCase _ -> 1 + | TestLabel (_, t) -> test_case_count t + | TestList l -> + List.fold_left + (fun c t -> c + test_case_count t) + 0 l + +let string_of_node = + function + | ListItem n -> + string_of_int n + | Label s -> + s + +module Path = +struct + type t = path + + let compare p1 p2 = Stdlib.compare p1 p2 + + let to_string p = String.concat ":" (List.rev_map string_of_node p) +end + +module MapPath = Map.Make(Path) + +let string_of_path = + Path.to_string + +(* Returns all possible paths in the test. The order is from test case + to root. + *) +let test_case_paths test = + let rec tcps path test = + match test with + | TestCase _ -> + [path] + + | TestList tests -> + List.concat + (mapi (fun t i -> tcps ((ListItem i)::path) t) tests) + + | TestLabel (l, t) -> + tcps ((Label l)::path) t + in + tcps [] test + +(* Test filtering with their path *) +module SetTestPath = Set.Make(String) + +let test_filter ?(skip=false) only test = + let set_test = + List.fold_left + (fun st str -> SetTestPath.add str st) + SetTestPath.empty + only + in + let rec filter_test path tst = + if SetTestPath.mem (string_of_path path) set_test then + begin + Some tst + end + + else + begin + match tst with + | TestCase (l, _) -> + begin + if skip then + Some + (TestCase + (l, fun _ -> + raise (Skip "Test disabled"))) + else + None + end + + | TestList tst_lst -> + begin + let ntst_lst = + fold_lefti + (fun ntst_lst tst i -> + let nntst_lst = + match filter_test ((ListItem i) :: path) tst with + | Some tst -> + tst :: ntst_lst + | None -> + ntst_lst + in + nntst_lst) + [] + tst_lst + in + if not skip && ntst_lst = [] then + None + else + Some (TestList (List.rev ntst_lst)) + end + + | TestLabel (lbl, tst) -> + begin + let ntst_opt = + filter_test + ((Label lbl) :: path) + tst + in + match ntst_opt with + | Some ntst -> + Some (TestLabel (lbl, ntst)) + | None -> + if skip then + Some (TestLabel (lbl, tst)) + else + None + end + end + in + filter_test [] test diff -Nru ounit-2.0.8/src/lib/ounit2/advanced/oUnitUtils.ml ounit-2.2.3/src/lib/ounit2/advanced/oUnitUtils.ml --- ounit-2.0.8/src/lib/ounit2/advanced/oUnitUtils.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/advanced/oUnitUtils.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,250 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(** + Utilities for OUnit + @author Sylvain Le Gall + *) + +let is_blank = + function + | ' ' | '\012' | '\n' | '\r' | '\t' -> true + | _ -> false + +let rec trim s = + let strlen = String.length s in + if strlen = 0 then + "" + else if is_blank s.[0] then + trim (String.sub s 1 (strlen - 1)) + else if is_blank s.[strlen - 1] then + trim (String.sub s 0 (strlen - 1)) + else + s + +let trim_comment s = + let buff = Buffer.create (String.length s) in + let idx = ref 0 in + while !idx < String.length s && s.[!idx] != '#' do + Buffer.add_char buff s.[!idx]; + incr idx + done; + Buffer.contents buff + +let split_lines s = + let rev_lst = ref [] in + let buff = Buffer.create 13 in + let flush () = + rev_lst := Buffer.contents buff :: !rev_lst; + Buffer.clear buff + in + if String.length s > 0 then + begin + String.iter + (function + | '\n' -> flush () + | c -> Buffer.add_char buff c) + s; + flush (); + List.rev !rev_lst + end + else + [] + +let starts_with ~prefix s = + if String.length s >= String.length prefix then + String.sub s 0 (String.length prefix) = prefix + else + false + +let start_substr ~prefix s = + if starts_with ~prefix s then begin + let prefix_len = String.length prefix in + true, String.sub s prefix_len (String.length s - prefix_len) + end else begin + false, s + end + +let extract_backtrace_position str = + let prefixes = + [ + "Raised at "; + "Re-raised at "; + "Raised by primitive operation at "; + "Called from "; + ] + in + + let rec extract_one_line s prefixes = + match prefixes with + | [] -> None + | prefix :: tl -> + let really_starts, eol = start_substr ~prefix s in + if really_starts then begin + if eol = "unknown location" then + None + else + try + Scanf.sscanf eol "%_s@\"%s@\", line %d, characters %d-%d" + (fun fn line _ _ -> Some (fn, line)) + with Scanf.Scan_failure _ -> + None + end else begin + extract_one_line s tl + end + in + List.map + (fun s -> extract_one_line s prefixes) + (split_lines str) + +let cmp_float ?(epsilon = 0.00001) a b = + match classify_float a, classify_float b with + | FP_infinite, FP_infinite -> a = b + | FP_infinite, _ | _, FP_infinite | FP_nan, _ | _, FP_nan -> false + | _, _ -> + abs_float (a -. b) <= epsilon *. (abs_float a) || + abs_float (a -. b) <= epsilon *. (abs_float b) + +let buff_format_printf f = + let buff = Buffer.create 13 in + let fmt = Format.formatter_of_buffer buff in + f fmt; + Format.pp_print_flush fmt (); + Buffer.contents buff + +(* Applies function f in turn to each element in list. Function f takes + one element, and integer indicating its location in the list *) +let mapi f l = + let rec rmapi cnt l = + match l with + | [] -> + [] + + | h :: t -> + (f h cnt) :: (rmapi (cnt + 1) t) + in + rmapi 0 l + +let fold_lefti f accu l = + let rec rfold_lefti cnt accup l = + match l with + | [] -> + accup + + | h::t -> + rfold_lefti (cnt + 1) (f accup h cnt) t + in + rfold_lefti 0 accu l + +let now () = + Unix.gettimeofday () + +(* Function which runs the given function and returns the running time + of the function, and the original result in a tuple *) +let time_fun f x = + let begin_time = now () in + let res = f x in + (now () -. begin_time, res) + +let date_iso8601 ?(tz=true) timestamp = + let tm = Unix.gmtime timestamp in + let res = + Printf.sprintf + "%04d-%02d-%02dT%02d:%02d:%02d" + (1900 + tm.Unix.tm_year) + (1 + tm.Unix.tm_mon) + tm.Unix.tm_mday + tm.Unix.tm_hour + tm.Unix.tm_min + tm.Unix.tm_sec + in + if tz then + res ^ "+00:00" + else + res + +let buildir = + (* Detect a location where we can store semi-temporary data: + - it must survive a compilation + - it must be removed with 'make clean' + *) + let pwd = Sys.getcwd () in + let dir_exists fn = Sys.file_exists fn && Sys.is_directory fn in + let concat, dirname = Filename.concat, Filename.dirname in + List.find + dir_exists + [ + concat pwd "_build"; + concat (dirname pwd) "_build"; + concat (dirname (dirname pwd)) "_build"; + pwd + ] + +let failwithf fmt = + Printf.ksprintf failwith fmt + +let opt f = function Some v -> f v | None -> () + +let fqdn () = + try + (Unix.gethostbyname (Unix.gethostname ())).Unix.h_name + with + Not_found -> "localhost" + +let shardf = Printf.sprintf "%s#%02d" (Unix.gethostname ()) + +let string_of_process_status = + function + | Unix.WEXITED n -> + Printf.sprintf "Exited with code %d" n + | Unix.WSIGNALED n -> + Printf.sprintf "Killed by signal %d" n + | Unix.WSTOPPED n -> + Printf.sprintf "Stopped by signal %d" n + +let make_counter () = + let data = Hashtbl.create 13 in + let all () = + Hashtbl.fold + (fun k v lst -> (k, v) :: lst) + data [] + in + let incr k = + let v = + try + Hashtbl.find data k + with Not_found -> + 0 + in + Hashtbl.replace data k (v + 1) + in + all, incr diff -Nru ounit-2.0.8/src/lib/ounit2/dune ounit-2.2.3/src/lib/ounit2/dune --- ounit-2.0.8/src/lib/ounit2/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,9 @@ +(library + (name oUnit) + (public_name ounit2) + (wrapped false) + (libraries unix ounit2.advanced)) + +(documentation + (package ounit2) + (mld_files index)) diff -Nru ounit-2.0.8/src/lib/ounit2/index.mld ounit-2.2.3/src/lib/ounit2/index.mld --- ounit-2.0.8/src/lib/ounit2/index.mld 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/index.mld 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,316 @@ +{1 OUnit: xUnit testing framework for OCaml} + +{2 What is unit Testing?} + +A test-oriented methodology for software development is most +effective when tests are easy to create, change, and execute. The +JUnit tool pioneered test-first development in Java. OUnit is +an adaptation of JUnit to OCaml. + +With OUnit, as with JUnit, you can easily create tests, name them, +group them into suites, and execute them, with the framework +checking the results automatically. + +{!modules: OUnit2 OUnit} + +{2 Getting Started} + +The basic principle of a OUnit test suite is to have a {i test.ml} file which +will contain the tests, and an OCaml module under test, here named {i foo.ml}. + +File {i foo.ml}: +{[ +(* The functions we wish to test *) +let unity x = x;; +let funix ()= 0;; +let fgeneric () = failwith "Not implemented";; +]} + +The main point of a test is to check that the function under test has the +expected behavior. You check the behavior using assert functions. The simplest +one is {!OUnit2.assert_equal}. This function compares the result of the +function under test with an expected result. + +Some useful functions include: +- {!OUnit2.assert_equal} the basic assert function +- {!OUnit2.(>:::)} to define a list of tests +- {!OUnit2.(>::)} to name a test +- {!OUnit2.run_test_tt_main} to run the test suite you define +- {!OUnit2.bracket_tmpfile} that create a temporary filename. +- {!OUnit2.bracket_tmpdir} that create a temporary directory. + +File {i test.ml}: +{[ +open OUnit2;; + +let test1 test_ctxt = assert_equal "x" (Foo.unity "x");; + +let test2 test_ctxt = assert_equal 100 (Foo.unity 100);; + +(* Name the test cases and group them together *) +let suite = +"suite">::: + ["test1">:: test1; + "test2">:: test2] +;; + +let () = + run_test_tt_main suite +;; +]} + +And compile the module + +{[ +$ ocamlfind ocamlc -o test -package oUnit -linkpkg -g foo.ml test.ml +]} + +A executable named "test" will be created. When run it produces the +following output. + +{[ +$ ./test +.. +Ran: 2 tests in: 0.00 Seconds +OK +]} + +When using {!OUnit2.run_test_tt_main}, a non-zero exit code signals that the +test suite failed. + +{2 Extra features} + +OUnit supports colored output and JUnit/HTML generation. They are command line +flags or environment variables that you can set before running OUnit test +suites. + +{ul +{- Colored output: +{ul + {- Set the environment variable [OUNIT_CI=true]} + {- Use the command line flag [-ci true]} +}} +{- JUnit generation: +{ul + {- Set the environment variable [OUNIT_OUTPUT_JUNIT_FILE=fn]} + {- Use the command line flag [-output-junit-file fn]} +}} +{- HTML report +{ul + {- Set the environment variable [OUNIT_OUTPUT_HTML_DIR=fn]} + {- Use the command line flag [-output-html-dir fn]} +}}} + +{2 Advanced usage} + +This section is only for advanced users who wish to uncover the power of OUnit. + +{!modules: OUnit2} + +{3 Error reporting} + +The error reporting part of OUnit is quite important. If you want to identify +the failure, you should tune the display of the value and the test. + +Here is a list of things you can display: +- name of the test: OUnit uses numbers to define path's test. But an error + reporting about a failed test "0:1:2" is less explicit than + "OUnit:0:comparator:1:float_comparator:2" +- [~msg] parameter: it allows you to define, say, which assert has failed in your + test. When you have more than one assert in a test, you should provide a + [~msg] to differentiate them +- [~printer] parameter: {!OUnit2.assert_equal} allows you to define a printer for + compared values. A message ["abcd" is not equal to "defg"] is better than [not + equal] + +{[ +open OUnit2;; + +let _ = + "mytest">:: + (fun test_ctxt -> + assert_equal + ~msg:"int value" + ~printer:string_of_int + 1 + (Foo.unity 1)) +;; +]} + +{3 Command-line arguments} + +{!OUnit2.run_test_tt_main} already provides a set of command-line arguments to +help users run only the tests they want: +- [-only-test]: skip all the tests except this one, you can use this flag + several time to select more than one test to run +- [-list-test]: list all the available tests and exit +- [-help]: display help message and exit + +It is also possible to add your own command-line arguments, environment +variables and config file variables. You should do it if you want to define some +extra arguments. + +For example: + +{[ +open OUnit2;; + +let my_program = + Conf.make_exec "my_program" +;; + +let test1 test_ctxt = + assert_command (my_program test_ctxt) [] +;; + +let () = + run_test_tt_main ("test1" >:: test1) +;; +]} + +The [Conf.make_*] creates a command-line argument, an environment variable and +a config file variable. + +{3 Skip and todo tests} + +Tests are not always meaningful and can even fail because something is missing +in the environment. In order to handle this, you can define a skip condition +that will skip the test. + +If you start by defining your tests rather than implementing the functions +under test, you know that some tests will just fail. You can mark these tests +as pending todo tests. This way they will be reported differently in your test suite. + +{[ +open OUnit2;; + +let _ = + "allfuns" >::: + [ + "funix">:: + (fun test_ctxt -> + skip_if (Sys.os_type = "Win32") "Don't work on Windows"; + assert_equal + 0 + (Foo.funix ())); + + "fgeneric">:: + (fun test_ctxt -> + todo "fgeneric not implemented"; + assert_equal + 0 + (Foo.fgeneric ())); + ] +;; +]} + +{3 OUnit2.Threads} + +This module provide thread related utilities. In particular, it provides a +"thread" runner, that allows to run concurrently tests using OCaml threads. +This should provide a good level of parallelism on Windows, for UNIX systems +it is recommended to use the standard "process" runner. + +To install the extra thread runner: + +{[ +let () = OUnitThreads.init () +]} + +{!modules: OUnitThreads} + +{3 Effective OUnit} + +This section has general tips about unit testing and OUnit. It is the +result of some years using OUnit in real-world applications. + +- test everything: the more you create tests, the better chance you have to + catch errors in your program early. Every submitted bug to your application + should have a matching test. This is a good practice, but it is not always + easy to implement. +- test only what is really exported: on the long term, you have to maintain your + test suite. If you test low-level functions, you'll have a lot of tests to + rewrite. You should focus on creating tests for functions for which the + behavior shouldn't change. +- test fast: the best test suite is the one that runs after every single build. + You should set your default Makefile target to run the test suite. It means + that your test suite should be fast to run, typically, a 10s test suite is + fine. +- test long: contrary to the former tip, you should also have a complete test + suite which can be very long to run. The best way to achieve both tips, is to + define a command-line argument [-long] and skip the tests that are too long in + your test suite according to it. When you do a release, you should run + your long test suite. +- family tests: when testing behavior, most of the time you call exactly the + same code with different arguments. In this case [List.map] and + {!OUnit2.(>:::)} are your friends. For example: + +{[ +open OUnit2;; + +let _ = + "Family">::: + (List.map + (fun (arg,res) -> + let title = + Printf.sprintf "%s->%s" arg res + in + title >:: + (fun test_ctxt -> + assert_equal res (Foo.unity arg))) + ["abcd", "abcd"; + "defg", "defg"; + "wxyz", "wxyz"]) +;; +]} + +- test failures and successes: the most obvious thing you want to test are + successes, i.e. that you get the expected behavior in the normal case. But + most of the errors arise in corner cases and in the code of the test itself. + For example, you can have a partial application of your {!OUnit2.assert_equal} + and never encounter any errors, just because the [assert_equal] is not called. + In this case, if you test errors as well as the "happy path", you will have + a notice the missing errors as well. +- set up and clean your environment in the test: you should not set up and clean + your test environment outside the test. Ideally, if you run no tests, the + program should do nothing. This also ensures that you are always testing in a + clean environment, not polluted by the result of failed tests of an earlier + test run. This includes the process environment, like current working + directory. + +{[ +open OUnit2;; + +let _ = + (* We need to call a function in a particular directory *) + "change-dir-and-run">:: + (fun test_ctxt -> + assert_command ~chdir:"/foo/test" "ls" []) +;; +]} +- separate your tests: OUnit test code should live outside the code under a + directory called {i test}. This allow to drop the dependency on OUnit when + distributing your library/application. This also enables people to easily + make a difference from what really matters (the main code) and what are only + tests. It is also possible to have the tests directly in the code, like in + Quickcheck-style tests. + +The unit testing scope is always hard to define. Unit testing should be about +testing a single feature. But OUnit can also help you to test higher-level +behavior, by running a full program for example. While it isn't real unit +testing, you can use OUnit to do it and should not hesitate to do it. + +In terms of lines of codes, a test suite can represent from 10% to 150% of the +code under test. With time, your test suite will grow faster than your +program/library. A good ratio is 33%. + +{3 OUnit2.Advanced} + +These modules should only be used when building low-level OUnit features. They +allow to create your own process runner or logger. + +Modules available in [ounit2.advanced]: +{!modules: OUnitAssert OUnitBracket OUnitCache OUnitCheckEnv OUnitChooser OUnitConf OUnitCore OUnitDiff OUnitLogger OUnitLoggerCI OUnitLoggerHTML OUnitLoggerJUnit OUnitLoggerStd OUnitPlugin OUnitPropList OUnitResultSummary OUnitRunner OUnitRunnerProcesses OUnitShared OUnitState OUnitTest OUnitTestData OUnitUtils} + +@author Maas-Maarten Zeeman +@author Sylvain Le Gall diff -Nru ounit-2.0.8/src/lib/ounit2/oUnit2.ml ounit-2.2.3/src/lib/ounit2/oUnit2.ml --- ounit-2.0.8/src/lib/ounit2/oUnit2.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/oUnit2.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,97 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open OUnitTest + +let (>:) = OUnitTest.(>:) +let (>::) = OUnitTest.(>::) +let (>:::) = OUnitTest.(>:::) + +type test_ctxt = OUnitTest.ctxt +type test_fun = OUnitTest.test_fun +type test_length = OUnitTest.test_length +type test = OUnitTest.test +let test_case ?(length=Short) f = TestCase(length, f) +let test_list lst = TestList lst + +type log_severity = OUnitLogger.log_severity + +let assert_failure = OUnitAssert.assert_failure +let assert_bool = OUnitAssert.assert_bool +let assert_string = OUnitAssert.assert_string +(* Upgrade to OUnit v2, using logger. *) +(* let assert_command = OUnitAssert.assert_command *) +let assert_command + ?exit_code ?sinput ?foutput ?use_stderr ?backtrace ?chdir ?env ~ctxt + prg args = + OUnitAssert.assert_command + ?exit_code ?sinput ?foutput ?use_stderr ?backtrace ?chdir ?env ~ctxt + prg args +let assert_equal = OUnitAssert.assert_equal +let assert_raises = OUnitAssert.assert_raises +let skip_if = OUnitAssert.skip_if +let todo = OUnitAssert.todo +let cmp_float = OUnitUtils.cmp_float +let bracket = OUnitBracket.create +let bracket_tmpfile = OUnitBracket.bracket_tmpfile +let bracket_tmpdir = OUnitBracket.bracket_tmpdir +let with_bracket_chdir test_ctxt dn f = + OUnitBracket.with_bracket test_ctxt + (OUnitBracket.bracket_chdir dn) + (fun _ -> f) + + +let non_fatal = OUnitTest.non_fatal +let run_test_tt_main = OUnitCore.run_test_tt_main + +let logf ctxt log_severity fmt = + OUnitLogger.Test.logf ctxt.test_logger log_severity fmt + +let in_testdata_dir ctxt path = + OUnitTestData.in_testdata_dir ctxt.conf path + +let conf_wrap f name default help = + let get = f name default help in + fun ctxt -> get ctxt.conf + +module Conf = +struct + type 'a conf_t = string -> 'a -> Arg.doc -> test_ctxt -> 'a + let make_string = conf_wrap OUnitConf.make_string + let make_string_opt = conf_wrap OUnitConf.make_string_opt + let make_int = conf_wrap OUnitConf.make_int + let make_float = conf_wrap OUnitConf.make_float + let make_bool = conf_wrap OUnitConf.make_bool + let make_exec name = + let get = OUnitConf.make_exec name in + fun ctxt -> get ctxt.conf +end diff -Nru ounit-2.0.8/src/lib/ounit2/oUnit2.mli ounit-2.2.3/src/lib/ounit2/oUnit2.mli --- ounit-2.0.8/src/lib/ounit2/oUnit2.mli 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/oUnit2.mli 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,307 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(** Unit test building blocks (v2). + + @author Sylvain Le Gall + *) + +(** {2 Types} *) + +(** Context of a test. *) +type test_ctxt = OUnitTest.ctxt + +(** The type of test function. *) +type test_fun = test_ctxt -> unit + +(** The type of test. *) +type test = OUnitTest.test + +(** The expected length of the test. *) +type test_length = OUnitTest.test_length + +(** {2 Assertions} + + Assertions are the basic building blocks of unittests. *) + +(** Signals a failure. This will raise an exception with the specified + string. + + @raise Failure signal a failure *) +val assert_failure : string -> 'a + +(** Signals a failure when bool is false. The string identifies the + failure. + + @raise Failure signal a failure *) +val assert_bool : string -> bool -> unit + +(** Signals a failure when the string is non-empty. The string identifies the + failure. + + @raise Failure signal a failure *) +val assert_string : string -> unit + +(** [assert_command prg args] Run the command provided. + + @param exit_code expected exit code + @param sinput provide this [char Stream.t] as input of the process + @param foutput run this function on output, it can contains an + [assert_equal] to check it + @param use_stderr redirect [stderr] to [stdout] + @param backtrace Set OCAMLRUNPARAM=b + @param chdir Chdir into a directory before running the command. + @param env Unix environment + @param verbose if a failed, dump stdout/stderr of the process to stderr + *) +val assert_command : + ?exit_code:Unix.process_status -> + ?sinput:char Stream.t -> + ?foutput:(char Stream.t -> unit) -> + ?use_stderr:bool -> + ?backtrace:bool -> + ?chdir:string -> + ?env:string array -> + ctxt:test_ctxt -> + string -> string list -> unit + +(** [assert_equal expected real] Compares two values, when they are not equal a + failure is signaled. + + @param cmp customize function to compare, default is [=] + @param printer value printer, don't print value otherwise + @param pp_diff if not equal, ask a custom display of the difference + using [diff fmt exp real] where [fmt] is the formatter to use + @param msg custom message to identify the failure + @param ctxt if provided, always print expected and real value + + @raise Failure signal a failure + *) +val assert_equal : + ?ctxt:test_ctxt -> + ?cmp:('a -> 'a -> bool) -> + ?printer:('a -> string) -> + ?pp_diff:(Format.formatter -> ('a * 'a) -> unit) -> + ?msg:string -> 'a -> 'a -> unit + +(** Asserts if the expected exception was raised. + + @param msg identify the failure + + @raise Failure description *) +val assert_raises : ?msg:string -> exn -> (unit -> 'a) -> unit + +(** {2 Skipping tests } + + In certain condition test can be written but there is no point running it, + because they are not significant (missing OS features for example). In this + case this is not a failure nor a success. Following functions allow you to + escape test, just as assertion but without the same error status. + + A test skipped is counted as success. A test todo is counted as failure. + *) + +(** [skip cond msg] If [cond] is true, skip the test for the reason explain in + [msg]. For example [skip_if (Sys.os_type = "Win32") "Test a doesn't run on + windows"]. + *) +val skip_if : bool -> string -> unit + +(** The associated test is still to be done, for the reason given. + *) +val todo : string -> unit + +(** {2 Compare Functions} *) + +(** Compare floats up to a given relative error. + + In keeping with standard floating point semantics, NaN is not equal to + anything: [cmp_float nan nan = false]. + + @param epsilon if the difference is smaller [epsilon] values are equal + *) +val cmp_float : ?epsilon:float -> float -> float -> bool + +(** {2 Bracket} + + A bracket is a registered object with setUp and tearDown in unit tests. + Data generated during the setUp will be automatically tearDown when the test + ends. + *) + +(** [bracket set_up tear_down test_ctxt] set up an object and register it to be + tore down in [test_ctxt]. + *) +val bracket : (test_ctxt -> 'a) -> ('a -> test_ctxt -> unit) -> test_ctxt -> 'a + +(** [bracket_tmpfile test_ctxt] Create a temporary filename and matching output + channel. The temporary file is removed after the test. + + @param prefix see [Filename.open_temp_file] + @param suffix see [Filename.open_temp_file] + @param mode see [Filename.open_temp_file] + *) +val bracket_tmpfile: + ?prefix:string -> + ?suffix:string -> + ?mode:open_flag list -> + test_ctxt -> (string * out_channel) + +(** [bracket_tmpdir test_ctxt] Create a temporary dirname. The temporary + directory is removed after the test. + + @param prefix see [Filename.open_temp_file] + @param suffix see [Filename.open_temp_file] + *) +val bracket_tmpdir: + ?prefix:string -> + ?suffix:string -> + test_ctxt -> string + +(** [with_bracket_chdir test_ctxt dn f] change directory to [dn] during + execution of function [f]. In order to [Sys.chdir], we need to take a lock + to avoid other tests trying to do change the current directory at the same + time. So this bracket is not directly accessible in order to use it only on + shorter piece of code. + *) +val with_bracket_chdir: test_ctxt -> string -> (test_ctxt -> 'a) -> 'a + +(** {2 Constructing Tests} *) + +(** Create a TestLabel for a test *) +val (>:) : string -> test -> test + +(** Create a TestLabel for a TestCase *) +val (>::) : string -> test_fun -> test + +(** Create a TestLabel for a TestList *) +val (>:::) : string -> test list -> test + +(** Generic function to create a test case. *) +val test_case : ?length:test_length -> test_fun -> test + +(** Generic function to create a test list. *) +val test_list : test list -> test + +(** Some shorthands which allows easy test construction. + + Examples: + + - ["test1" >: TestCase((fun _ -> ()))] => + [TestLabel("test2", TestCase((fun _ -> ())))] + - ["test2" >:: (fun _ -> ())] => + [TestLabel("test2", TestCase((fun _ -> ())))] + - ["test-suite" >::: ["test2" >:: (fun _ -> ());]] => + [TestLabel("test-suite", TestSuite([TestLabel("test2", + TestCase((fun _ -> ())))]))] +*) + +(** {2 Performing Tests} *) + +(** Severity level for log. *) +type log_severity = [ `Error | `Warning | `Info ] + +(** Log into OUnit logging system. + *) +val logf: test_ctxt -> log_severity -> ('a, unit, string, unit) format4 -> 'a + +(** Build a filename for a file that should be located in the test data dir. + + The test data dir, can be defined on the command line (preferably absolute) + The default option is to locate it in topsrcdir/test/data. + *) +val in_testdata_dir: test_ctxt -> string list -> string + +(** [non_fatal ctxt f] Run [f] but if an exception is raised or an assert fails, + don't stop, just register the result. The global test running result will + mix in the non fatal result to determine the success or failure of the test. + *) +val non_fatal: test_ctxt -> (test_ctxt -> unit) -> unit + +(** Define command line options, environment variables and file configuration. + + This module helps to define configuration options that are translated to + command line options et al. + + The name defined for the variable is: + - should be a valid OCaml identifier + - kept as is for use in configuration file. (foo_bar = "") + - '_' are replaced by '-' and a leading '-' is added for command line + (-foo "") + - capitalized and prefixed by OUNIT_ for environment (OUNIT_FOO_BAR="") + *) +module Conf: +sig + (** The default type of function that create a configuration option of type + 'a. + *) + type 'a conf_t = string -> 'a -> Arg.doc -> test_ctxt -> 'a + + (** [make_string name default help] Create a string configuration + option with default value [default] and a short help string. + The result of the partial application of the function can be used + inside tests to be evaluated to a value. + +{[ +let my_option = Conf.make_string "my_option" "the default" "A default option." + +let tests = + "ATest" >:: + (fun test_ctxt -> let option_value = my_option test_ctxt in ()) + +]} + *) + val make_string: string conf_t + + (** Create a [string option] configuration option. See [!make_string]. *) + val make_string_opt: (string option) conf_t + + (** Create an [int] configuration option. See [!make_string]. *) + val make_int: int conf_t + + (** Create a [float] configuration option. See [!make_string]. *) + val make_float: float conf_t + + (** Create a [bool] configuration option. See [!make_string]. *) + val make_bool: bool conf_t + + (** [make_exec execname] Create a option to define an executable. *) + val make_exec: string -> test_ctxt -> string +end + +(** Main version of the text based test runner. It reads the supplied command + line arguments to set the verbose level and limit the number of test to + run. + + @param test the test suite to run. + *) +val run_test_tt_main : ?exit:(int -> unit) -> test -> unit diff -Nru ounit-2.0.8/src/lib/ounit2/oUnit.ml ounit-2.2.3/src/lib/ounit2/oUnit.ml --- ounit-2.0.8/src/lib/ounit2/oUnit.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/oUnit.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,378 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open OUnitUtils + +let get_test_context, + set_test_context, + reset_test_context = + let context_opt = ref None in + (* get *) + (fun () -> + match !context_opt with + | Some ctxt -> ctxt + | None -> failwith "Function need to be called from inside a test."), + (fun ctxt -> + context_opt := Some ctxt), + (fun _ -> + context_opt := None) + +type node = ListItem of int | Label of string + +let node1_of_node = + function + | OUnitTest.ListItem i -> ListItem i + | OUnitTest.Label s -> Label s + +let node_of_node1 = + function + | ListItem i -> OUnitTest.ListItem i + | Label s -> OUnitTest.Label s + +type path = node list + +let path1_of_path pth = + List.map node1_of_node pth + +type test_fun = unit -> unit + +type test = + TestCase of test_fun + | TestList of test list + | TestLabel of string * test + +let rec test1_of_test = + function + | OUnitTest.TestCase (_, f) -> TestCase (fun () -> f (get_test_context ())) + | OUnitTest.TestList lst -> TestList (List.map test1_of_test lst) + | OUnitTest.TestLabel (str, tst) -> TestLabel (str, test1_of_test tst) + +let rec test_of_test1 = + function + | TestCase f -> + OUnitTest.TestCase + (OUnitTest.Short, + fun ctxt -> + set_test_context ctxt; + f (); + reset_test_context ()) + | TestList lst -> OUnitTest.TestList (List.map test_of_test1 lst) + | TestLabel (str, tst) -> OUnitTest.TestLabel (str, test_of_test1 tst) + +let rec ounit2_of_ounit1 = + function + | TestCase f -> + OUnit2.test_case + (fun ctxt -> + set_test_context ctxt; + f (); + reset_test_context ()) + | TestList lst -> + OUnit2.test_list (List.map ounit2_of_ounit1 lst) + | TestLabel (lbl, test) -> + OUnit2.( >: ) lbl (ounit2_of_ounit1 test) + +type test_result = + RSuccess of path + | RFailure of path * string + | RError of path * string + | RSkip of path * string + | RTodo of path * string + +let test_result1_of_test_result path rslt = + let path1 = + path1_of_path path + in + let rslt1 = + match rslt with + | OUnitTest.RSuccess -> + RSuccess path1 + | OUnitTest.RFailure (str, _, _) -> + RFailure (path1, str) + | OUnitTest.RError (str, _) -> + RError (path1, str) + | OUnitTest.RSkip str -> + RSkip (path1, str) + | OUnitTest.RTodo str -> + RTodo (path1, str) + | OUnitTest.RTimeout test_length -> + RError (path1, + (Printf.sprintf + "timeout after %.1fs." + (OUnitTest.delay_of_length test_length))) + in + rslt1 + + +type test_event = + EStart of path + | EEnd of path + | EResult of test_result + +type test_results = test_result list + +let list_result1_of_list_result = + List.map + (fun (pth, rslt, _) -> + test_result1_of_test_result pth rslt) + +let assert_failure = + OUnitAssert.assert_failure + +let assert_bool = + OUnitAssert.assert_bool + +let ( @? ) = + OUnitAssert.assert_bool + +let assert_string = + OUnitAssert.assert_string + +let assert_command + ?exit_code ?sinput ?foutput ?use_stderr ?env ?(verbose=false) prg args = + let ctxt = + let ctxt = get_test_context () in + let conf' = Hashtbl.copy ctxt.OUnitTest.conf in + OUnitConf.set ~origin:"OUnit.assert_command" conf' + "verbose" (string_of_bool verbose); + { + ctxt with + OUnitTest.test_logger = + OUnitLogger.Test.create + (OUnitLoggerStd.std_logger conf' OUnitLogger.shard_default) + ctxt.OUnitTest.path; + } + in + OUnitAssert.assert_command + ?exit_code ?sinput ?foutput ?use_stderr ?env ~ctxt + prg args + +let assert_equal ?cmp ?printer ?pp_diff ?msg a b = + OUnitAssert.assert_equal ?cmp ?printer ?pp_diff ?msg a b + +let assert_raises ?msg exc f = + OUnitAssert.assert_raises ?msg exc f + +let skip_if = + OUnitAssert.skip_if + +let todo = + OUnitAssert.todo + +let cmp_float ?epsilon f1 f2 = + OUnitUtils.cmp_float ?epsilon f1 f2 + +let bracket pre f post () = + OUnitTest.section_ctxt (get_test_context ()) + (fun ctxt -> + let fixture = + OUnitBracket.create + (fun _ -> pre ()) + (fun fixture _ -> post fixture) + ctxt + in + let () = f fixture in + ()) + +let bracket_tmpfile ?prefix ?suffix ?mode gen () = + OUnitTest.section_ctxt (get_test_context ()) + (fun ctxt -> + let fixture = + OUnitBracket.bracket_tmpfile ?prefix ?suffix ?mode ctxt + in + gen fixture) + +let (>:) a b = + test1_of_test (OUnitTest.(>:) a (test_of_test1 b)) + +let (>::) a b = + test1_of_test (OUnitTest.(>::) a (fun _ -> b ())) + +let (>:::) a b = + test1_of_test (OUnitTest.(>:::) a (List.map test_of_test1 b)) + +let test_decorate g tst = + test1_of_test + (OUnitTest.test_decorate + (fun f -> + let f1 = (fun () -> f (get_test_context ())) in + let f1' = g f1 in + (fun ctxt -> + set_test_context ctxt; + f1' (); + reset_test_context ())) + (test_of_test1 tst)) + +let test_filter ?skip lst test = + let res = + OUnitTest.test_filter ?skip lst (test_of_test1 test) + in + match res with + | Some tst -> Some (test1_of_test tst) + | None -> None + +let test_case_count tst = + OUnitTest.test_case_count (test_of_test1 tst) + +let string_of_node nd = + OUnitTest.string_of_node (node_of_node1 nd) + +let string_of_path pth = + OUnitTest.string_of_path (List.map node_of_node1 pth) + +let test_case_paths tst = + let lst = + OUnitTest.test_case_paths (test_of_test1 tst) + in + List.map + (List.map node1_of_node) + lst + +let default_v1_conf ?(verbose=false) () = + OUnitConf.default + ~preset: + [ + "chooser", "simple"; + "runner", "sequential"; + "results_style_1_X", "true"; + "verbose", (string_of_bool verbose); + "output_file", "none"; + ] + () + +let perform_test logger1 tst = + let logger = + OUnitLogger.fun_logger + (function + | {OUnitLogger.event = OUnitLogger.GlobalEvent _; _} -> + () + | {OUnitLogger.event = OUnitLogger.TestEvent (path, test_event); _} -> + begin + let path1 = + path1_of_path path + in + match test_event with + | OUnitLogger.EStart -> + logger1 (EStart path1) + | OUnitLogger.EEnd -> + logger1 (EEnd path1) + | OUnitLogger.EResult rslt -> + logger1 (EResult (test_result1_of_test_result path rslt)) + | OUnitLogger.ELog _ | OUnitLogger.ELogRaw _ -> + () + end) + ignore + in + let conf = default_v1_conf () in + list_result1_of_list_result + (OUnitCore.perform_test + conf + logger + (snd (OUnitRunner.choice conf)) + (snd (OUnitChooser.choice conf)) + (test_of_test1 tst)) + +let run_test_tt ?verbose test = + let conf = default_v1_conf ?verbose () in + list_result1_of_list_result + (OUnitCore.run_test_tt + conf + (OUnitLoggerStd.create conf OUnitLogger.shard_default) + (snd (OUnitRunner.choice conf)) + (snd (OUnitChooser.choice conf)) + (test_of_test1 test)) + +let run_test_tt_main ?(arg_specs=[]) ?(set_verbose=ignore) suite = + let suite = test_of_test1 suite in + let only_test = ref [] in + let list_test = ref false in + let verbose = ref false in + let specs = + [ + "-verbose", + Arg.Set verbose, + " Rather than displaying dots while running the test, be more verbose."; + + "-only-test", + Arg.String (fun str -> only_test := str :: !only_test), + "path Run only the selected tests."; + + "-list-test", + Arg.Set list_test, + " List tests"; + ] @ arg_specs + in + let () = + Arg.parse + (Arg.align specs) + (fun x -> raise (Arg.Bad ("Bad argument : " ^ x))) + ("usage: " ^ Sys.argv.(0) ^ " [options] [-only-test path]*") + in + let conf = default_v1_conf ~verbose:!verbose () in + set_verbose (OUnitLoggerStd.verbose conf); + if !list_test then + begin + List.iter + (fun pth -> print_endline (OUnitTest.string_of_path pth)) + (OUnitTest.test_case_paths suite); + [] + end + else + begin + let nsuite = + if !only_test = [] then + suite + else + begin + match OUnitTest.test_filter ~skip:true !only_test suite with + | Some test -> + test + | None -> + failwithf + "Filtering test %s lead to no tests." + (String.concat ", " !only_test) + end + in + + let test_results = + OUnitCore.run_test_tt + conf + (OUnitLoggerStd.std_logger conf OUnitLogger.shard_default) + (snd (OUnitRunner.choice conf)) + (snd (OUnitChooser.choice conf)) + nsuite + in + if not (OUnitResultSummary.was_successful test_results) then + exit 1 + else + list_result1_of_list_result test_results; + end diff -Nru ounit-2.0.8/src/lib/ounit2/oUnit.mli ounit-2.2.3/src/lib/ounit2/oUnit.mli --- ounit-2.0.8/src/lib/ounit2/oUnit.mli 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/oUnit.mli 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,287 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(** Unit test building blocks + + @author Maas-Maarten Zeeman + @author Sylvain Le Gall + *) + +(** {2 Assertions} + + Assertions are the basic building blocks of unittests. *) + +(** Signals a failure. This will raise an exception with the specified + string. + + @raise Failure signal a failure *) +val assert_failure : string -> 'a + +(** Signals a failure when bool is false. The string identifies the + failure. + + @raise Failure signal a failure *) +val assert_bool : string -> bool -> unit + +(** Shorthand for assert_bool + + @raise Failure to signal a failure *) +val ( @? ) : string -> bool -> unit + +(** Signals a failure when the string is non-empty. The string identifies the + failure. + + @raise Failure signal a failure *) +val assert_string : string -> unit + +(** [assert_command prg args] Run the command provided. + + @param exit_code expected exit code + @param sinput provide this [char Stream.t] as input of the process + @param foutput run this function on output, it can contains an + [assert_equal] to check it + @param use_stderr redirect [stderr] to [stdout] + @param env Unix environment + @param verbose if failed, dump stdout/stderr of the process to stderr + + @since 1.1.0 + *) +val assert_command : + ?exit_code:Unix.process_status -> + ?sinput:char Stream.t -> + ?foutput:(char Stream.t -> unit) -> + ?use_stderr:bool -> + ?env:string array -> + ?verbose:bool -> + string -> string list -> unit + +(** [assert_equal expected real] Compares two values, when they are not equal a + failure is signaled. + + @param cmp customize function to compare, default is [=] + @param printer value printer, don't print value otherwise + @param pp_diff if not equal, ask a custom display of the difference + using [diff fmt exp real] where [fmt] is the formatter to use + @param msg custom message to identify the failure + + @raise Failure signal a failure + + @version 1.1.0 + *) +val assert_equal : + ?cmp:('a -> 'a -> bool) -> + ?printer:('a -> string) -> + ?pp_diff:(Format.formatter -> ('a * 'a) -> unit) -> + ?msg:string -> 'a -> 'a -> unit + +(** Asserts if the expected exception was raised. + + @param msg identify the failure + + @raise Failure description *) +val assert_raises : ?msg:string -> exn -> (unit -> 'a) -> unit + +(** {2 Skipping tests } + + In certain condition test can be written but there is no point running it, + because they are not significant (missing OS features for example). In this + case this is not a failure nor a success. Following functions allow you to + escape test, just as assertion but without the same error status. + + A test skipped is counted as success. A test todo is counted as failure. + *) + +(** [skip cond msg] If [cond] is true, skip the test for the reason explain in + [msg]. For example [skip_if (Sys.os_type = "Win32") "Test a doesn't run on + windows"]. + + @since 1.0.3 + *) +val skip_if : bool -> string -> unit + +(** The associated test is still to be done, for the reason given. + + @since 1.0.3 + *) +val todo : string -> unit + +(** {2 Compare Functions} *) + +(** Compare floats up to a given relative error. + + @param epsilon if the difference is smaller [epsilon] values are equal + *) +val cmp_float : ?epsilon:float -> float -> float -> bool + +(** {2 Bracket} + + A bracket is a functional implementation of the commonly used + setUp and tearDown feature in unittests. It can be used like this: + + ["MyTestCase" >:: (bracket test_set_up test_fun test_tear_down)] + + *) + +(** [bracket set_up test tear_down] The [set_up] function runs first, then + the [test] function runs and at the end [tear_down] runs. The + [tear_down] function runs even if the [test] failed and help to clean + the environment. + *) +val bracket: (unit -> 'a) -> ('a -> unit) -> ('a -> unit) -> unit -> unit + +(** [bracket_tmpfile test] The [test] function takes a temporary filename + and matching output channel as arguments. The temporary file is created + before the test and removed after the test. + + @param prefix see [Filename.open_temp_file] + @param suffix see [Filename.open_temp_file] + @param mode see [Filename.open_temp_file] + + @since 1.1.0 + *) +val bracket_tmpfile: + ?prefix:string -> + ?suffix:string -> + ?mode:open_flag list -> + ((string * out_channel) -> unit) -> unit -> unit + +(** {2 Constructing Tests} *) + +(** The type of test function *) +type test_fun = unit -> unit + +(** The type of tests *) +type test = + TestCase of test_fun + | TestList of test list + | TestLabel of string * test + +(** Create a TestLabel for a test *) +val (>:) : string -> test -> test + +(** Create a TestLabel for a TestCase *) +val (>::) : string -> test_fun -> test + +(** Create a TestLabel for a TestList *) +val (>:::) : string -> test list -> test + +(** Some shorthands which allows easy test construction. + + Examples: + + - ["test1" >: TestCase((fun _ -> ()))] => + [TestLabel("test2", TestCase((fun _ -> ())))] + - ["test2" >:: (fun _ -> ())] => + [TestLabel("test2", TestCase((fun _ -> ())))] + - ["test-suite" >::: ["test2" >:: (fun _ -> ());]] => + [TestLabel("test-suite", TestSuite([TestLabel("test2", + TestCase((fun _ -> ())))]))] +*) + +(** [test_decorate g tst] Apply [g] to test function contains in [tst] tree. + + @since 1.0.3 + *) +val test_decorate : (test_fun -> test_fun) -> test -> test + +(** [test_filter paths tst] Filter test based on their path string + representation. + + @param skip if set, just use [skip_if] for the matching tests. + @since 1.0.3 + *) +val test_filter : ?skip:bool -> string list -> test -> test option + +(** {2 Retrieve Information from Tests} *) + +(** Returns the number of available test cases *) +val test_case_count : test -> int + +(** Types which represent the path of a test *) +type node = ListItem of int | Label of string +type path = node list (** The path to the test (in reverse order). *) + +(** Make a string from a node *) +val string_of_node : node -> string + +(** Make a string from a path. The path will be reversed before it is + tranlated into a string *) +val string_of_path : path -> string + +(** Returns a list with paths of the test *) +val test_case_paths : test -> path list + +(** {2 Performing Tests} *) + +(** The possible results of a test *) +type test_result = + RSuccess of path + | RFailure of path * string + | RError of path * string + | RSkip of path * string + | RTodo of path * string + +(** Events which occur during a test run. *) +type test_event = + EStart of path (** A test start. *) + | EEnd of path (** A test end. *) + | EResult of test_result (** Result of a test. *) + +(** Results of a test run. *) +type test_results = test_result list + +(** Perform the test, allows you to build your own test runner *) +val perform_test : (test_event -> unit) -> test -> test_results + +(** A simple text based test runner. + + @param verbose print verbose message + *) +val run_test_tt : ?verbose:bool -> test -> test_results + +(** Main version of the text based test runner. It reads the supplied command + line arguments to set the verbose level and limit the number of test to + run. + + @param arg_specs add extra command line arguments + @param set_verbose call a function to set verbosity + @param fexit call a final function after test, by default exit 1. + + @version 1.1.0 + *) +val run_test_tt_main : + ?arg_specs:(Arg.key * Arg.spec * Arg.doc) list -> + ?set_verbose:(bool -> unit) -> + test -> test_results + + +val ounit2_of_ounit1 : test -> OUnit2.test diff -Nru ounit-2.0.8/src/lib/ounit2/threads/dune ounit-2.2.3/src/lib/ounit2/threads/dune --- ounit-2.0.8/src/lib/ounit2/threads/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/threads/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,5 @@ +(library + (name oUnitThreads) + (public_name ounit2.threads) + (private_modules oUnitRunnerThreads) + (libraries threads ounit2)) diff -Nru ounit-2.0.8/src/lib/ounit2/threads/oUnitRunnerThreads.ml ounit-2.2.3/src/lib/ounit2/threads/oUnitRunnerThreads.ml --- ounit-2.0.8/src/lib/ounit2/threads/oUnitRunnerThreads.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/threads/oUnitRunnerThreads.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,226 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(** Use threads to run several tests concurrently. + * + * Run threads that handle running tests. It works the same way + * as processes. Due to the non-parallel threads behavior in OCaml, you cannot + * truly use the power of parallelism with threads, except when you have a lot + * of disk and process operation. + *) + +open OUnitRunner.GenericWorker + +let make_channel + shard_id + sync_send_data + (string_of_read_message: 'read -> string) + (string_of_written_message: 'written -> string) + (chan_read: 'read Event.channel) + (chan_write: 'written Event.channel) = + let chan_sync_send_data = Event.new_channel () in + let send_data msg = + if sync_send_data then + Event.sync (Event.send chan_sync_send_data shard_id); + Event.sync (Event.send chan_write msg) + in + + let receive_data _ = + Event.sync (Event.receive chan_read) + in + chan_sync_send_data, + wrap_channel + shard_id + string_of_read_message + string_of_written_message + { + send_data = send_data; + receive_data = receive_data; + close = ignore; + } + +let create_worker ~shard_id ~master_id ~worker_log_file conf map_test_cases = + (* Threads will get message from master by there. *) + let master_to_worker = Event.new_channel () in + (* Threads will send message to master by there. *) + let worker_to_master = Event.new_channel () in + (* Signal end of the worker. *) + let worker_finished = ref false in + let worker_finished_mutex = Mutex.create () in + let worker_finished_cond = Condition.create () in + + let select_fd, channel_worker = + make_channel + shard_id + true + string_of_message_to_worker + string_of_message_from_worker + master_to_worker + worker_to_master + in + + let thread_main_worker () = + let at_end () = + channel_worker.close (); + Mutex.lock worker_finished_mutex; + worker_finished := true; + Condition.broadcast worker_finished_cond; + Mutex.unlock worker_finished_mutex + in + try + main_worker_loop + conf + ~yield:Thread.yield + channel_worker + ~shard_id + map_test_cases + ~worker_log_file; + at_end () + with e -> + at_end (); + raise e + in + + let thread = Thread.create thread_main_worker () in + + let _, channel_master = + make_channel + master_id + false + string_of_message_from_worker + string_of_message_to_worker + worker_to_master + master_to_worker + in + + let is_running () = + let res = + Mutex.lock worker_finished_mutex; + not !worker_finished + in + Mutex.unlock worker_finished_mutex; + res + in + + let close_worker () = + let killer () = + let total_wait = ref 0.0 in + let step = 0.1 in + Mutex.lock worker_finished_mutex; + while !total_wait < 5.0 && not !worker_finished do + Mutex.unlock worker_finished_mutex; + Thread.delay step; + total_wait := !total_wait +. step; + Mutex.lock worker_finished_mutex + done; + if not !worker_finished then begin + (* This will fail... because probably not implemented. *) + Thread.kill thread; + worker_finished := true; + Condition.broadcast worker_finished_cond + end; + Mutex.unlock worker_finished_mutex + in + let killer_thread = Thread.create killer () in + Mutex.lock worker_finished_mutex; + while not !worker_finished do + Condition.wait worker_finished_cond worker_finished_mutex + done; + Mutex.unlock worker_finished_mutex; + try + Thread.join killer_thread; + Thread.join thread; + None + with e -> + Some (Printf.sprintf + "Exception raised: %s." + (Printexc.to_string e)) + in + { + channel = channel_master; + close_worker = close_worker; + select_fd = select_fd; + shard_id = shard_id; + is_running = is_running; + } + + +let workers_waiting ~timeout:_ workers = + let channel_timeout = Event.new_channel () in +(* TODO: clean implementation of the timeout. + * Timeout not implemented, because it should be killed in most cases and + * actually Thread.kill is not implemented for systhreads. + * We could do either of this: + * - Thread.time_read + mkpipe + * - use signal ALARM + * + * Patch welcome. + * + * Sylvain Le Gall -- 2013/09/18. + let thread_timeout = + Thread.create + (fun () -> + Thread.delay timeout; + Event.sync (Event.send channel_timeout None)) + () + in + *) + let worker_id_ready = + Event.select + (Event.receive channel_timeout + :: + (List.rev_map + (fun worker -> + Event.wrap + (Event.receive worker.select_fd) + (fun s -> Some s)) + workers)) + in + match worker_id_ready with + | None -> +(* Thread.join thread_timeout; *) + [] + | Some worker_id -> +(* Thread.kill thread_timeout; *) + try + let worker = + List.find + (fun worker -> + worker.shard_id = worker_id) + workers + in + [worker] + with Not_found -> + assert false + +let init () = + OUnitRunner.register "threads" 70 (runner create_worker workers_waiting) diff -Nru ounit-2.0.8/src/lib/ounit2/threads/oUnitThreads.ml ounit-2.2.3/src/lib/ounit2/threads/oUnitThreads.ml --- ounit-2.0.8/src/lib/ounit2/threads/oUnitThreads.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2/threads/oUnitThreads.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,44 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + + +let init () = + OUnitShared.mutex_create := + (fun () -> + let mutex = Mutex.create () in + { + OUnitShared. + lock = (fun () -> Mutex.lock mutex); + try_lock = (fun () -> Mutex.try_lock mutex); + unlock = (fun () -> Mutex.unlock mutex); + }); + OUnitRunnerThreads.init () diff -Nru ounit-2.0.8/src/lib/ounit2-lwt/dune ounit-2.2.3/src/lib/ounit2-lwt/dune --- ounit-2.0.8/src/lib/ounit2-lwt/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2-lwt/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,4 @@ +(library + (name oUnitLwt) + (public_name ounit2-lwt) + (libraries lwt lwt.unix ounit2.advanced)) diff -Nru ounit-2.0.8/src/lib/ounit2-lwt/oUnitLwt.ml ounit-2.2.3/src/lib/ounit2-lwt/oUnitLwt.ml --- ounit-2.0.8/src/lib/ounit2-lwt/oUnitLwt.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit2-lwt/oUnitLwt.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,21 @@ +(** Helper to write Lwt tests with OUnit. + + As of 2019-09-19, this module is still experimental. + *) + +let () = OUnitRunnerProcesses.unix_fork := Lwt_unix.fork + +(** [lwt_wrapper f] transforms an Lwt function into a test. + +Example: +{[ +let test = + "SimpleAssertion" >:: + (lwt_wrapper + (fun ctxt -> + Lwt.return 4 + >>= fun i -> + Lwt.return (assert_equal ~ctxt 4 i))) +]} + *) +let lwt_wrapper f = fun ctxt -> f ctxt |> Lwt_main.run diff -Nru ounit-2.0.8/src/lib/ounit-lwt/dune ounit-2.2.3/src/lib/ounit-lwt/dune --- ounit-2.0.8/src/lib/ounit-lwt/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit-lwt/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,3 @@ +(documentation + (package ounit-lwt) + (mld_files index)) diff -Nru ounit-2.0.8/src/lib/ounit-lwt/index.mld ounit-2.2.3/src/lib/ounit-lwt/index.mld --- ounit-2.0.8/src/lib/ounit-lwt/index.mld 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit-lwt/index.mld 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,4 @@ +{1 OUnit-lwt transitional package} + +This is a transitional package for ounit2-lwt. Use +{{: ../ounit2-lwt/index.html} ounit2-lwt package}. diff -Nru ounit-2.0.8/src/lib/ounit-lwt/META ounit-2.2.3/src/lib/ounit-lwt/META --- ounit-2.0.8/src/lib/ounit-lwt/META 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/lib/ounit-lwt/META 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,2 @@ +description = "Transition package to ounit2-lwt" +requires = "ounit2-lwt" diff -Nru ounit-2.0.8/src/META ounit-2.2.3/src/META --- ounit-2.0.8/src/META 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/src/META 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 431f8d222a6b255926917a89793fe722) -version = "2.0.8" -description = "Unit testing framework" -requires = "unix oUnit.advanced" -archive(byte) = "oUnit.cma" -archive(byte, plugin) = "oUnit.cma" -archive(native) = "oUnit.cmxa" -archive(native, plugin) = "oUnit.cmxs" -exists_if = "oUnit.cma" -package "threads" ( - version = "2.0.8" - description = "Unit testing framework" - requires = "threads oUnit" - archive(byte) = "oUnitThreads.cma" - archive(byte, plugin) = "oUnitThreads.cma" - archive(native) = "oUnitThreads.cmxa" - archive(native, plugin) = "oUnitThreads.cmxs" - exists_if = "oUnitThreads.cma" -) - -package "advanced" ( - version = "2.0.8" - description = "Unit testing framework" - requires = "bytes" - archive(byte) = "oUnitAdvanced.cma" - archive(byte, plugin) = "oUnitAdvanced.cma" - archive(native) = "oUnitAdvanced.cmxa" - archive(native, plugin) = "oUnitAdvanced.cmxs" - exists_if = "oUnitAdvanced.cma" -) -# OASIS_STOP - diff -Nru ounit-2.0.8/src/oUnit2.ml ounit-2.2.3/src/oUnit2.ml --- ounit-2.0.8/src/oUnit2.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnit2.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,98 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnitCore -open OUnitTest - -let (>:) = OUnitTest.(>:) -let (>::) = OUnitTest.(>::) -let (>:::) = OUnitTest.(>:::) - -type test_ctxt = OUnitTest.ctxt -type test_fun = OUnitTest.test_fun -type test_length = OUnitTest.test_length -type test = OUnitTest.test -let test_case ?(length=Short) f = TestCase(length, f) -let test_list lst = TestList lst - -type log_severity = OUnitLogger.log_severity - -let assert_failure = OUnitAssert.assert_failure -let assert_bool = OUnitAssert.assert_bool -let assert_string = OUnitAssert.assert_string -(* Upgrade to OUnit v2, using logger. *) -(* let assert_command = OUnitAssert.assert_command *) -let assert_command - ?exit_code ?sinput ?foutput ?use_stderr ?backtrace ?chdir ?env ~ctxt - prg args = - OUnitAssert.assert_command - ?exit_code ?sinput ?foutput ?use_stderr ?backtrace ?chdir ?env ~ctxt - prg args -let assert_equal = OUnitAssert.assert_equal -let assert_raises = OUnitAssert.assert_raises -let skip_if = OUnitAssert.skip_if -let todo = OUnitAssert.todo -let cmp_float = OUnitUtils.cmp_float -let bracket = OUnitBracket.create -let bracket_tmpfile = OUnitBracket.bracket_tmpfile -let bracket_tmpdir = OUnitBracket.bracket_tmpdir -let with_bracket_chdir test_ctxt dn f = - OUnitBracket.with_bracket test_ctxt - (OUnitBracket.bracket_chdir dn) - (fun _ -> f) - - -let non_fatal = OUnitTest.non_fatal -let run_test_tt_main = OUnitCore.run_test_tt_main - -let logf ctxt log_severity fmt = - OUnitLogger.Test.logf ctxt.test_logger log_severity fmt - -let in_testdata_dir ctxt path = - OUnitTestData.in_testdata_dir ctxt.conf path - -let conf_wrap f name default help = - let get = f name default help in - fun ctxt -> get ctxt.conf - -module Conf = -struct - type 'a conf_t = string -> 'a -> Arg.doc -> test_ctxt -> 'a - let make_string = conf_wrap OUnitConf.make_string - let make_string_opt = conf_wrap OUnitConf.make_string_opt - let make_int = conf_wrap OUnitConf.make_int - let make_float = conf_wrap OUnitConf.make_float - let make_bool = conf_wrap OUnitConf.make_bool - let make_exec name = - let get = OUnitConf.make_exec name in - fun ctxt -> get ctxt.conf -end diff -Nru ounit-2.0.8/src/oUnit2.mli ounit-2.2.3/src/oUnit2.mli --- ounit-2.0.8/src/oUnit2.mli 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnit2.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,307 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(** Unit test building blocks (v2). - - @author Sylvain Le Gall - *) - -(** {2 Types} *) - -(** Context of a test. *) -type test_ctxt = OUnitTest.ctxt - -(** The type of test function. *) -type test_fun = test_ctxt -> unit - -(** The type of test. *) -type test = OUnitTest.test - -(** The expected length of the test. *) -type test_length = OUnitTest.test_length - -(** {2 Assertions} - - Assertions are the basic building blocks of unittests. *) - -(** Signals a failure. This will raise an exception with the specified - string. - - @raise Failure signal a failure *) -val assert_failure : string -> 'a - -(** Signals a failure when bool is false. The string identifies the - failure. - - @raise Failure signal a failure *) -val assert_bool : string -> bool -> unit - -(** Signals a failure when the string is non-empty. The string identifies the - failure. - - @raise Failure signal a failure *) -val assert_string : string -> unit - -(** [assert_command prg args] Run the command provided. - - @param exit_code expected exit code - @param sinput provide this [char Stream.t] as input of the process - @param foutput run this function on output, it can contains an - [assert_equal] to check it - @param use_stderr redirect [stderr] to [stdout] - @param backtrace Set OCAMLRUNPARAM=b - @param chdir Chdir into a directory before running the command. - @param env Unix environment - @param verbose if a failed, dump stdout/stderr of the process to stderr - *) -val assert_command : - ?exit_code:Unix.process_status -> - ?sinput:char Stream.t -> - ?foutput:(char Stream.t -> unit) -> - ?use_stderr:bool -> - ?backtrace:bool -> - ?chdir:string -> - ?env:string array -> - ctxt:test_ctxt -> - string -> string list -> unit - -(** [assert_equal expected real] Compares two values, when they are not equal a - failure is signaled. - - @param cmp customize function to compare, default is [=] - @param printer value printer, don't print value otherwise - @param pp_diff if not equal, ask a custom display of the difference - using [diff fmt exp real] where [fmt] is the formatter to use - @param msg custom message to identify the failure - @param ctxt if provided, always print expected and real value - - @raise Failure signal a failure - *) -val assert_equal : - ?ctxt:test_ctxt -> - ?cmp:('a -> 'a -> bool) -> - ?printer:('a -> string) -> - ?pp_diff:(Format.formatter -> ('a * 'a) -> unit) -> - ?msg:string -> 'a -> 'a -> unit - -(** Asserts if the expected exception was raised. - - @param msg identify the failure - - @raise Failure description *) -val assert_raises : ?msg:string -> exn -> (unit -> 'a) -> unit - -(** {2 Skipping tests } - - In certain condition test can be written but there is no point running it, - because they are not significant (missing OS features for example). In this - case this is not a failure nor a success. Following functions allow you to - escape test, just as assertion but without the same error status. - - A test skipped is counted as success. A test todo is counted as failure. - *) - -(** [skip cond msg] If [cond] is true, skip the test for the reason explain in - [msg]. For example [skip_if (Sys.os_type = "Win32") "Test a doesn't run on - windows"]. - *) -val skip_if : bool -> string -> unit - -(** The associated test is still to be done, for the reason given. - *) -val todo : string -> unit - -(** {2 Compare Functions} *) - -(** Compare floats up to a given relative error. - - In keeping with standard floating point semantics, NaN is not equal to - anything: [cmp_float nan nan = false]. - - @param epsilon if the difference is smaller [epsilon] values are equal - *) -val cmp_float : ?epsilon:float -> float -> float -> bool - -(** {2 Bracket} - - A bracket is a registered object with setUp and tearDown in unit tests. - Data generated during the setUp will be automatically tearDown when the test - ends. - *) - -(** [bracket set_up tear_down test_ctxt] set up an object and register it to be - tore down in [test_ctxt]. - *) -val bracket : (test_ctxt -> 'a) -> ('a -> test_ctxt -> unit) -> test_ctxt -> 'a - -(** [bracket_tmpfile test_ctxt] Create a temporary filename and matching output - channel. The temporary file is removed after the test. - - @param prefix see [Filename.open_temp_file] - @param suffix see [Filename.open_temp_file] - @param mode see [Filename.open_temp_file] - *) -val bracket_tmpfile: - ?prefix:string -> - ?suffix:string -> - ?mode:open_flag list -> - test_ctxt -> (string * out_channel) - -(** [bracket_tmpdir test_ctxt] Create a temporary dirname. The temporary - directory is removed after the test. - - @param prefix see [Filename.open_temp_file] - @param suffix see [Filename.open_temp_file] - *) -val bracket_tmpdir: - ?prefix:string -> - ?suffix:string -> - test_ctxt -> string - -(** [with_bracket_chdir test_ctxt dn f] change directory to [dn] during - execution of function [f]. In order to [Sys.chdir], we need to take a lock - to avoid other tests trying to do change the current directory at the same - time. So this bracket is not directly accessible in order to use it only on - shorter piece of code. - *) -val with_bracket_chdir: test_ctxt -> string -> (test_ctxt -> 'a) -> 'a - -(** {2 Constructing Tests} *) - -(** Create a TestLabel for a test *) -val (>:) : string -> test -> test - -(** Create a TestLabel for a TestCase *) -val (>::) : string -> test_fun -> test - -(** Create a TestLabel for a TestList *) -val (>:::) : string -> test list -> test - -(** Generic function to create a test case. *) -val test_case : ?length:test_length -> test_fun -> test - -(** Generic function to create a test list. *) -val test_list : test list -> test - -(** Some shorthands which allows easy test construction. - - Examples: - - - ["test1" >: TestCase((fun _ -> ()))] => - [TestLabel("test2", TestCase((fun _ -> ())))] - - ["test2" >:: (fun _ -> ())] => - [TestLabel("test2", TestCase((fun _ -> ())))] - - ["test-suite" >::: ["test2" >:: (fun _ -> ());]] => - [TestLabel("test-suite", TestSuite([TestLabel("test2", - TestCase((fun _ -> ())))]))] -*) - -(** {2 Performing Tests} *) - -(** Severity level for log. *) -type log_severity = [ `Error | `Warning | `Info ] - -(** Log into OUnit logging system. - *) -val logf: test_ctxt -> log_severity -> ('a, unit, string, unit) format4 -> 'a - -(** Build a filename for a file that should be located in the test data dir. - - The test data dir, can be defined on the command line (preferably absolute) - The default option is to locate it in topsrcdir/test/data. - *) -val in_testdata_dir: test_ctxt -> string list -> string - -(** [non_fatal ctxt f] Run [f] but if an exception is raised or an assert fails, - don't stop, just register the result. The global test running result will - mix in the non fatal result to determine the success or failure of the test. - *) -val non_fatal: test_ctxt -> (test_ctxt -> unit) -> unit - -(** Define command line options, environment variables and file configuration. - - This module helps to define configuration options that are translated to - command line options et al. - - The name defined for the variable is: - - should be a valid OCaml identifier - - kept as is for use in configuration file. (foo_bar = "") - - '_' are replaced by '-' and a leading '-' is added for command line - (-foo "") - - capitalized and prefixed by OUNIT_ for environment (OUNIT_FOO_BAR="") - *) -module Conf: -sig - (** The default type of function that create a configuration option of type - 'a. - *) - type 'a conf_t = string -> 'a -> Arg.doc -> test_ctxt -> 'a - - (** [make_string name default help] Create a string configuration - option with default value [default] and a short help string. - The result of the partial application of the function can be used - inside tests to be evaluated to a value. - -{[ -let my_option = Conf.make_string "my_option" "the default" "A default option." - -let tests = - "ATest" >:: - (fun test_ctxt -> let option_value = my_option test_ctxt in ()) - -]} - *) - val make_string: string conf_t - - (** Create a [string option] configuration option. See [!make_string]. *) - val make_string_opt: (string option) conf_t - - (** Create an [int] configuration option. See [!make_string]. *) - val make_int: int conf_t - - (** Create a [float] configuration option. See [!make_string]. *) - val make_float: float conf_t - - (** Create a [bool] configuration option. See [!make_string]. *) - val make_bool: bool conf_t - - (** [make_exec execname] Create a option to define an executable. *) - val make_exec: string -> test_ctxt -> string -end - -(** Main version of the text based test runner. It reads the supplied command - line arguments to set the verbose level and limit the number of test to - run. - - @param test the test suite to run. - *) -val run_test_tt_main : ?exit:(int -> unit) -> test -> unit diff -Nru ounit-2.0.8/src/oUnitAdvanced.mldylib ounit-2.2.3/src/oUnitAdvanced.mldylib --- ounit-2.0.8/src/oUnitAdvanced.mldylib 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/src/oUnitAdvanced.mldylib 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 63cc39f68c681144d83ffd81399dc187) -OUnitUtils -OUnitPropList -OUnitPlugin -OUnitChooser -OUnitResultSummary -OUnitLoggerStd -OUnitLoggerHTML -OUnitLoggerHTMLData -OUnitLoggerJUnit -OUnitAssert -OUnitBracket -OUnitTest -OUnitState -OUnitRunner -OUnitRunnerProcesses -OUnitCore -OUnitLogger -OUnitConf -OUnitShared -OUnitCache -OUnitTestData -OUnitCheckEnv -OUnitDiff -# OASIS_STOP diff -Nru ounit-2.0.8/src/oUnitAdvanced.mllib ounit-2.2.3/src/oUnitAdvanced.mllib --- ounit-2.0.8/src/oUnitAdvanced.mllib 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/src/oUnitAdvanced.mllib 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 63cc39f68c681144d83ffd81399dc187) -OUnitUtils -OUnitPropList -OUnitPlugin -OUnitChooser -OUnitResultSummary -OUnitLoggerStd -OUnitLoggerHTML -OUnitLoggerHTMLData -OUnitLoggerJUnit -OUnitAssert -OUnitBracket -OUnitTest -OUnitState -OUnitRunner -OUnitRunnerProcesses -OUnitCore -OUnitLogger -OUnitConf -OUnitShared -OUnitCache -OUnitTestData -OUnitCheckEnv -OUnitDiff -# OASIS_STOP diff -Nru ounit-2.0.8/src/oUnitAssert.ml ounit-2.2.3/src/oUnitAssert.ml --- ounit-2.0.8/src/oUnitAssert.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitAssert.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,321 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnitUtils -open OUnitBracket -open OUnitTest - -let skip_if b msg = - if b then - raise (Skip msg) - -let todo msg = - raise (Todo msg) - -let assert_failure msg = - raise (OUnit_failure msg) - -let assert_bool msg b = - if not b then assert_failure msg - -let assert_string str = - if not (str = "") then assert_failure str - -let assert_equal ?ctxt ?(cmp = ( = )) ?printer ?pp_diff ?msg expected actual = - let get_error_string () = - let res = - buff_format_printf - (fun fmt -> - Format.pp_open_vbox fmt 0; - begin - match msg with - | Some s -> - Format.pp_open_box fmt 0; - Format.pp_print_string fmt s; - Format.pp_close_box fmt (); - Format.pp_print_cut fmt () - | None -> - () - end; - - begin - match printer with - | Some p -> - Format.fprintf fmt - "@[expected: @[%s@]@ but got: @[%s@]@]@," - (p expected) - (p actual) - - | None -> - Format.fprintf fmt "@[not equal@]@," - end; - - begin - match pp_diff with - | Some d -> - Format.fprintf fmt - "@[differences: %a@]@," - d (expected, actual) - - | None -> - () - end; - Format.pp_close_box fmt ()) - in - let len = - String.length res - in - if len > 0 && res.[len - 1] = '\n' then - String.sub res 0 (len - 1) - else - res - in - let logf fmt = - match ctxt with - | Some ctxt -> - OUnitLogger.Test.logf ctxt.test_logger `Info fmt - | None -> - Printf.ksprintf ignore fmt - in - begin - match msg with - | Some str -> - logf "%s" str; - | _ -> - () - end; - begin - match printer with - | Some p -> - logf "Expected: %s" (p expected); - logf "Actual: %s" (p actual) - | _ -> - () - end; - - if not (cmp expected actual) then - assert_failure (get_error_string ()) - -let assert_command - ?(exit_code=Unix.WEXITED 0) - ?(sinput=Stream.of_list []) - ?(foutput=ignore) - ?(use_stderr=true) - ?(backtrace=true) - ?chdir - ?env - ~ctxt - prg args = - - OUnitTest.section_ctxt ctxt - (fun ctxt -> - let (fn_out, chn_out) = bracket_tmpfile ctxt in - let cmd_print fmt = - Format.pp_print_string fmt prg; - List.iter (Format.fprintf fmt "@ %s") args - in - - (* Start the process *) - let in_write = - Unix.dup (Unix.descr_of_out_channel chn_out) - in - let (out_read, out_write) = - Unix.pipe () - in - let err = - if use_stderr then - in_write - else - Unix.stderr - in - let args = - Array.of_list (prg :: args) - in - let env = - let param = "OCAMLRUNPARAM" in - let analyse_and_fix env = - let arr = Array.copy env in - let fixed = ref false in - let new_var = ref "" in - for i = 0 to (Array.length arr) - 1 do - let really_starts, current_value = - OUnitUtils.start_substr ~prefix:(param^"=") arr.(i) - in - if really_starts then begin - (* Rewrite the params. *) - if not (String.contains current_value 'b') then begin - arr.(i) <- param^"="^current_value^"b" - end; - new_var := arr.(i); - fixed := true - end - done; - if !fixed then - arr - else - Array.append arr [|param^"=b"|] - in - if backtrace then begin - (* Analyse of the provided environment. *) - match env with - | Some env -> - Some (analyse_and_fix env) - | None -> - Some (analyse_and_fix (Unix.environment ())) - end else begin - env - end - in - let command_chdir, in_chdir = - match chdir with - | Some dn -> - dn, - fun f -> - with_bracket ctxt (bracket_chdir dn) - (fun _ _ -> f ()) - | None -> - Sys.getcwd (), fun f -> f () - in - let pid = - OUnitLogger.Test.logf ctxt.test_logger `Info "%s" - (buff_format_printf - (fun fmt -> - Format.fprintf fmt "Starting command '%t'." cmd_print)); - OUnitLogger.Test.logf ctxt.test_logger `Info "Working directory: %S" - command_chdir; - OUnitLogger.Test.logf ctxt.test_logger `Info "Environment: "; - Array.iter - (fun v -> - OUnitLogger.Test.logf ctxt.test_logger `Info "%s" v) - (match env with - | Some e -> e - | None -> Unix.environment ()); - Unix.set_close_on_exec out_write; - match env with - | Some e -> - in_chdir - (fun () -> - Unix.create_process_env prg args e out_read in_write err) - | None -> - in_chdir - (fun () -> - Unix.create_process prg args out_read in_write err) - in - let () = - Unix.close out_read; - Unix.close in_write - in - let () = - (* Dump sinput into the process stdin *) - let buff = Bytes.make 1 ' ' in - Stream.iter - (fun c -> - let _i : int = - Bytes.set buff 0 c; - Unix.write out_write buff 0 1 - in - ()) - sinput; - Unix.close out_write - in - let _, real_exit_code = - let rec wait_intr () = - try - Unix.waitpid [] pid - with Unix.Unix_error (Unix.EINTR, _, _) -> - wait_intr () - in - wait_intr () - in - (* Dump process output to stderr *) - begin - let chn = open_in fn_out in - let buff = Bytes.make 4096 'X' in - let len = ref (-1) in - while !len <> 0 do - len := input chn buff 0 (Bytes.length buff); - OUnitLogger.Test.raw_printf - ctxt.test_logger "%s" Bytes.(to_string (sub buff 0 !len)); - done; - close_in chn - end; - - (* Check process status *) - assert_equal - ~msg:(buff_format_printf - (fun fmt -> - Format.fprintf fmt - "@[Exit status of command '%t'@]" cmd_print)) - ~printer:string_of_process_status - exit_code - real_exit_code; - - begin - let chn = open_in fn_out in - try - foutput (Stream.of_channel chn) - with e -> - close_in chn; - raise e - end) - -let raises f = - try - f (); - None - with e -> - Some e - -let assert_raises ?msg exn (f: unit -> 'a) = - let pexn = - Printexc.to_string - in - let get_error_string () = - let str = - Format.sprintf - "expected exception %s, but no exception was raised." - (pexn exn) - in - match msg with - | None -> - assert_failure str - - | Some s -> - assert_failure (s^"\n"^str) - in - match raises f with - | None -> - assert_failure (get_error_string ()) - - | Some e -> - assert_equal ?msg ~printer:pexn exn e - diff -Nru ounit-2.0.8/src/oUnitBracket.ml ounit-2.2.3/src/oUnitBracket.ml --- ounit-2.0.8/src/oUnitBracket.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitBracket.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,140 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnitTest - -type t = (unit -> unit) list - -let create set_up tear_down test_ctxt = - let fixture = set_up test_ctxt in - let tear_down test_ctxt = - tear_down fixture test_ctxt - in - OUnitShared.Mutex.with_lock - test_ctxt.shared test_ctxt.tear_down_mutex - (fun () -> - test_ctxt.tear_down <- tear_down :: test_ctxt.tear_down); - fixture - -let logf logger lvl fmt = OUnitLogger.Test.logf logger lvl fmt - -let bracket_tmpfile ?(prefix="ounit-") ?(suffix=".txt") ?mode test_ctxt = - create - (fun test_ctxt -> - let suffix = "-"^(OUnitTest.get_shard_id test_ctxt)^suffix in - let (fn, chn) = Filename.open_temp_file ?mode prefix suffix in - logf test_ctxt.test_logger `Info "Created a temporary file: %S." fn; - (fn, chn)) - (fun (fn, chn) test_ctxt -> - (try close_out chn with _ -> ()); - try - Sys.remove fn; - logf test_ctxt.test_logger `Info "Removed a temporary file: %S." fn - with _ -> - ()) - test_ctxt - - -let bracket_tmpdir ?(prefix="ounit-") ?(suffix=".dir") test_ctxt = - let max_attempt = 10 in - let rec try_hard_mkdir attempt = - if max_attempt = attempt then begin - OUnitUtils.failwithf - "Unable to create temporary directory after %d attempts." - attempt - end else begin - try - let suffix = "-"^(OUnitTest.get_shard_id test_ctxt)^suffix in - let tmpdn = Filename.temp_file prefix suffix in - Sys.remove tmpdn; - Unix.mkdir tmpdn 0o755; - tmpdn - with Unix.Unix_error (Unix.EEXIST, "mkdir", _) -> - try_hard_mkdir (max_attempt + 1) - end - in - create - (fun test_ctxt -> - let tmpdn = try_hard_mkdir 0 in - logf test_ctxt.test_logger `Info - "Create a temporary directory: %S." tmpdn; - tmpdn) - (fun tmpdn test_ctxt -> - let log_delete fn = - logf test_ctxt.test_logger `Info - "Delete in a temporary directory: %S." fn - in - let safe_run f a = try f a with _ -> () in - let rec rmdir fn = - Array.iter - (fun bn -> - let fn' = Filename.concat fn bn in - let is_dir = try Sys.is_directory fn' with _ -> false in - if is_dir then begin - rmdir fn'; - safe_run Unix.rmdir fn'; - log_delete fn' - end else begin - safe_run Sys.remove fn'; - log_delete fn' - end) - (try Sys.readdir fn with _ -> [||]) - in - rmdir tmpdn; - safe_run Unix.rmdir tmpdn; - log_delete tmpdn) - test_ctxt - -let chdir_mutex = OUnitShared.Mutex.create OUnitShared.ScopeProcess - -let bracket_chdir dir = - create - (fun test_ctxt -> - let () = - OUnitLogger.infof test_ctxt.logger "Change directory to %S" dir; - try - OUnitShared.Mutex.lock test_ctxt.shared chdir_mutex; - with OUnitShared.Lock_failure -> - failwith "Trying to do a nested chdir." - in - let cur_pwd = Sys.getcwd () in - Unix.chdir dir; - cur_pwd) - (fun cur_pwd test_ctxt -> - Unix.chdir cur_pwd; - OUnitShared.Mutex.unlock test_ctxt.shared chdir_mutex) - -let with_bracket test_ctxt bracket f = - section_ctxt test_ctxt - (fun test_ctxt -> - let res = bracket test_ctxt in - f res test_ctxt) diff -Nru ounit-2.0.8/src/oUnitCache.ml ounit-2.2.3/src/oUnitCache.ml --- ounit-2.0.8/src/oUnitCache.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitCache.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,89 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnitTest - -type cache = OUnitTest.result MapPath.t - -let cache_filename = - OUnitConf.make_string_subst_opt - "cache_filename" - (* TODO: oUnit-$(name).cache *) - (Some (Filename.concat OUnitUtils.buildir "oUnit-$(suite_name).cache")) - "Cache file to store previous results." - -let default = MapPath.empty - -let load conf = - match cache_filename conf with - | Some fn -> - begin - try - let chn = open_in fn in - let cache : cache = - try - Marshal.from_channel chn - with e -> - default - in - close_in chn; - cache - with _ -> - default - end - - | None -> - default - -let dump conf cache = - match cache_filename conf with - | Some fn -> - begin - try - let chn = open_out fn in - Marshal.to_channel chn cache []; - close_out chn - with _ -> - () - end - - | None -> - () - -let get_result path cache = - try - Some (MapPath.find path cache) - with Not_found -> - None - -let add_result path result cache = - MapPath.add path result cache diff -Nru ounit-2.0.8/src/oUnitCheckEnv.ml ounit-2.2.3/src/oUnitCheckEnv.ml --- ounit-2.0.8/src/oUnitCheckEnv.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitCheckEnv.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - - -(* Check environment after and before tests, to check isolation. *) - -open OUnitTest -open OUnitAssert - -type t = - { - pwd: string; - env: string array; - } - -let create () = - { - pwd = Sys.getcwd (); - env = Unix.environment (); - } - -module EnvElement = -struct - type t = string - - let pp_printer = Format.pp_print_string - - let compare = String.compare - - let pp_print_sep = OUnitDiff.pp_comma_separator -end - -module SetEnv = OUnitDiff.SetMake(EnvElement) - -let check test_ctxt t = - let t' = create () in - List.iter - (fun f -> non_fatal test_ctxt (fun _ -> f ())) - [ - (fun () -> - assert_equal - ~msg:"Current working dir (check env)." - ~printer:(fun s -> s) - t.pwd - t'.pwd); - (fun () -> - let convert t = SetEnv.of_list (Array.to_list t.env) in - SetEnv.assert_equal - ~msg:"Environment (check env)." - (convert t) - (convert t')); - ] diff -Nru ounit-2.0.8/src/oUnitChooser.ml ounit-2.2.3/src/oUnitChooser.ml --- ounit-2.0.8/src/oUnitChooser.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitChooser.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,136 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(** - Heuristic to pick a test to run. - - @author Sylvain Le Gall - *) - -open OUnitTest - -type t = - { - tests_planned: path list; - tests_running: path list; - tests_passed: result_list; - cache: OUnitCache.cache; - } - -type choice = - | ChooseToSkip of path - | ChooseToPostpone - | Choose of path - | NoChoice - -let string_of_choice = - function - | ChooseToSkip path -> - Printf.sprintf "ChooseToSkip %S" (string_of_path path) - | ChooseToPostpone -> "ChooseToPostpone" - | Choose path -> - Printf.sprintf "Choose %S" (string_of_path path) - | NoChoice -> "NoChoice" - - -type chooser = t -> choice - -(** Most simple heuristic, just pick the first test. *) -let simple t = - match t.tests_planned with - | hd :: _ -> Choose hd - | [] -> NoChoice - -module Plugin = - OUnitPlugin.Make - (struct - type t = chooser - let name = "chooser" - let conf_help = - "Select the method to choose tests to run." - let default_name = "simple" - let default_value = simple - end) - -include Plugin - -let allskip t = - match t.tests_planned with - | hd :: _ -> ChooseToSkip hd - | [] -> NoChoice - -let failfirst t = - let was_successful = OUnitResultSummary.was_successful in - let rec find_failing = - function - | path :: tl -> - begin - match OUnitCache.get_result path t.cache with - | Some result -> - (* Find the first formerly failing test. *) - if was_successful [path, result, None] then - find_failing tl - else - Choose path - | None -> - Choose path - end - | [] -> - begin - let wait_results_running = - List.fold_left - (fun wait path -> - match OUnitCache.get_result path t.cache with - | Some result -> - (not (was_successful [path, result, None])) || wait - | None -> - (* No former result, we need the result of - * this test. - *) - true) - false t.tests_running - in - if wait_results_running then - (* We need more data about currently running tests. *) - ChooseToPostpone - else if was_successful t.tests_passed then - (* All tests that were red has become green, continue. *) - simple t - else - (* Some tests still fail, skip the rest. *) - allskip t - end - in - find_failing t.tests_planned - -let () = - register "failfirst" ~-1 failfirst diff -Nru ounit-2.0.8/src/oUnitConf.ml ounit-2.2.3/src/oUnitConf.ml --- ounit-2.0.8/src/oUnitConf.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitConf.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,427 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnitUtils - -exception Parse_error of string - -type conf = OUnitPropList.t - -type metadata = - { - help: string; - get_print: conf -> string; - parse_set: string -> conf -> unit; - cli: conf -> (string * Arg.spec * string) list; - } - -let metaconf = Hashtbl.create 13 - -let check_variable_name str = - let () = - if String.length str = 0 then - failwith "'' is not a valid name." - in - let () = - match str.[0] with - | '0' .. '9' | '_' -> - failwithf - "%S is not a valid variable name. It must not start with %C." - str str.[0] - | _ -> - () - in - String.iter - (function - | 'A' .. 'Z' | 'a' .. 'z' | '_' | '0' .. '9' -> - () - | c -> - failwithf - "%S is not a valid variable name. It must not contain %C." - str c) - str - -let cli_name name = - let replace_underscores str = - let b = Buffer.create (String.length str) in - String.iter - (function - | '_' -> Buffer.add_char b '-' - | c -> Buffer.add_char b c) - str; - Buffer.contents b - in - "-" ^ replace_underscores name - -let subst conf extra_subst str = - let substitutions = Hashtbl.create (Hashtbl.length metaconf) in - let () = - (* Fill the substitutions table. *) - Hashtbl.iter - (fun name metadata -> - Hashtbl.add substitutions name (metadata.get_print conf)) - metaconf; - List.iter (fun (k, v) -> Hashtbl.add substitutions k v) extra_subst - in - let buff = Buffer.create (String.length str) in - Buffer.add_substitute buff - (fun var -> - try - Hashtbl.find substitutions var - with Not_found -> - failwithf "Unknown substitution variable %S in %S." var str) - str; - Buffer.contents buff - -let make ~name ~parse ~print ~default ~help ~fcli () = - let () = - check_variable_name name; - if Hashtbl.mem metaconf name then - failwithf - "Duplicate definition for configuration variable %S." name - in - let set, get = OUnitPropList.new_property default in - let parse_set str conf = set conf (parse str) in - let get_print conf = print (get conf) in - Hashtbl.add metaconf name - {help = help; - get_print = get_print; - parse_set = parse_set; - cli = (fun conf -> fcli (get conf) (set conf))}; - get - -let make_string name default help = - make - ~name - ~parse:(fun s -> s) - ~print:(fun s -> s) - ~default - ~help - ~fcli: - (fun get set -> - [cli_name name, - Arg.String set, - "str "^help]) - () - -let make_string_subst name default help = - let get = make_string name default help in - (fun ?(extra_subst=[]) conf -> - subst conf extra_subst (get conf)) - -let make_string_opt name default help = - make - ~name - ~parse: - (function - | "none" -> None - | str -> Some str) - ~print: - (function - | Some x -> x - | None -> "none") - ~default - ~help - ~fcli: - (fun get set -> - [cli_name name, - Arg.String (fun str -> set (Some str)), - "str "^help; - - cli_name ("no_"^name), - Arg.Unit (fun () -> set None), - Printf.sprintf " Reset value of %s." name]) - () - -let make_string_subst_opt name default opt = - let get = make_string_opt name default opt in - (fun ?(extra_subst=[]) conf -> - match get conf with - | Some str -> Some (subst conf extra_subst str) - | None -> None) - -let make_int name default help = - make - ~name - ~parse: - (fun str -> - try - int_of_string str - with Failure _ -> - raise - (Parse_error - (Printf.sprintf "%S is not an integer." str))) - ~print:string_of_int - ~default - ~help - ~fcli: - (fun get set -> - [cli_name name, - Arg.Int set, - "i "^help]) - () - -let make_float name default help = - make - ~name - ~parse: - (fun str -> - try - float_of_string str - with Failure _ -> - raise - (Parse_error - (Printf.sprintf "%S is not a float." str))) - ~print:string_of_float - ~default - ~help - ~fcli: - (fun get set -> - [cli_name name, - Arg.Float set, - "f "^help]) - () - -let make_bool name default help = - make - ~name - ~parse: - (fun str -> - try - bool_of_string str - with Failure _ -> - raise - (Parse_error - (Printf.sprintf "%S is not a boolean (true or false)." str))) - ~print:string_of_bool - ~default - ~help - ~fcli: - (fun get set -> - [cli_name name, - Arg.Bool set, - "{true|false} "^help]) - () - -let make_enum name get_enums default help = - let parse str = - let enum_lst = get_enums () in - if not (List.exists (fun (str', _) -> str = str') enum_lst) then - raise - (Parse_error - (Printf.sprintf - "%S is not an allowed value for %s." - str name)); - str - in - let get = - make - ~name - ~parse - ~print:(fun s -> s) - ~default - ~help - ~fcli: - (fun get set -> - [cli_name name, - Arg.Symbol (List.map fst (get_enums ()), set), - " "^help]) - () - in - fun conf -> - try - get conf, List.assoc (get conf) (get_enums ()) - with Not_found -> - failwithf - "Enums list for %s has changed during execution." name - -let make_exec name = - let default = - let pwd = Sys.getcwd () in - let bn = Filename.concat pwd name in - if Sys.file_exists (bn^".native") then - bn^".native" - else if Sys.file_exists (bn^".byte") then - bn^".byte" - else - name - in - make_string name default (Printf.sprintf "Executable %s." name) - -let set ~origin conf name value = - try - (Hashtbl.find metaconf name).parse_set value conf - with - | Not_found -> - failwithf - "Variable %S is not defined in the application.\n%s" name origin - | Parse_error str -> - failwith (str ^ "\n" ^ origin) - -let file_parse conf fn = - let parse lineno line = - let origin = - Printf.sprintf - "File \"%s\", line %d." - fn lineno - in - match trim (trim_comment line) with - | "" -> - () - | str -> - begin - let name, value = - try - Scanf.sscanf str "%s = %S" (fun name value -> name, value) - with Scanf.Scan_failure _ -> - begin - try - Scanf.sscanf str "%s = %s" (fun name value -> name, value) - with Scanf.Scan_failure _ -> - failwithf "Unparseable line: %s\n%s" line origin - end - in - set ~origin conf name value - end - in - let chn = open_in fn in - let lineno = ref 0 in - try - while true do - let line = input_line chn in - incr lineno; - parse !lineno line - done; - () - with - | End_of_file -> - close_in chn - | e -> - close_in chn; - raise e - -let env_parse conf = - let parse name = - let uppercase_name = - let b = Buffer.create (String.length name) in - String.iter - (function - | 'a' .. 'z' as c -> - Buffer.add_char b (Char.chr ((Char.code c) - 32)) - | c -> Buffer.add_char b c) - name; - Buffer.contents b - in - let env_name = "OUNIT_" ^ uppercase_name in - try - let value = Sys.getenv env_name in - (* Check and translate double quoted variable. *) - let value = - try - Scanf.sscanf value "%S" (fun s -> s) - with Scanf.Scan_failure _ -> - value - in - let origin = - Printf.sprintf "Environment variable %s=%S." env_name value - in - set ~origin conf name value - with Not_found -> - () - in - Hashtbl.iter (fun name _ -> parse name) metaconf - -let cli_parse ?argv extra_specs conf = - let specs = - Hashtbl.fold - (fun name metadata lst -> - let cli_lst = - match metadata.cli conf with - | (key, spec, doc) :: tl -> - (key, spec, doc ^ - (Printf.sprintf " (default: %s)" - (metadata.get_print conf))) - :: tl - | [] -> [] - in - cli_lst @ lst) - metaconf - [] - in - let all_specs = - Arg.align - ([ - "-conf", - Arg.String (file_parse conf), - "fn Read configuration file." - ] - @ (List.sort Pervasives.compare specs) - @ extra_specs) - in - let arg_parse = - match argv with - | Some arr -> - Arg.parse_argv ~current:(ref 0) arr - | None -> - Arg.parse - in - arg_parse - all_specs - (fun x -> raise (Arg.Bad ("Unexpected argument: " ^ x))) - ("usage: " ^ Sys.argv.(0) ^ " options*") - -let default ?(preset=[]) () = - let conf = OUnitPropList.create () in - List.iter - (fun (name, value) -> - set ~origin:"Preset by program." conf name value) - preset; - conf - -(** Load test options from file, environment and command line (in this order). - Not that [extra_specs] is here for historical reason, better use [make] to - create command line options. - *) -let load ?preset ?argv extra_specs = - let conf = default ?preset () in - if Sys.file_exists "ounit.conf" then - file_parse conf "ounit.conf"; - env_parse conf; - cli_parse ?argv extra_specs conf; - conf - -let dump conf = - Hashtbl.fold - (fun name metadata lst -> - (name, metadata.get_print conf) :: lst) - metaconf - [] diff -Nru ounit-2.0.8/src/oUnitCore.ml ounit-2.2.3/src/oUnitCore.ml --- ounit-2.0.8/src/oUnitCore.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitCore.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,176 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnitUtils -open OUnitTest -open OUnitLogger - -(* Plugin initialisation. *) -let () = - OUnitRunnerProcesses.init () - -(* - * Types and global states. - *) - -(* Run all tests, report starts, errors, failures, and return the results *) -let perform_test conf logger runner chooser test = - let rec flatten_test path acc = - function - | TestCase(l, f) -> - (path, l, f) :: acc - - | TestList (tests) -> - fold_lefti - (fun acc t cnt -> - flatten_test - ((ListItem cnt)::path) - acc t) - acc tests - | TestLabel (label, t) -> - flatten_test ((Label label)::path) acc t - in - let test_cases = - List.rev (flatten_test [] [] test) - in - runner conf logger chooser test_cases - -(* A simple (currently too simple) text based test runner *) -let run_test_tt conf logger runner chooser test = - let () = - Printexc.record_backtrace true - in - - let () = - (* TODO: move into perform test. *) - List.iter - (fun (k, v) -> - OUnitLogger.report logger (GlobalEvent (GConf (k, v)))) - (OUnitConf.dump conf) - in - - (* Now start the test *) - let running_time, test_results = - time_fun (perform_test conf logger runner chooser) test - in - - (* TODO: move into perform test. *) - (* Print test report *) - OUnitLogger.report logger - (GlobalEvent - (GResults (running_time, - test_results, - OUnitTest.test_case_count test))); - - (* Reset logger. *) - OUnitLogger.close logger; - - (* Return the results possibly for further processing *) - test_results - -(* Test-only override. *) -let run_test_tt_main_conf = - ref (fun ?(preset=[]) ?argv extra_specs -> - OUnitConf.load - ?argv - ~preset:(OUnitChooser.preset (OUnitRunner.preset preset)) - extra_specs) - -let suite_name = - OUnitConf.make_string - "suite_name" - "anon" - "The name of the test suite running." - -(* Call this one to act as your main() function. *) -let run_test_tt_main ?(exit=Pervasives.exit) suite = - let only_test = ref [] in - let list_test = ref false in - let extra_specs = - [ - "-only-test", - Arg.String (fun str -> only_test := str :: !only_test), - "path Run only the selected tests."; - - "-list-test", - Arg.Set list_test, - " List tests"; - ] - in - let preset = - match suite with - | OUnitTest.TestLabel (suite_name, _) -> ["suite_name", suite_name] - | OUnitTest.TestCase _ | OUnitTest.TestList _ -> [] - in - let conf = !run_test_tt_main_conf ~preset extra_specs in - if !list_test then - begin - List.iter - (fun pth -> print_endline (OUnitTest.string_of_path pth)) - (OUnitTest.test_case_paths suite) - end - else - begin - let nsuite = - if !only_test = [] then - suite - else - begin - match OUnitTest.test_filter ~skip:true !only_test suite with - | Some test -> - test - | None -> - failwithf - "Filtering test %s lead to no tests." - (String.concat ", " !only_test) - end - in - - let logger = - OUnitLogger.combine - [ - OUnitLoggerStd.create conf shard_default; - OUnitLoggerHTML.create conf; - OUnitLoggerJUnit.create conf; - ] - in - - let runner_name, runner = OUnitRunner.choice conf in - let chooser_name, chooser = OUnitChooser.choice conf in - let test_results = - OUnitLogger.infof logger "Runner: %s" runner_name; - OUnitLogger.infof logger "Chooser: %s" chooser_name; - run_test_tt conf logger runner chooser nsuite - in - if not (OUnitResultSummary.was_successful test_results) then - exit 1 - end diff -Nru ounit-2.0.8/src/oUnit.css ounit-2.2.3/src/oUnit.css --- ounit-2.0.8/src/oUnit.css 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnit.css 1970-01-01 00:00:00.000000000 +0000 @@ -1,145 +0,0 @@ -/**************************************************************************/ -/* The OUnit library */ -/* */ -/* Copyright (C) 2002-2008 Maas-Maarten Zeeman. */ -/* Copyright (C) 2010 OCamlCore SARL */ -/* Copyright (C) 2013 Sylvain Le Gall */ -/* */ -/* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL */ -/* and Sylvain Le Gall. */ -/* */ -/* Permission is hereby granted, free of charge, to any person obtaining */ -/* a copy of this document and the OUnit software ("the Software"), to */ -/* deal in the Software without restriction, including without limitation */ -/* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages */ -/* or other liability, whether in an action of contract, tort or */ -/* otherwise, arising from, out of or in connection with the Software or */ -/* the use or other dealings in the software. */ -/* */ -/* See LICENSE.txt for details. */ -/**************************************************************************/ - -h1 { - font-size: 26px; - margin-right: 15px; - padding-left: 0px; -} - -h2 { - font-size: 20px; - margin-right: 15px; - padding-left: 5px; -} - -#ounit-current h2 { - text-decoration: underline; -} - -#ounit-results-started-at { - width: 100%; -} - -.ounit-results-content div { - width: 150px; - margin-top: 1px; -} - -.ounit-results-content .number { - text-align: right; - display: inline-block; - float: right; - width: 50px; -} - -.ounit-results-verdict.ounit-failure { - color: red; -} - -.ounit-success h2, -.ounit-results-successes .number { - background-color: #4a4; -} - -.ounit-failure h2, -.ounit-results-failures .number { - background-color: #f66; -} - -.ounit-error h2, -.ounit-results-errors .number { - background-color: #000; - color: #fff; -} - -.ounit-skip h2, -.ounit-results-skips .number { - background-color: #fd0; -} - -.ounit-todo h2, -.ounit-results-todos .number { - background-color: #aaf; -} - -.ounit-timeout h2, -.ounit-results-timeouts .number { - background-color: #888; -} - -.ounit-conf h2, -.ounit-results h2 { - background-color: #aaa; -} - -.ounit-log, -.ounit-conf-content { - font-family: Lucida Console, Monaco, Courier New, monospace; - white-space: nowrap; - font-size: 16px; - color: #666; - margin-left: 20px; -} - -.ounit-duration, -.ounit-started-at, -.ounit-results-content { - margin-bottom: 10px; - margin-left: 15px; -} - -.ounit-started-at { - margin-bottom: 0; -} - -span.ounit-timestamp { - display: inline-block; - width: 70px; -} - -.ounit-log .ounit-result, -.ounit-results-verdict { - font-weight: bold; - margin-top: 5px; -} - -#navigation { - position: fixed; - top: 0; - right: 0; - background-color: #fff; - padding: 9px; - border: 1px solid #000; - border-top: none; - border-right: none; -}; diff -Nru ounit-2.0.8/src/oUnitDiff.ml ounit-2.2.3/src/oUnitDiff.ml --- ounit-2.0.8/src/oUnitDiff.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitDiff.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,209 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open Format - -module type DIFF_ELEMENT = -sig - type t - - val pp_printer: Format.formatter -> t -> unit - - val compare: t -> t -> int - - val pp_print_sep: Format.formatter -> unit -> unit -end - -module type S = -sig - type e - - type t - - val compare: t -> t -> int - - val pp_printer: Format.formatter -> t -> unit - - val pp_diff: Format.formatter -> (t * t) -> unit - - val assert_equal: ?msg:string -> t -> t -> unit - - val of_list: e list -> t -end - -let assert_equal ?msg compare pp_printer pp_diff exp act = - OUnitAssert.assert_equal - ~cmp:(fun t1 t2 -> (compare t1 t2) = 0) - ~printer:(fun t -> - let buff = Buffer.create 13 in - let fmt = formatter_of_buffer buff in - pp_printer fmt t; - pp_print_flush fmt (); - Buffer.contents buff) - ~pp_diff - ?msg - exp act - -module SetMake (D: DIFF_ELEMENT) : S with type e = D.t = -struct - module Set = Set.Make(D) - - type e = D.t - - type t = Set.t - - let compare = - Set.compare - - let pp_printer fmt t = - let first = ref true in - pp_open_box fmt 0; - Set.iter - (fun e -> - if not !first then - D.pp_print_sep fmt (); - D.pp_printer fmt e; - first := false) - t; - pp_close_box fmt () - - let pp_diff fmt (t1, t2) = - let first = ref true in - let print_list c t = - Set.iter - (fun e -> - if not !first then - D.pp_print_sep fmt (); - pp_print_char fmt c; - D.pp_printer fmt e; - first := false) - t - in - pp_open_box fmt 0; - print_list '+' (Set.diff t2 t1); - print_list '-' (Set.diff t1 t2); - pp_close_box fmt () - - let assert_equal ?msg exp act = - assert_equal ?msg compare pp_printer pp_diff exp act - - let of_list lst = - List.fold_left - (fun acc e -> - Set.add e acc) - Set.empty - lst - -end - -module ListSimpleMake (D: DIFF_ELEMENT) : S - with type e = D.t and type t = D.t list = -struct - type e = D.t - - type t = e list - - let rec compare t1 t2 = - match t1, t2 with - | e1 :: tl1, e2 :: tl2 -> - begin - match D.compare e1 e2 with - | 0 -> - compare tl1 tl2 - | n -> - n - end - - | [], [] -> - 0 - - | _, [] -> - -1 - - | [], _ -> - 1 - - let pp_print_gen pre fmt t = - let first = ref true in - pp_open_box fmt 0; - List.iter - (fun e -> - if not !first then - D.pp_print_sep fmt (); - fprintf fmt "%s%a" pre D.pp_printer e; - first := false) - t; - pp_close_box fmt () - - let pp_printer fmt t = - pp_print_gen "" fmt t - - let pp_diff fmt (t1, t2) = - let rec pp_diff' n t1 t2 = - match t1, t2 with - | e1 :: tl1, e2 :: tl2 -> - begin - match D.compare e1 e2 with - | 0 -> - pp_diff' (n + 1) tl1 tl2 - | _ -> - fprintf fmt - "element number %d differ (%a <> %a)" - n - D.pp_printer e1 - D.pp_printer e2 - end - - | [], [] -> - () - - | [], lst -> - fprintf fmt "at end,@ "; - pp_print_gen "+" fmt lst - - | lst, [] -> - fprintf fmt "at end,@ "; - pp_print_gen "-" fmt lst - in - pp_open_box fmt 0; - pp_diff' 0 t1 t2; - pp_close_box fmt () - - let assert_equal ?msg exp act = - assert_equal ?msg compare pp_printer pp_diff exp act - - let of_list lst = - lst -end - -let pp_comma_separator fmt () = - fprintf fmt ",@ " diff -Nru ounit-2.0.8/src/oUnitDiff.mli ounit-2.2.3/src/oUnitDiff.mli --- ounit-2.0.8/src/oUnitDiff.mli 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitDiff.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,135 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(** Unit tests for collection of elements - - This module allows to define a more precise way to display differences - between collection of elements. When collection differ, the tester is - interested by what are the missing/extra elements. This module provides - a [diff] operation to spot the difference quickly between two sets of - elements. - - Example: -{[ -open OUnit;; - -module EInt = -struct - type t = int - let compare = ( - ) - let pp_printer = Format.pp_print_int - let pp_print_sep = OUnitDiff.pp_comma_separator -end - -module ListInt = OUnitDiff.ListSimpleMake(EInt);; - -let test_diff () = - ListInt.assert_equal - [1; 2; 3; 4; 5] - [1; 2; 5; 4] -;; - -let _ = - run_test_tt_main ("test_diff" >:: test_diff) -;; -]} - -when run this test outputs: -{[ -OUnit: expected: 1, 2, 3, 4, 5 but got: 1, 2, 5, 4 -differences: element number 2 differ (3 <> 5) -]} - - @since 1.1.0 - @author Sylvain Le Gall - *) - -(** {2 Signatures} *) - -(** Definition of an element - *) -module type DIFF_ELEMENT = - sig - (** Type of an element *) - type t - - (** Pretty printer for an element *) - val pp_printer : Format.formatter -> t -> unit - - (** Element comparison *) - val compare : t -> t -> int - - (** Pretty print element separator *) - val pp_print_sep : Format.formatter -> unit -> unit - end - -(** Definition of standard operations - *) -module type S = - sig - (** Type of an element *) - type e - - (** Type of a collection of element *) - type t - - (** Compare a collection of element *) - val compare : t -> t -> int - - (** Pretty printer a collection of element *) - val pp_printer : Format.formatter -> t -> unit - - (** Pretty printer for collection differences *) - val pp_diff : Format.formatter -> t * t -> unit - - (** {!assert_equal} with [~diff], [~cmp] and [~printer] predefined for - this collection events - *) - val assert_equal : ?msg:string -> t -> t -> unit - - (** Create [t] using of list *) - val of_list : e list -> t - end - -(** {2 Implementations} *) - -(** Collection of elements based on a Set, elements order doesn't matter *) -module SetMake : functor (D : DIFF_ELEMENT) -> S - with type e = D.t - -(** Collection of elements based on a List, order matters but difference display - is very simple. It stops at the first element which differs. - *) -module ListSimpleMake : functor (D: DIFF_ELEMENT) -> S - with type e = D.t and type t = D.t list - -val pp_comma_separator : Format.formatter -> unit -> unit diff -Nru ounit-2.0.8/src/oUnit.js ounit-2.2.3/src/oUnit.js --- ounit-2.0.8/src/oUnit.js 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnit.js 1970-01-01 00:00:00.000000000 +0000 @@ -1,97 +0,0 @@ -/**************************************************************************/ -/* The OUnit library */ -/* */ -/* Copyright (C) 2002-2008 Maas-Maarten Zeeman. */ -/* Copyright (C) 2010 OCamlCore SARL */ -/* Copyright (C) 2013 Sylvain Le Gall */ -/* */ -/* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL */ -/* and Sylvain Le Gall. */ -/* */ -/* Permission is hereby granted, free of charge, to any person obtaining */ -/* a copy of this document and the OUnit software ("the Software"), to */ -/* deal in the Software without restriction, including without limitation */ -/* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages */ -/* or other liability, whether in an action of contract, tort or */ -/* otherwise, arising from, out of or in connection with the Software or */ -/* the use or other dealings in the software. */ -/* */ -/* See LICENSE.txt for details. */ -/**************************************************************************/ - -var successHidden = true; - -function displaySuccess(display) { - var div = document.getElementsByClassName('ounit-success'); - for (var i = 0; i < div.length; i++) { - div[i].style.display = display; - }; -}; - -function toggleSuccess() { - if (successHidden) { - displaySuccess('block'); - } else { - displaySuccess('none'); - }; - successHidden = ! successHidden; - var button = document.getElementById('toggleVisibiltySuccess'); - if (successHidden) { - button.textContent = 'Show success'; - } else { - button.textContent = 'Hide success'; - }; -}; - -function resetTestCurrent() { - var div = document.getElementById('ounit-current'); - if (div) { - div.removeAttribute('id'); - }; -}; - -function setTestCurrent(div) { - resetTestCurrent(); - div.id = "ounit-current"; - div.scrollIntoView(true); -}; - -function nextTest() { - var div = document.getElementsByClassName('ounit-test'); - var found = false; - var foundCurrent = false; - var idx = 0; - if (div) { - for (; !found && idx < div.length; idx++) { - if (foundCurrent && div[idx].style.display != 'none') { - found = true; - }; - if (div[idx].id == "ounit-current") { - foundCurrent = true; - }; - }; - if (!foundCurrent && div.length > 0) { - setTestCurrent(div[0]); - } else if (found) { - setTestCurrent(div[idx - 1]); - } else { - resetTestCurrent(); - }; - }; -}; - -function gotoTop() { - window.scrollTo(0,0); - resetTestCurrent(); -}; diff -Nru ounit-2.0.8/src/oUnitLoggerHTML.ml ounit-2.2.3/src/oUnitLoggerHTML.ml --- ounit-2.0.8/src/oUnitLoggerHTML.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitLoggerHTML.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,256 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(* - HTML logger for OUnit. - *) - -open OUnitLogger -open OUnitUtils -open OUnitTest -open OUnitResultSummary - -let html_escaper str = - let buffer = Buffer.create (String.length str) in - let addc = Buffer.add_char buffer in - let addse se = - addc '&'; - Buffer.add_string buffer se; - addc ';' - in - String.iter - (function - | '"' -> addse "quot" - | '&' -> addse "amp" - | '<' -> addse "lt" - | '>' -> addse "gt" -(* - | 'Œ' -> addse "OElig" - | 'œ' -> addse "oelig" - | 'Š' -> addse "Scaron" - | 'š' -> addse "scaron" - | 'Ÿ' -> addse "Yuml" - | 'ˆ' -> addse "circ" - | '˜' -> addse "tilde" - | ' ' -> addse "ensp" - | ' ' -> addse "emsp" - | ' ' -> addse "thinsp" - | '–' -> addse "ndash" - | '—' -> addse "mdash" - | '‘' -> addse "lsquo" - | '’' -> addse "rsquo" - | '‚' -> addse "sbquo" - | '“' -> addse "ldquo" - | '”' -> addse "rdquo" - | '„' -> addse "bdquo" - | '†' -> addse "dagger" - | '‡' -> addse "Dagger" - | '‰' -> addse "permil" - | '‹' -> addse "lsaquo" - | '›' -> addse "rsaquo" - | '€' -> addse "euro" - *) - | '\'' -> addse "#39" - | c -> addc c) - str; - Buffer.contents buffer - -let render conf dn events = - let smr = - OUnitResultSummary.of_log_events conf events - in - let () = - if not (Sys.file_exists dn) then - Unix.handle_unix_error (fun () -> Unix.mkdir dn 0o755) () - in - - let chn = open_out (Filename.concat dn "oUnit.css") in - let () = - output_string chn OUnitLoggerHTMLData.oUnit_css; - close_out chn - in - - let chn = open_out (Filename.concat dn "oUnit.js") in - let () = - output_string chn OUnitLoggerHTMLData.oUnit_js; - close_out chn - in - - let chn = open_out (Filename.concat dn "index.html") in - let printf fmt = Printf.fprintf chn fmt in - printf "\ - - - Test suite %s - - - - - - -

Test suite %s

-
-

Results

-
\n" - (html_escaper smr.suite_name) smr.charset (html_escaper smr.suite_name); - begin - let printf_result clss label num = - printf - "
\n\ - %s: %d\n\ -
\n" - clss label num - in - let printf_non0_result clss label num = - if num > 0 then - printf_result clss label num - in - printf - "
\ - Started at: %s -
" (date_iso8601 smr.start_at); - printf - "
\ - Total duration: %.3fs\ -
" smr.running_time; - printf_result "test-count" "Tests count" smr.test_case_count; - printf_non0_result "errors" "Errors" smr.errors; - printf_non0_result "failures" "Failures" smr.failures; - printf_non0_result "skips" "Skipped" smr.skips; - printf_non0_result "todos" "TODO" smr.todos; - printf_non0_result "timeouts" "Timed out" smr.timeouts; - printf_result "successes" "Successes" smr.successes; - - (* Print final verdict *) - if was_successful smr.global_results then - printf "
Success
" - else - printf "
Failure
" - end; - - printf "\ -
-
-
-

Configuration

-
\n"; - List.iter - (fun (k, v) -> printf "%s=%S
\n" - (html_escaper k) (html_escaper v)) - smr.conf; - printf ("\ -
-
-"); - List.iter - (fun test_data -> - let class_result, text_result = - match test_data.test_result with - | RSuccess -> "ounit-success", "succeed" - | RFailure _ -> "ounit-failure", "failed" - | RError _ -> "ounit-error", "error" - | RSkip _ -> "ounit-skip", "skipped" - | RTodo _ -> "ounit-todo", "TODO" - | RTimeout _ -> "ounit-timeout", "timeout" - in - let class_severity_opt = - function - | Some `Error -> "ounit-log-error" - | Some `Warning -> "ounit-log-warning" - | Some `Info -> "ounit-log-info" - | None -> "" - in - printf " -
-

%s (%s)

-
Started at: %s
-
Test duration: %.3fs
-
\n" - class_result - (html_escaper test_data.test_name) - (html_escaper text_result) - (date_iso8601 test_data.timestamp_start) - (test_data.timestamp_end -. test_data.timestamp_start); - printf "%.3fsStart
\n" - 0.0; - List.iter (fun (tmstp, svrt, str) -> - printf "\ - - %.3fs%s
\n" - (class_severity_opt svrt) tmstp (html_escaper str)) - test_data.log_entries; - printf "%.3fsEnd
\n" - (test_data.timestamp_end -. test_data.timestamp_start); - printf "
"; - begin - (* TODO: use backtrace *) - match test_data.test_result with - | RSuccess -> printf "Success." - | RFailure (str, _, backtrace) -> - printf "Failure:
%s" (html_escaper str) - | RError (str, backtrace) -> - printf "Error:
%s" (html_escaper str) - | RSkip str -> - printf "Skipped:
%s" (html_escaper str) - | RTodo str -> - printf "Todo:
%s" (html_escaper str) - | RTimeout test_length -> - printf "Timeout after %.1fs
" - (delay_of_length test_length) - end; - printf "
"; - printf "\ -
-
\n"; (* TODO: results, end timestamp *)) - smr.tests; - printf "\ - -"; - close_out chn - -let output_html_dir = - OUnitConf.make_string_subst_opt - "output_html_dir" - None - "Output directory of the HTML files." - -let create conf = - match output_html_dir conf with - | Some dn -> - post_logger (render conf dn) - | None -> - null_logger diff -Nru ounit-2.0.8/src/oUnitLoggerJUnit.ml ounit-2.2.3/src/oUnitLoggerJUnit.ml --- ounit-2.0.8/src/oUnitLoggerJUnit.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitLoggerJUnit.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,149 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(* - JUnit logger for OUnit. - *) - -open OUnitLogger -open OUnitUtils -open OUnitTest -open OUnitResultSummary - - -let xml_escaper = OUnitLoggerHTML.html_escaper - -let render conf fn events = - let smr = - OUnitResultSummary.of_log_events conf events - in - let chn = open_out fn in - let string_of_failure = - function - | msg, None -> - msg^"\nNo backtrace." - | msg, Some backtrace -> - msg^"\n"^backtrace - in - let printf fmt = Printf.fprintf chn fmt in - printf "\ - - - \n" - smr.charset - (xml_escaper smr.suite_name) - (xml_escaper smr.suite_name) - (xml_escaper (date_iso8601 ~tz:false smr.start_at)) - (xml_escaper (fqdn ())) - smr.test_case_count - (smr.failures + smr.todos) - smr.errors - smr.running_time; - printf "\ -\ \n"; - List.iter - (fun (k, v) -> - printf "\ -\ \n" - (xml_escaper k) (xml_escaper v)) - smr.conf; - printf "\ -\ \n"; - List.iter - (fun test_data -> - printf "\ -\ \n" - (xml_escaper test_data.test_name) - (xml_escaper test_data.test_name) - (test_data.timestamp_end -. test_data.timestamp_start); - begin - match test_data.test_result with - | RSuccess | RSkip _ -> - () - | RError (msg, backtrace) -> - printf "\ -\ %s\n" - (xml_escaper msg) - (xml_escaper (string_of_failure (msg, backtrace))) - | RFailure (msg, _, backtrace) -> - printf "\ -\ %s\n" - (xml_escaper msg) - (xml_escaper (string_of_failure (msg, backtrace))) - | RTodo msg -> - printf "\ -\ \n" - (xml_escaper msg) - | RTimeout test_length -> - printf "\ -\ \n" - (delay_of_length test_length) - end; - printf "\ -\ \n") - smr.tests; - printf "\ -\ \n"; - List.iter - (fun log_event -> - List.iter (fun s -> printf "%s\n" (xml_escaper s)) - (OUnitLoggerStd.format_log_event log_event)) - events; - printf "\ -\ - - - -"; - close_out chn - -let output_junit_file = - OUnitConf.make_string_subst_opt - "output_junit_file" - None - "Output file for JUnit." - -let create conf = - match output_junit_file conf with - | Some fn -> - post_logger (render conf fn) - | None -> - null_logger diff -Nru ounit-2.0.8/src/oUnitLogger.ml ounit-2.2.3/src/oUnitLogger.ml --- ounit-2.0.8/src/oUnitLogger.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitLogger.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,235 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(* - Logger for information and various OUnit events. - *) - -open OUnitUtils - -(* See OUnit.mli. *) -type position = - { - filename: string; - line: int; - } - -(** See OUnit.mli. *) -type log_severity = [`Error | `Warning | `Info] - -(** See OUnit.mli. *) -type 'result test_event = - | EStart - | EEnd - | EResult of 'result - | ELog of log_severity * string - | ELogRaw of string - -type ('path, 'result) result_full = ('path * 'result * position option) - -(** Events which occur at the global level. *) -type ('path, 'result) global_event = - | GConf of string * string (** Dump a configuration options. *) - | GLog of log_severity * string - | GStart (** Start running the tests. *) - | GEnd (** Finish running the tests. *) - | GResults of (float * ('path, 'result) result_full list * int) - -type ('path, 'result) log_event_t = - | GlobalEvent of ('path, 'result) global_event - | TestEvent of 'path * 'result test_event - -type ('path, 'result) log_event = - { - shard: string; - timestamp: float; - event: ('path, 'result) log_event_t; - } - -type ('path, 'result) logger = - { - lshard: string; - fwrite: ('path, 'result) log_event -> unit; - fpos: unit -> position option; - fclose: unit -> unit; - } - -let shard_default = OUnitUtils.shardf 0 - -let string_of_event ev = - let spf fmt = Printf.sprintf fmt in - let string_of_log_severity = - function - | `Error -> "`Error" - | `Warning -> "`Warning" - | `Info -> "`Info" - in - match ev with - | GlobalEvent e -> - begin - match e with - | GConf (k, v) -> spf "GConf (%S, %S)" k v - | GLog (lvl, s) -> - spf "GLog (%s, %S)" (string_of_log_severity lvl) s - | GStart -> "GStart" - | GEnd -> "GEnd" - | GResults _ -> "GResults" - end - | TestEvent (path, e) -> - begin - match e with - | EStart -> - "EStart" - | EEnd -> - "EEnd" - | EResult result -> - "EResult (_)" - | ELog (lvl, str) -> - spf "ELog (%s, %S)" (string_of_log_severity lvl) str - | ELogRaw str -> - spf "ELogRaw %S" str - end - - -let null_logger = - { - lshard = shard_default; - fwrite = ignore; - fpos = (fun () -> None); - fclose = ignore; - } - - -let fun_logger fwrite fclose = - { - lshard = shard_default; - fwrite = (fun log_ev -> fwrite log_ev); - fpos = (fun () -> None); - fclose = fclose; - } - -let post_logger fpost = - let data = ref [] in - let fwrite ev = data := ev :: !data in - let fclose () = fpost (List.rev !data) in - { - lshard = shard_default; - fwrite = fwrite; - fpos = (fun () -> None); - fclose = fclose; - } - -let set_shard shard logger = - {logger with lshard = shard} - -let report logger ev = - logger.fwrite - { - shard = logger.lshard; - timestamp = now (); - event = ev; - } - -let infof logger fmt = - Printf.ksprintf - (fun str -> report logger (GlobalEvent (GLog (`Info, str)))) - fmt - -let warningf logger fmt = - Printf.ksprintf - (fun str -> report logger (GlobalEvent (GLog (`Warning, str)))) - fmt - -let errorf logger fmt = - Printf.ksprintf - (fun str -> report logger (GlobalEvent (GLog (`Error, str)))) - fmt - -let position logger = - logger.fpos () - -let close logger = - logger.fclose () - -let combine lst = - let rec fpos = - function - | logger :: tl -> - begin - match position logger with - | Some _ as pos -> - pos - | None -> - fpos tl - end - | [] -> - None - in - let lshard = - match lst with hd :: _ -> hd.lshard | [] -> shard_default - in - { - lshard = lshard; - fwrite = - (fun log_ev -> - List.iter - (fun logger -> - logger.fwrite log_ev) lst); - fpos = (fun () -> fpos lst); - fclose = - (fun () -> - List.iter (fun logger -> close logger) (List.rev lst)); - } - -module Test = -struct - type 'result t = 'result test_event -> unit - - let create logger path = - fun ev -> - logger.fwrite - { - shard = logger.lshard; - timestamp = now (); - event = TestEvent (path, ev) - } - - let raw_printf t fmt = - Printf.ksprintf - (fun s -> t (ELogRaw s)) - fmt - - let logf t lvl fmt = - Printf.ksprintf - (fun s -> t (ELog (lvl, s))) - fmt -end diff -Nru ounit-2.0.8/src/oUnitLoggerStd.ml ounit-2.2.3/src/oUnitLoggerStd.ml --- ounit-2.0.8/src/oUnitLoggerStd.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitLoggerStd.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,325 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnitLogger -open OUnitTest -open OUnitResultSummary - -let ocaml_position pos = - Printf.sprintf - "File \"%s\", line %d, characters 1-1:" - pos.filename pos.line - -let multiline f str = - if String.length str > 0 then - let buf = Buffer.create 80 in - let flush () = f (Buffer.contents buf); Buffer.clear buf in - String.iter - (function '\n' -> flush () | c -> Buffer.add_char buf c) - str; - flush () - -let count results f = - List.fold_left - (fun count (_, test_result, _) -> - if f test_result then count + 1 else count) - 0 results - -(* TODO: deprecate in 2.1.0. *) -let results_style_1_X = - OUnitConf.make_bool - "results_style_1_X" - false - "Use OUnit 1.X results printer (will be deprecated in 2.1.0+)." - -let format_display_event conf log_event = - match log_event.event with - | GlobalEvent e -> - begin - match e with - | GConf (_, _) | GLog _ | GStart | GEnd -> "" - | GResults (running_time, results, test_case_count) -> - let separator1 = String.make (Format.get_margin ()) '=' in - let separator2 = String.make (Format.get_margin ()) '-' in - let buf = Buffer.create 1024 in - let bprintf fmt = Printf.bprintf buf fmt in - let print_results = - List.iter - (fun (path, test_result, pos_opt) -> - bprintf "%s\n" separator1; - if results_style_1_X conf then begin - bprintf "%s: %s\n\n" - (result_flavour test_result) - (string_of_path path); - end else begin - bprintf "Error: %s.\n\n" (string_of_path path); - begin - match pos_opt with - | Some pos -> - bprintf "%s\nError: %s (in the log).\n\n" - (ocaml_position pos) - (string_of_path path) - | None -> - () - end; - begin - match test_result with - | RError (_, Some backtrace) -> - bprintf "%s\n" backtrace - | RFailure (_, Some pos, _) -> - bprintf "%s\nError: %s (in the code).\n\n" - (ocaml_position pos) - (string_of_path path) - | RFailure (_, _, Some backtrace) -> - bprintf "%s\n" backtrace - | _ -> - () - end; - end; - bprintf "%s\n" (result_msg test_result); - bprintf "%s\n" separator2) - in - let filter f = - let lst = - List.filter - (fun (_, test_result, _) -> f test_result) - results - in - lst, List.length lst - in - let errors, nerrors = filter is_error in - let failures, nfailures = filter is_failure in - let skips, nskips = filter is_skip in - let todos, ntodos = filter is_todo in - let timeouts, ntimeouts = filter is_timeout in - bprintf "\n"; - print_results errors; - print_results failures; - print_results timeouts; - bprintf "Ran: %d tests in: %.2f seconds.\n" - (List.length results) running_time; - - (* Print final verdict *) - if was_successful results then - begin - if skips = [] then - bprintf "OK" - else - bprintf "OK: Cases: %d Skip: %d" - test_case_count nskips - end - else - begin - bprintf - "FAILED: Cases: %d Tried: %d Errors: %d \ - Failures: %d Skip: %d Todo: %d \ - Timeouts: %d." - test_case_count - (List.length results) - nerrors - nfailures - nskips - ntodos - ntimeouts; - end; - bprintf "\n"; - Buffer.contents buf - end - - | TestEvent (_, e) -> - begin - match e with - | EStart | EEnd | ELog _ | ELogRaw _ -> "" - | EResult RSuccess -> "." - | EResult (RFailure _) -> "F" - | EResult (RError _) -> "E" - | EResult (RSkip _) -> "S" - | EResult (RTodo _) -> "T" - | EResult (RTimeout _) -> "~" - end - -let format_log_event ev = - let rlst = ref [] in - let timestamp_str = OUnitUtils.date_iso8601 ev.timestamp in - let spf pre fmt = - Printf.ksprintf - (multiline - (fun l -> - rlst := (timestamp_str^" "^ev.shard^" "^pre^": "^l) :: !rlst)) - fmt - in - let ispf fmt = spf "I" fmt in - let wspf fmt = spf "W" fmt in - let espf fmt = spf "E" fmt in - let format_result path result = - let path_str = string_of_path path in - match result with - | RTimeout test_length -> - espf "Test %s timed out after %.1fs" - path_str (delay_of_length test_length) - | RError (msg, backtrace_opt) -> - espf "Test %s exited with an error." path_str; - espf "%s in test %s." msg path_str; - OUnitUtils.opt (espf "%s") backtrace_opt - | RFailure (msg, _, backtrace_opt) -> - espf "Test %s has failed." path_str; - espf "%s in test %s." msg path_str; - OUnitUtils.opt (espf "%s") backtrace_opt - | RTodo msg -> wspf "TODO test %s: %s." path_str msg - | RSkip msg -> wspf "Skip test %s: %s." path_str msg - | RSuccess -> ispf "Test %s is successful." path_str - in - - begin - match ev.event with - | GlobalEvent e -> - begin - match e with - | GConf (k, v) -> ispf "Configuration %s = %S" k v - | GLog (`Error, str) -> espf "%s" str - | GLog (`Warning, str) -> wspf "%s" str - | GLog (`Info, str) -> ispf "%s" str - | GStart -> ispf "Start testing." - | GEnd -> ispf "End testing." - | GResults (running_time, results, test_case_count) -> - let countr = count results in - ispf "=============="; - ispf "Summary:"; - List.iter - (fun (path, test_result, _) -> - format_result path test_result) - results; - (* Print final verdict *) - ispf "Ran: %d tests in: %.2f seconds." - (List.length results) running_time; - ispf "Cases: %d." test_case_count; - ispf "Tried: %d." (List.length results); - ispf "Errors: %d." (countr is_error); - ispf "Failures: %d." (countr is_failure); - ispf "Skip: %d." (countr is_skip); - ispf "Todo: %d." (countr is_todo); - ispf "Timeout: %d." (countr is_timeout) - end - - | TestEvent (path, e) -> - begin - let path_str = string_of_path path in - match e with - | EStart -> ispf "Start test %s." path_str - | EEnd -> ispf "End test %s." path_str - | EResult result -> format_result path result - | ELog (`Error, str) -> espf "%s" str - | ELog (`Warning, str) -> wspf "%s" str - | ELog (`Info, str) -> ispf "%s" str - | ELogRaw str -> ispf "%s" str - end - end; - List.rev !rlst - -let file_logger conf shard_id fn = - let chn = open_out fn in - let line = ref 1 in - - let fwrite ev = - List.iter - (fun l -> output_string chn l; output_char chn '\n'; incr line) - (format_log_event ev); - flush chn - in - let fpos () = - Some { filename = fn; line = !line } - in - let fclose () = - close_out chn - in - { - lshard = shard_id; - fwrite = fwrite; - fpos = fpos; - fclose = fclose; - } - -let verbose = - OUnitConf.make_bool - "verbose" - false - "Run test in verbose mode." - -let display = - OUnitConf.make_bool - "display" - true - "Output logs on screen." - -let std_logger conf shard_id = - if display conf then - let verbose = verbose conf in - let fwrite log_ev = - if verbose then - List.iter print_endline (format_log_event log_ev) - else - print_string (format_display_event conf log_ev); - flush stdout - in - { - lshard = shard_id; - fwrite = fwrite; - fpos = (fun () -> None); - fclose = ignore; - } - else - null_logger - -let output_file = - OUnitConf.make_string_subst_opt - "output_file" - (Some (Filename.concat - OUnitUtils.buildir - "oUnit-$(suite_name)-$(shard_id).log")) - "Output verbose log in the given file." - -let is_output_file_shard_dependent conf = - let fn1 = output_file ~extra_subst:["shard_id", "foo"] conf in - let fn2 = output_file ~extra_subst:["shard_id", "bar"] conf in - fn1 <> fn2 - -let create_file_logger conf shard_id = - match output_file ~extra_subst:["shard_id", shard_id] conf with - | Some fn -> - file_logger conf shard_id fn - | None -> - null_logger - -let create conf shard_id = - let std_logger = std_logger conf shard_id in - let file_logger = create_file_logger conf shard_id in - combine [std_logger; file_logger] diff -Nru ounit-2.0.8/src/oUnit.ml ounit-2.2.3/src/oUnit.ml --- ounit-2.0.8/src/oUnit.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnit.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,386 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnitUtils - -let get_test_context, - set_test_context, - reset_test_context = - let context_opt = ref None in - (* get *) - (fun () -> - match !context_opt with - | Some ctxt -> ctxt - | None -> failwith "Function need to be called from inside a test."), - (fun ctxt -> - context_opt := Some ctxt), - (fun ctxt -> - context_opt := None) - -type node = ListItem of int | Label of string - -let node1_of_node = - function - | OUnitTest.ListItem i -> ListItem i - | OUnitTest.Label s -> Label s - -let node_of_node1 = - function - | ListItem i -> OUnitTest.ListItem i - | Label s -> OUnitTest.Label s - -type path = node list - -let path1_of_path pth = - List.map node1_of_node pth - -type test_fun = unit -> unit - -type test = - TestCase of test_fun - | TestList of test list - | TestLabel of string * test - -let rec test1_of_test = - function - | OUnitTest.TestCase (_, f) -> TestCase (fun () -> f (get_test_context ())) - | OUnitTest.TestList lst -> TestList (List.map test1_of_test lst) - | OUnitTest.TestLabel (str, tst) -> TestLabel (str, test1_of_test tst) - -let rec test_of_test1 = - function - | TestCase f -> - OUnitTest.TestCase - (OUnitTest.Short, - fun ctxt -> - set_test_context ctxt; - f (); - reset_test_context ()) - | TestList lst -> OUnitTest.TestList (List.map test_of_test1 lst) - | TestLabel (str, tst) -> OUnitTest.TestLabel (str, test_of_test1 tst) - -let rec ounit2_of_ounit1 = - function - | TestCase f -> - OUnit2.test_case - (fun ctxt -> - set_test_context ctxt; - f (); - reset_test_context ()) - | TestList lst -> - OUnit2.test_list (List.map ounit2_of_ounit1 lst) - | TestLabel (lbl, test) -> - OUnit2.( >: ) lbl (ounit2_of_ounit1 test) - -type test_result = - RSuccess of path - | RFailure of path * string - | RError of path * string - | RSkip of path * string - | RTodo of path * string - -let test_result1_of_test_result path rslt = - let path1 = - path1_of_path path - in - let rslt1 = - match rslt with - | OUnitTest.RSuccess -> - RSuccess path1 - | OUnitTest.RFailure (str, _, _) -> - RFailure (path1, str) - | OUnitTest.RError (str, _) -> - RError (path1, str) - | OUnitTest.RSkip str -> - RSkip (path1, str) - | OUnitTest.RTodo str -> - RTodo (path1, str) - | OUnitTest.RTimeout test_length -> - RError (path1, - (Printf.sprintf - "timeout after %.1fs." - (OUnitTest.delay_of_length test_length))) - in - rslt1 - - -type test_event = - EStart of path - | EEnd of path - | EResult of test_result - -let result_path = - function - | RSuccess path - | RError (path, _) - | RFailure (path, _) - | RSkip (path, _) - | RTodo (path, _) -> path - -type test_results = test_result list - -let list_result1_of_list_result = - List.map - (fun (pth, rslt, _) -> - test_result1_of_test_result pth rslt) - -let assert_failure = - OUnitAssert.assert_failure - -let assert_bool = - OUnitAssert.assert_bool - -let ( @? ) = - OUnitAssert.assert_bool - -let assert_string = - OUnitAssert.assert_string - -let assert_command - ?exit_code ?sinput ?foutput ?use_stderr ?env ?(verbose=false) prg args = - let ctxt = - let ctxt = get_test_context () in - let conf' = Hashtbl.copy ctxt.OUnitTest.conf in - OUnitConf.set ~origin:"OUnit.assert_command" conf' - "verbose" (string_of_bool verbose); - { - ctxt with - OUnitTest.test_logger = - OUnitLogger.Test.create - (OUnitLoggerStd.std_logger conf' OUnitLogger.shard_default) - ctxt.OUnitTest.path; - } - in - OUnitAssert.assert_command - ?exit_code ?sinput ?foutput ?use_stderr ?env ~ctxt - prg args - -let assert_equal ?cmp ?printer ?pp_diff ?msg a b = - OUnitAssert.assert_equal ?cmp ?printer ?pp_diff ?msg a b - -let assert_raises ?msg exc f = - OUnitAssert.assert_raises ?msg exc f - -let skip_if = - OUnitAssert.skip_if - -let todo = - OUnitAssert.todo - -let cmp_float ?epsilon f1 f2 = - OUnitUtils.cmp_float ?epsilon f1 f2 - -let bracket pre f post () = - OUnitTest.section_ctxt (get_test_context ()) - (fun ctxt -> - let fixture = - OUnitBracket.create - (fun _ -> pre ()) - (fun fixture _ -> post fixture) - ctxt - in - let () = f fixture in - ()) - -let bracket_tmpfile ?prefix ?suffix ?mode gen () = - OUnitTest.section_ctxt (get_test_context ()) - (fun ctxt -> - let fixture = - OUnitBracket.bracket_tmpfile ?prefix ?suffix ?mode ctxt - in - gen fixture) - -let (>:) a b = - test1_of_test (OUnitTest.(>:) a (test_of_test1 b)) - -let (>::) a b = - test1_of_test (OUnitTest.(>::) a (fun _ -> b ())) - -let (>:::) a b = - test1_of_test (OUnitTest.(>:::) a (List.map test_of_test1 b)) - -let test_decorate g tst = - test1_of_test - (OUnitTest.test_decorate - (fun f -> - let f1 = (fun () -> f (get_test_context ())) in - let f1' = g f1 in - (fun ctxt -> - set_test_context ctxt; - f1' (); - reset_test_context ())) - (test_of_test1 tst)) - -let test_filter ?skip lst test = - let res = - OUnitTest.test_filter ?skip lst (test_of_test1 test) - in - match res with - | Some tst -> Some (test1_of_test tst) - | None -> None - -let test_case_count tst = - OUnitTest.test_case_count (test_of_test1 tst) - -let string_of_node nd = - OUnitTest.string_of_node (node_of_node1 nd) - -let string_of_path pth = - OUnitTest.string_of_path (List.map node_of_node1 pth) - -let test_case_paths tst = - let lst = - OUnitTest.test_case_paths (test_of_test1 tst) - in - List.map - (List.map node1_of_node) - lst - -let default_v1_conf ?(verbose=false) () = - OUnitConf.default - ~preset: - [ - "chooser", "simple"; - "runner", "sequential"; - "results_style_1_X", "true"; - "verbose", (string_of_bool verbose); - "output_file", "none"; - ] - () - -let perform_test logger1 tst = - let logger = - OUnitLogger.fun_logger - (function - | {OUnitLogger.event = OUnitLogger.GlobalEvent _} -> - () - | {OUnitLogger.event = OUnitLogger.TestEvent (path, test_event)} -> - begin - let path1 = - path1_of_path path - in - match test_event with - | OUnitLogger.EStart -> - logger1 (EStart path1) - | OUnitLogger.EEnd -> - logger1 (EEnd path1) - | OUnitLogger.EResult rslt -> - logger1 (EResult (test_result1_of_test_result path rslt)) - | OUnitLogger.ELog _ | OUnitLogger.ELogRaw _ -> - () - end) - ignore - in - let conf = default_v1_conf () in - list_result1_of_list_result - (OUnitCore.perform_test - conf - logger - (snd (OUnitRunner.choice conf)) - (snd (OUnitChooser.choice conf)) - (test_of_test1 tst)) - -let run_test_tt ?verbose test = - let conf = default_v1_conf ?verbose () in - list_result1_of_list_result - (OUnitCore.run_test_tt - conf - (OUnitLoggerStd.create conf OUnitLogger.shard_default) - (snd (OUnitRunner.choice conf)) - (snd (OUnitChooser.choice conf)) - (test_of_test1 test)) - -let run_test_tt_main ?(arg_specs=[]) ?(set_verbose=ignore) suite = - let suite = test_of_test1 suite in - let only_test = ref [] in - let list_test = ref false in - let verbose = ref false in - let specs = - [ - "-verbose", - Arg.Set verbose, - " Rather than displaying dots while running the test, be more verbose."; - - "-only-test", - Arg.String (fun str -> only_test := str :: !only_test), - "path Run only the selected tests."; - - "-list-test", - Arg.Set list_test, - " List tests"; - ] @ arg_specs - in - let () = - Arg.parse - (Arg.align specs) - (fun x -> raise (Arg.Bad ("Bad argument : " ^ x))) - ("usage: " ^ Sys.argv.(0) ^ " [options] [-only-test path]*") - in - let conf = default_v1_conf ~verbose:!verbose () in - set_verbose (OUnitLoggerStd.verbose conf); - if !list_test then - begin - List.iter - (fun pth -> print_endline (OUnitTest.string_of_path pth)) - (OUnitTest.test_case_paths suite); - [] - end - else - begin - let nsuite = - if !only_test = [] then - suite - else - begin - match OUnitTest.test_filter ~skip:true !only_test suite with - | Some test -> - test - | None -> - failwithf - "Filtering test %s lead to no tests." - (String.concat ", " !only_test) - end - in - - let test_results = - OUnitCore.run_test_tt - conf - (OUnitLoggerStd.std_logger conf OUnitLogger.shard_default) - (snd (OUnitRunner.choice conf)) - (snd (OUnitChooser.choice conf)) - nsuite - in - if not (OUnitResultSummary.was_successful test_results) then - exit 1 - else - list_result1_of_list_result test_results; - end diff -Nru ounit-2.0.8/src/oUnit.mldylib ounit-2.2.3/src/oUnit.mldylib --- ounit-2.0.8/src/oUnit.mldylib 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/src/oUnit.mldylib 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 1ad80d12b97eab491c61097067896fca) -OUnit -OUnit2 -# OASIS_STOP diff -Nru ounit-2.0.8/src/oUnit.mli ounit-2.2.3/src/oUnit.mli --- ounit-2.0.8/src/oUnit.mli 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnit.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,287 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(** Unit test building blocks - - @author Maas-Maarten Zeeman - @author Sylvain Le Gall - *) - -(** {2 Assertions} - - Assertions are the basic building blocks of unittests. *) - -(** Signals a failure. This will raise an exception with the specified - string. - - @raise Failure signal a failure *) -val assert_failure : string -> 'a - -(** Signals a failure when bool is false. The string identifies the - failure. - - @raise Failure signal a failure *) -val assert_bool : string -> bool -> unit - -(** Shorthand for assert_bool - - @raise Failure to signal a failure *) -val ( @? ) : string -> bool -> unit - -(** Signals a failure when the string is non-empty. The string identifies the - failure. - - @raise Failure signal a failure *) -val assert_string : string -> unit - -(** [assert_command prg args] Run the command provided. - - @param exit_code expected exit code - @param sinput provide this [char Stream.t] as input of the process - @param foutput run this function on output, it can contains an - [assert_equal] to check it - @param use_stderr redirect [stderr] to [stdout] - @param env Unix environment - @param verbose if failed, dump stdout/stderr of the process to stderr - - @since 1.1.0 - *) -val assert_command : - ?exit_code:Unix.process_status -> - ?sinput:char Stream.t -> - ?foutput:(char Stream.t -> unit) -> - ?use_stderr:bool -> - ?env:string array -> - ?verbose:bool -> - string -> string list -> unit - -(** [assert_equal expected real] Compares two values, when they are not equal a - failure is signaled. - - @param cmp customize function to compare, default is [=] - @param printer value printer, don't print value otherwise - @param pp_diff if not equal, ask a custom display of the difference - using [diff fmt exp real] where [fmt] is the formatter to use - @param msg custom message to identify the failure - - @raise Failure signal a failure - - @version 1.1.0 - *) -val assert_equal : - ?cmp:('a -> 'a -> bool) -> - ?printer:('a -> string) -> - ?pp_diff:(Format.formatter -> ('a * 'a) -> unit) -> - ?msg:string -> 'a -> 'a -> unit - -(** Asserts if the expected exception was raised. - - @param msg identify the failure - - @raise Failure description *) -val assert_raises : ?msg:string -> exn -> (unit -> 'a) -> unit - -(** {2 Skipping tests } - - In certain condition test can be written but there is no point running it, - because they are not significant (missing OS features for example). In this - case this is not a failure nor a success. Following functions allow you to - escape test, just as assertion but without the same error status. - - A test skipped is counted as success. A test todo is counted as failure. - *) - -(** [skip cond msg] If [cond] is true, skip the test for the reason explain in - [msg]. For example [skip_if (Sys.os_type = "Win32") "Test a doesn't run on - windows"]. - - @since 1.0.3 - *) -val skip_if : bool -> string -> unit - -(** The associated test is still to be done, for the reason given. - - @since 1.0.3 - *) -val todo : string -> unit - -(** {2 Compare Functions} *) - -(** Compare floats up to a given relative error. - - @param epsilon if the difference is smaller [epsilon] values are equal - *) -val cmp_float : ?epsilon:float -> float -> float -> bool - -(** {2 Bracket} - - A bracket is a functional implementation of the commonly used - setUp and tearDown feature in unittests. It can be used like this: - - ["MyTestCase" >:: (bracket test_set_up test_fun test_tear_down)] - - *) - -(** [bracket set_up test tear_down] The [set_up] function runs first, then - the [test] function runs and at the end [tear_down] runs. The - [tear_down] function runs even if the [test] failed and help to clean - the environment. - *) -val bracket: (unit -> 'a) -> ('a -> unit) -> ('a -> unit) -> unit -> unit - -(** [bracket_tmpfile test] The [test] function takes a temporary filename - and matching output channel as arguments. The temporary file is created - before the test and removed after the test. - - @param prefix see [Filename.open_temp_file] - @param suffix see [Filename.open_temp_file] - @param mode see [Filename.open_temp_file] - - @since 1.1.0 - *) -val bracket_tmpfile: - ?prefix:string -> - ?suffix:string -> - ?mode:open_flag list -> - ((string * out_channel) -> unit) -> unit -> unit - -(** {2 Constructing Tests} *) - -(** The type of test function *) -type test_fun = unit -> unit - -(** The type of tests *) -type test = - TestCase of test_fun - | TestList of test list - | TestLabel of string * test - -(** Create a TestLabel for a test *) -val (>:) : string -> test -> test - -(** Create a TestLabel for a TestCase *) -val (>::) : string -> test_fun -> test - -(** Create a TestLabel for a TestList *) -val (>:::) : string -> test list -> test - -(** Some shorthands which allows easy test construction. - - Examples: - - - ["test1" >: TestCase((fun _ -> ()))] => - [TestLabel("test2", TestCase((fun _ -> ())))] - - ["test2" >:: (fun _ -> ())] => - [TestLabel("test2", TestCase((fun _ -> ())))] - - ["test-suite" >::: ["test2" >:: (fun _ -> ());]] => - [TestLabel("test-suite", TestSuite([TestLabel("test2", - TestCase((fun _ -> ())))]))] -*) - -(** [test_decorate g tst] Apply [g] to test function contains in [tst] tree. - - @since 1.0.3 - *) -val test_decorate : (test_fun -> test_fun) -> test -> test - -(** [test_filter paths tst] Filter test based on their path string - representation. - - @param skip if set, just use [skip_if] for the matching tests. - @since 1.0.3 - *) -val test_filter : ?skip:bool -> string list -> test -> test option - -(** {2 Retrieve Information from Tests} *) - -(** Returns the number of available test cases *) -val test_case_count : test -> int - -(** Types which represent the path of a test *) -type node = ListItem of int | Label of string -type path = node list (** The path to the test (in reverse order). *) - -(** Make a string from a node *) -val string_of_node : node -> string - -(** Make a string from a path. The path will be reversed before it is - tranlated into a string *) -val string_of_path : path -> string - -(** Returns a list with paths of the test *) -val test_case_paths : test -> path list - -(** {2 Performing Tests} *) - -(** The possible results of a test *) -type test_result = - RSuccess of path - | RFailure of path * string - | RError of path * string - | RSkip of path * string - | RTodo of path * string - -(** Events which occur during a test run. *) -type test_event = - EStart of path (** A test start. *) - | EEnd of path (** A test end. *) - | EResult of test_result (** Result of a test. *) - -(** Results of a test run. *) -type test_results = test_result list - -(** Perform the test, allows you to build your own test runner *) -val perform_test : (test_event -> unit) -> test -> test_results - -(** A simple text based test runner. - - @param verbose print verbose message - *) -val run_test_tt : ?verbose:bool -> test -> test_results - -(** Main version of the text based test runner. It reads the supplied command - line arguments to set the verbose level and limit the number of test to - run. - - @param arg_specs add extra command line arguments - @param set_verbose call a function to set verbosity - @param fexit call a final function after test, by default exit 1. - - @version 1.1.0 - *) -val run_test_tt_main : - ?arg_specs:(Arg.key * Arg.spec * Arg.doc) list -> - ?set_verbose:(bool -> unit) -> - test -> test_results - - -val ounit2_of_ounit1 : test -> OUnit2.test diff -Nru ounit-2.0.8/src/oUnit.mllib ounit-2.2.3/src/oUnit.mllib --- ounit-2.0.8/src/oUnit.mllib 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/src/oUnit.mllib 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 1ad80d12b97eab491c61097067896fca) -OUnit -OUnit2 -# OASIS_STOP diff -Nru ounit-2.0.8/src/oUnitPlugin.ml ounit-2.2.3/src/oUnitPlugin.ml --- ounit-2.0.8/src/oUnitPlugin.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitPlugin.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(** Standard functions for plugin (register, choose). *) - -module type SETTINGS = -sig - type t - val name: string - val conf_help: string - val default_name: string - val default_value: t -end - -module Make(Settings: SETTINGS) = -struct - let all = ref [0, (Settings.default_name, Settings.default_value)] - - let register name pref f = - all := (pref, (name, f)) :: !all - - let of_name s = - try - List.assoc s (List.map snd !all) - with Not_found -> - OUnitUtils.failwithf "Unable to find %s '%s'." Settings.name s - - let choice = - OUnitConf.make_enum - Settings.name - (fun () -> List.map snd !all) - Settings.default_name - Settings.conf_help - - let preset lst = - let _, (default, _) = - List.fold_left max (List.hd !all) (List.tl !all) - in - (Settings.name, default) :: lst - -end diff -Nru ounit-2.0.8/src/oUnitPropList.ml ounit-2.2.3/src/oUnitPropList.ml --- ounit-2.0.8/src/oUnitPropList.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitPropList.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(** Property list. - - @see Eigenclass Article on property list. - *) - -type t = (int, unit -> unit) Hashtbl.t - -let create () = Hashtbl.create 13 - -let new_property default = - let id = Oo.id (object end) in - let v = ref default in - let set t x = - Hashtbl.replace t id (fun () -> v := x) - in - let get t = - try - let x = - (Hashtbl.find t id) (); - !v - in - v := default; - x - with Not_found -> - default - in - (set, get) diff -Nru ounit-2.0.8/src/oUnitResultSummary.ml ounit-2.2.3/src/oUnitResultSummary.ml --- ounit-2.0.8/src/oUnitResultSummary.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitResultSummary.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,322 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(* - Summary of the results, based on captured log events. - *) - -open OUnitUtils -open OUnitTest -open OUnitLogger - -type log_entry = - float (* time since start of the test *) * - log_severity option * - string (* log entry without \n *) - -type test_data = - { - test_name: string; - timestamp_start: float; (* UNIX timestamp *) - timestamp_end: float; (* UNIX timestamp *) - log_entries: log_entry list; (* time sorted log entry, timestamp from - timestamp_start *) - test_result: OUnitTest.result; - } - -type t = - { - suite_name: string; - start_at: float; - charset: string; - conf: (string * string) list; - running_time: float; - global_results: OUnitTest.result_list; - test_case_count: int; - tests: test_data list; - errors: int; - failures: int; - skips: int; - todos: int; - timeouts: int; - successes: int; - } - -let is_success = - function - | RSuccess -> true - | RFailure _ | RError _ | RSkip _ | RTodo _ | RTimeout _ -> false - -let is_failure = - function - | RFailure _ -> true - | RSuccess | RError _ | RSkip _ | RTodo _ | RTimeout _ -> false - -let is_error = - function - | RError _ -> true - | RSuccess | RFailure _ | RSkip _ | RTodo _ | RTimeout _ -> false - -let is_skip = - function - | RSkip _ -> true - | RSuccess | RFailure _ | RError _ | RTodo _ | RTimeout _ -> false - -let is_todo = - function - | RTodo _ -> true - | RSuccess | RFailure _ | RError _ | RSkip _ | RTimeout _ -> false - -let is_timeout = - function - | RTimeout _ -> true - | RSuccess | RFailure _ | RError _ | RSkip _ | RTodo _ -> false - -let result_flavour = - function - | RError _ -> "Error" - | RFailure _ -> "Failure" - | RSuccess -> "Success" - | RSkip _ -> "Skip" - | RTodo _ -> "Todo" - | RTimeout _ -> "Timeout" - -let result_msg = - function - | RSuccess -> "Success" - | RError (msg, _) - | RFailure (msg, _, _) - | RSkip msg - | RTodo msg -> msg - | RTimeout test_length -> - Printf.sprintf "Timeout after %.1fs" (delay_of_length test_length) - -let worst_cmp result1 result2 = - let rank = - function - | RSuccess -> 0 - | RSkip _ -> 1 - | RTodo _ -> 2 - | RFailure _ -> 3 - | RError _ -> 4 - | RTimeout _ -> 5 - in - (rank result1) - (rank result2) - -let worst_result_full result_full lst = - let worst = - List.fold_left - (fun ((_, result1, _) as result_full1) - ((_, result2, _) as result_full2) -> - if worst_cmp result1 result2 < 0 then - result_full2 - else - result_full1) - result_full lst - in - worst, - List.filter - (fun result_full -> not (result_full == worst)) - (result_full :: lst) - -let was_successful lst = - List.for_all - (fun (_, rslt, _) -> - match rslt with - | RSuccess | RSkip _ -> true - | _ -> false) - lst - -let encoding = - OUnitConf.make_string - "log_encoding" - "utf-8" - "Encoding of the log." - -let of_log_events conf events = - let global_conf = - List.fold_left - (fun acc log_ev -> - match log_ev.event with - | GlobalEvent (GConf (k, v)) -> (k, v) :: acc - | _ -> acc) - [] - (List.rev events) - in - let running_time, global_results, test_case_count = - let rec find_results = - function - | {event = - GlobalEvent - (GResults (running_time, results, test_case_count))} :: _ -> - running_time, results, test_case_count - | _ :: tl -> - find_results tl - | [] -> - failwith "Cannot find results in OUnitResult.of_log_events." - in - find_results events - in - let tests = - let rec split_raw tmstp str lst = - try - let idx = String.index str '\n' in - split_raw tmstp - (String.sub str (idx + 1) (String.length str - idx - 1)) - ((tmstp, None, String.sub str 0 idx) :: lst) - with Not_found -> - (tmstp, None, str) :: lst - in - - let finalize t = - let log_entries = - List.sort - (fun (f1, _, _) (f2, _, _) -> Pervasives.compare f2 f1) - t.log_entries - in - let log_entries = - List.rev_map - (fun (f, a, b) -> f -. t.timestamp_start, a, b) - log_entries - in - {t with log_entries = log_entries} - in - - let default_timestamp = 0.0 in - let rec process_log_event tests log_event = - let timestamp = log_event.timestamp in - match log_event.event with - | GlobalEvent _ -> - tests - | TestEvent (path, ev) -> - begin - let t = - try - MapPath.find path tests - with Not_found -> - { - test_name = string_of_path path; - timestamp_start = default_timestamp; - timestamp_end = default_timestamp; - log_entries = []; - test_result = RFailure ("Not finished", None, None); - } - in - let alt0 t1 t2 = - if t1 = default_timestamp then - t2 - else - t1 - in - let t' = - match ev with - | EStart -> - {t with - timestamp_start = timestamp; - timestamp_end = alt0 t.timestamp_end timestamp} - | EEnd -> - {t with - timestamp_end = timestamp; - timestamp_start = alt0 t.timestamp_start timestamp} - | EResult rslt -> - {t with test_result = rslt} - | ELog (svrt, str) -> - {t with log_entries = (timestamp, Some svrt, str) - :: t.log_entries} - | ELogRaw str -> - {t with log_entries = - split_raw timestamp str t.log_entries} - in - MapPath.add path t' tests - end - and group_test tests = - function - | hd :: tl -> - group_test - (process_log_event tests hd) - tl - | [] -> - let lst = - MapPath.fold - (fun _ test lst -> - finalize test :: lst) - tests [] - in - List.sort - (fun t1 t2 -> - Pervasives.compare t1.timestamp_start t2.timestamp_start) - lst - in - group_test MapPath.empty events - in - let start_at = - List.fold_left - (fun start_at log_ev -> - min start_at log_ev.timestamp) - (now ()) - events - in - let suite_name = - match global_results with - | (path, _, _) :: _ -> - List.fold_left - (fun acc nd -> - match nd with - | ListItem _ -> acc - | Label str -> str) - "noname" - path - | [] -> - "noname" - in - let count f = - List.length - (List.filter (fun (_, test_result, _) -> f test_result) - global_results) - in - let charset = encoding conf in - { - suite_name = suite_name; - start_at = start_at; - charset = charset; - conf = global_conf; - running_time = running_time; - global_results = global_results; - test_case_count = test_case_count; - tests = tests; - errors = count is_error; - failures = count is_failure; - skips = count is_skip; - todos = count is_todo; - timeouts = count is_timeout; - successes = count is_success; - } diff -Nru ounit-2.0.8/src/oUnitRunner.ml ounit-2.2.3/src/oUnitRunner.ml --- ounit-2.0.8/src/oUnitRunner.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitRunner.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,524 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnitTest -open OUnitLogger - -(** Common utilities to run test. *) -let run_one_test conf logger shared test_path test_fun = - let () = OUnitLogger.report logger (TestEvent (test_path, EStart)) in - let non_fatal = ref [] in - let main_result_full = - with_ctxt conf logger shared non_fatal test_path - (fun ctxt -> - let check_env = OUnitCheckEnv.create () in - let result_full = - try - test_fun ctxt; - OUnitCheckEnv.check ctxt check_env; - test_path, RSuccess, None - with e -> - OUnitTest.result_full_of_exception ctxt e - in - report_result_full ctxt result_full) - in - let result_full, other_result_fulls = - match main_result_full, List.rev !non_fatal with - | (_, RSuccess, _), [] -> - main_result_full, [] - | (_, RSuccess, _), hd :: tl -> - OUnitResultSummary.worst_result_full hd tl - | _, lst -> - OUnitResultSummary.worst_result_full main_result_full lst - in - OUnitLogger.report logger (TestEvent (test_path, EEnd)); - result_full, other_result_fulls - -type runner = - OUnitConf.conf -> - OUnitTest.logger -> - OUnitChooser.chooser -> - (path * test_length * test_fun) list -> - OUnitTest.result_list - -(* The simplest runner possible, run test one after the other in a single - * process, without threads. - *) - -(* Run all tests, sequential version *) -let sequential_runner conf logger chooser test_cases = - let shared = OUnitShared.create () in - let rec iter state = - match OUnitState.next_test_case conf logger state with - | OUnitState.Finished, state -> - OUnitState.get_results state - | OUnitState.Next_test_case (test_path, test_fun, worker), state -> - iter - (OUnitState.test_finished conf - (run_one_test conf logger shared test_path test_fun) - worker state) - | (OUnitState.Try_again | OUnitState.Not_enough_worker), _ -> - assert false - in - let state = - OUnitState.add_worker () (OUnitState.create conf chooser test_cases) - in - iter state - -(* Plugin interface. *) -module Plugin = - OUnitPlugin.Make - (struct - type t = runner - let name = "runner" - let conf_help = - "Select a the method to run tests." - let default_name = "sequential" - let default_value = sequential_runner - end) - -include Plugin - -let shards = - let shards = ref 2 in - if Sys.os_type = "Unix" then begin - if Sys.file_exists "/proc/cpuinfo" then begin - let chn_in = open_in "/proc/cpuinfo" in - let () = - try - while true do - try - let line = input_line chn_in in - Scanf.sscanf line "cpu cores : %d" (fun i -> shards := max i 2) - with Scanf.Scan_failure _ -> - () - done - with End_of_file -> - () - in - close_in chn_in - end - end; - OUnitConf.make_int - "shards" - !shards - "Number of shards to use as worker (threads or processes)." - -(** Build worker based runner. *) -module GenericWorker = -struct - open OUnitState - - type message_to_worker = - | Exit - | AckLock of bool - | RunTest of path - - let string_of_message_to_worker = - function - | Exit -> "Exit" - | AckLock _ -> "AckLock _" - | RunTest _ -> "RunTest _" - - type message_from_worker = - | AckExit - | Log of OUnitTest.log_event_t - | Lock of int - | Unlock of int - | TestDone of (OUnitTest.result_full * OUnitTest.result_list) - - let string_of_message_from_worker = - function - | AckExit -> "AckExit" - | Log _ -> "Log _" - | Lock _ -> "Lock _" - | Unlock _ -> "Unlock _" - | TestDone _ -> "TestDone _" - - module MapPath = - Map.Make - (struct - type t = path - let rec compare lst1 lst2 = - match lst1, lst2 with - | hd1 :: tl1, hd2 :: tl2 -> - begin - match Pervasives.compare hd1 hd2 with - | 0 -> compare tl1 tl2 - | n -> n - end - | [], _ :: _ -> -1 - | _ :: _, [] -> 1 - | [], [] -> 0 - end) - - type ('a, 'b) channel = - { - send_data: 'a -> unit; - receive_data: unit -> 'b; - close: unit -> unit; - } - - (* Add some extra feature to channel. *) - let wrap_channel - shard_id - string_of_read_message - string_of_written_message - channel = - (* Turn on to debug communication in channel. *) - let debug_communication = false in - if debug_communication then begin - let debugf fmt = - Printf.ksprintf - (fun s -> - if debug_communication then - prerr_endline ("D("^shard_id^"): "^s)) - fmt - in - let send_data msg = - debugf "Sending message %S" (string_of_written_message msg); - channel.send_data msg; - debugf "Message transmitted, continuing." - in - - let receive_data () = - let () = debugf "Waiting to receive data." in - let msg = channel.receive_data () in - debugf "Received message %S" (string_of_read_message msg); - msg - in - { - send_data = send_data; - receive_data = receive_data; - close = channel.close; - } - end else begin - channel - end - - - (* Run a worker, react to message receive from parent. *) - let main_worker_loop - conf yield channel shard_id map_test_cases worker_log_file = - let logger = - let master_logger = - set_shard shard_id - (OUnitLogger.fun_logger - (fun {event = log_ev} -> channel.send_data (Log log_ev)) - ignore) - in - let base_logger = - if worker_log_file then - OUnitLoggerStd.create_file_logger conf shard_id - else - OUnitLogger.null_logger - in - OUnitLogger.combine [base_logger; master_logger] - in - - let shared = - let try_lock id = - channel.send_data (Lock id); - match channel.receive_data () with - | AckLock b -> - b - | Exit | RunTest _ -> - assert false - in - let rec lock id = - if not (try_lock id) then begin - yield (); - lock id - end else begin - () - end - in - let unlock id = - channel.send_data (Unlock id); - in - let global = - { - OUnitShared. - lock = lock; - try_lock = try_lock; - unlock = unlock; - } - in - { - OUnitShared. - global = global; - process = OUnitShared.noscope_create (); - } - in - - let rec loop () = - match channel.receive_data () with - | Exit -> - channel.send_data AckExit - - | RunTest test_path -> - let test_path, _, test_fun = - MapPath.find test_path map_test_cases - in - let res = run_one_test conf logger shared test_path test_fun in - channel.send_data (TestDone res); - loop () - - | AckLock _ -> - loop () - in - loop () - - type 'a worker = - { - channel: (message_to_worker, message_from_worker) channel; - close_worker: unit -> string option; - select_fd: 'a; - shard_id: string; - is_running: unit -> bool; - } - - (* Run all tests. *) - let runner - create_worker workers_waiting - conf logger chooser test_cases = - let map_test_cases = - List.fold_left - (fun mp ((test_path, _, _) as test_case) -> - MapPath.add test_path test_case mp) - MapPath.empty - test_cases - in - - let state = OUnitState.create conf chooser test_cases in - - let shards = max (shards conf) 1 in - - let master_id = logger.OUnitLogger.lshard in - - let worker_idx = ref 1 in - - let test_per_worker, incr_tests_per_worker = - OUnitUtils.make_counter () - in - let health_check_per_worker, incr_health_check_per_worker = - OUnitUtils.make_counter () - in - - let () = infof logger "Using %d workers maximum." shards; in - - let worker_log_file = - if not (OUnitLoggerStd.is_output_file_shard_dependent conf) then begin - warningf logger - "-output-file doesn't include $(shard_id), \ - shards won't have file log."; - false - end else begin - true - end - in - - let master_shared = OUnitShared.noscope_create () in - - (* Act depending on the received message. *) - let process_message worker msg state = - match msg with - | AckExit -> - let msg_opt = - infof logger "Worker %s has ended." worker.shard_id; - worker.close_worker () - in - OUnitUtils.opt - (errorf logger "Worker return status: %s") - msg_opt; - remove_idle_worker worker state - - | Log log_ev -> - OUnitLogger.report (set_shard worker.shard_id logger) log_ev; - state - - | Lock id -> - worker.channel.send_data - (AckLock (master_shared.OUnitShared.try_lock id)); - state - - | Unlock id -> - master_shared.OUnitShared.unlock id; - state - - | TestDone test_result -> - OUnitState.test_finished conf test_result worker state - in - - (* Report a worker dead and unregister it. *) - let declare_dead_worker test_path worker result state = - let log_pos = position logger in - report logger (TestEvent (test_path, EResult result)); - report logger (TestEvent (test_path, EEnd)); - remove_idle_worker - worker - (test_finished conf - ((test_path, result, log_pos), []) - worker state) - in - - (* Kill the worker that has timed out. *) - let kill_timeout state = - List.fold_left - (fun state (test_path, test_length, worker) -> - let _msg : string option = - errorf logger "Worker %s, running test %s has timed out." - worker.shard_id (string_of_path test_path); - worker.close_worker () - in - declare_dead_worker test_path worker (RTimeout test_length) state) - state - (get_worker_timed_out state) - in - - (* Check that worker are healthy (i.e. still running). *) - let check_health state = - List.fold_left - (fun state (test_path, worker) -> - incr_health_check_per_worker worker.shard_id; - if worker.is_running () then begin - update_test_activity test_path state - end else begin - (* Argh, a test failed badly! *) - let result_msg = - errorf logger - "Worker %s, running test %s is not running anymore." - worker.shard_id (string_of_path test_path); - match worker.close_worker () with - | Some msg -> - Printf.sprintf "Worker stops running: %s" msg - | None -> - "Worker stops running for unknown reason." - in - declare_dead_worker test_path worker - (RError (result_msg, None)) - state - end) - state - (get_worker_need_health_check state) - in - - (* Main wait loop. *) - let rec wait_test_done state = - let state = (check_health (kill_timeout state)) in - if get_workers state <> [] then begin - let workers_waiting_lst = - infof logger "%d tests running: %s." - (count_tests_running state) - (String.concat ", " - (List.map string_of_path (get_tests_running state))); - workers_waiting (get_workers state) (timeout state) - in - List.fold_left - (fun state worker -> - process_message worker (worker.channel.receive_data ()) state) - state - workers_waiting_lst - - end else begin - state - end - in - - (* Wait for every worker to stop. *) - let rec wait_stopped state = - if OUnitState.get_workers state = [] then - state - else - wait_stopped (wait_test_done state) - in - - let rec iter state = - match OUnitState.next_test_case conf logger state with - | Not_enough_worker, state -> - if OUnitState.count_worker state < shards then begin - (* Start a worker. *) - let shard_id = OUnitUtils.shardf !worker_idx in - let () = infof logger "Starting worker number %s." shard_id in - let worker = - create_worker - conf map_test_cases shard_id master_id worker_log_file - in - let () = infof logger "Worker %s started." worker.shard_id in - let state = add_worker worker state in - incr worker_idx; - iter state - end else begin - iter (wait_test_done state) - end - - | Try_again, state -> - iter (wait_test_done state) - - | Next_test_case (test_path, _, worker), state -> - incr_tests_per_worker worker.shard_id; - worker.channel.send_data (RunTest test_path); - iter state - - | Finished, state -> - let count_tests_running = OUnitState.count_tests_running state in - if count_tests_running = 0 then begin - let state = - List.iter - (fun worker -> worker.channel.send_data Exit) - (OUnitState.get_workers state); - wait_stopped state - in - infof logger "Used %d worker during test execution." - (!worker_idx - 1); - List.iter - (fun (shard_id, count) -> - infof logger "Run %d tests with shard %s." - count shard_id) - (test_per_worker ()); - List.iter - (fun (shard_id, count) -> - infof logger "Check health of shard %s, %d times." - shard_id count) - (health_check_per_worker ()); - OUnitState.get_results state - end else begin - infof logger "Still %d tests running : %s." count_tests_running - (String.concat ", " - (List.map string_of_path - (get_tests_running state))); - iter (wait_test_done state) - end - in - iter state - -end diff -Nru ounit-2.0.8/src/oUnitRunnerProcesses.ml ounit-2.2.3/src/oUnitRunnerProcesses.ml --- ounit-2.0.8/src/oUnitRunnerProcesses.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitRunnerProcesses.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,253 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(** Use processes to run several tests in parallel. - * - * Run processes that handle running tests. The processes read test, execute - * it, and communicate back to the master the log. - * - * This need to be done in another process because ocaml Threads are not truly - * concurrent. Moreover we cannot use Unix.fork because it's not portable - *) - -open OUnitLogger -open OUnitTest -open OUnitState -open Unix -open OUnitRunner.GenericWorker - -(* Create functions to handle sending and receiving data over a file descriptor. - *) -let make_channel - shard_id - string_of_read_message - string_of_written_message - fd_read - fd_write = - let () = - set_nonblock fd_read; - set_close_on_exec fd_read; - set_close_on_exec fd_write - in - - let chn_write = out_channel_of_descr fd_write in - - let really_read fd str = - let off = ref 0 in - let read = ref 0 in - while !read < Bytes.length str do - try - let one_read = - Unix.read fd str !off (Bytes.length str - !off) - in - read := !read + one_read; - off := !off + one_read - with Unix_error(EAGAIN, _, _) -> - () - done; - str - in - - let header_str = Bytes.create Marshal.header_size in - - let send_data msg = - Marshal.to_channel chn_write msg []; - Pervasives.flush chn_write - in - - let receive_data () = - try - let data_size = Marshal.data_size (really_read fd_read header_str) 0 in - let data_str = really_read fd_read (Bytes.create data_size) in - let msg = - (* TODO: use Marshal.from_bytes when OCaml requirement is > 4.01. *) - Marshal.from_string - (Bytes.unsafe_to_string (Bytes.cat header_str data_str)) - 0 - in - msg - with Failure(msg) -> - OUnitUtils.failwithf "Communication error with worker processes: %s" msg - in - - let close () = - close_out chn_write; - in - wrap_channel - shard_id - string_of_read_message - string_of_written_message - { - send_data = send_data; - receive_data = receive_data; - close = close - } - -let processes_grace_period = - OUnitConf.make_float - "processes_grace_period" - 5.0 - "Delay to wait for a process to stop." - -let processes_kill_period = - OUnitConf.make_float - "processes_kill_period" - 5.0 - "Delay to wait for a process to stop after killing it." - -let create_worker conf map_test_cases shard_id master_id worker_log_file = - let safe_close fd = try close fd with Unix_error _ -> () in - let pipe_read_from_worker, pipe_write_to_master = Unix.pipe () in - let pipe_read_from_master, pipe_write_to_worker = Unix.pipe () in - match Unix.fork () with - | 0 -> - (* Child process. *) - let () = - safe_close pipe_read_from_worker; - safe_close pipe_write_to_worker; - (* stdin/stdout/stderr remain open and shared with master. *) - () - in - let channel = - make_channel - shard_id - string_of_message_to_worker - string_of_message_from_worker - pipe_read_from_master - pipe_write_to_master - in - main_worker_loop - conf ignore channel shard_id map_test_cases worker_log_file; - channel.close (); - safe_close pipe_read_from_master; - safe_close pipe_write_to_master; - exit 0 - - | pid -> - let channel = - make_channel - master_id - string_of_message_from_worker - string_of_message_to_worker - pipe_read_from_worker - pipe_write_to_worker - in - - let rstatus = ref None in - - let msg_of_process_status status = - if status = WEXITED 0 then - None - else - Some (OUnitUtils.string_of_process_status status) - in - - let is_running () = - match !rstatus with - | None -> - let pid, status = waitpid [WNOHANG] pid in - if pid <> 0 then begin - rstatus := Some status; - false - end else begin - true - end - | Some _ -> - false - in - - let close_worker () = - let rec wait_end timeout = - if timeout < 0.0 then begin - false, None - end else begin - let running = is_running () in - if running then - begin - begin - try ignore (Unix.select [] [] [] 0.1) - with Unix.Unix_error (Unix.EINTR, "select", "") -> () - end; - wait_end (timeout -. 0.1) - end - else - match !rstatus with - | Some status -> true, msg_of_process_status status - | None -> true, None - end - in - - let ended, msg_opt = - channel.close (); - safe_close pipe_read_from_worker; - safe_close pipe_write_to_worker; - (* Recovery for worker going wild and not dying. *) - List.fold_left - (fun (ended, msg_opt) signal -> - if ended then begin - ended, msg_opt - end else begin - kill pid signal; - wait_end (processes_kill_period conf) - end) - (wait_end (processes_grace_period conf)) - [15 (* SIGTERM *); 9 (* SIGKILL *)] - in - if ended then - msg_opt - else - Some (Printf.sprintf "unable to kill process %d" pid) - in - { - channel = channel; - close_worker = close_worker; - select_fd = pipe_read_from_worker; - shard_id = shard_id; - is_running = is_running; - } - -(* Filter running workers waiting data. *) -let workers_waiting workers timeout = - let workers_fd_lst = - List.rev_map (fun worker -> worker.select_fd) workers - in - let workers_fd_waiting_lst, _, _ = - Unix.select workers_fd_lst [] [] timeout - in - List.filter - (fun workers -> List.memq workers.select_fd workers_fd_waiting_lst) - workers - -let init () = - if Sys.os_type = "Unix" then - OUnitRunner.register "processes" 100 - (runner create_worker workers_waiting) diff -Nru ounit-2.0.8/src/oUnitRunnerThreads.ml ounit-2.2.3/src/oUnitRunnerThreads.ml --- ounit-2.0.8/src/oUnitRunnerThreads.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitRunnerThreads.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,222 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(** Use threads to run several tests concurrently. - * - * Run threads that handle running tests. It works the same way - * as processes. Due to the non-parallel threads behavior in OCaml, you cannot - * truly use the power of parallelism with threads, except when you have a lot - * of disk and process operation. - *) - -open OUnitRunner.GenericWorker - -let make_channel - shard_id - sync_send_data - (string_of_read_message: 'read -> string) - (string_of_written_message: 'written -> string) - (chan_read: 'read Event.channel) - (chan_write: 'written Event.channel) = - let chan_sync_send_data = Event.new_channel () in - let send_data msg = - if sync_send_data then - Event.sync (Event.send chan_sync_send_data shard_id); - Event.sync (Event.send chan_write msg) - in - - let receive_data msg = - Event.sync (Event.receive chan_read) - in - chan_sync_send_data, - wrap_channel - shard_id - string_of_read_message - string_of_written_message - { - send_data = send_data; - receive_data = receive_data; - close = ignore; - } - -let create_worker conf map_test_cases shard_id master_id worker_log_file = - (* Threads will get message from master by there. *) - let master_to_worker = Event.new_channel () in - (* Threads will send message to master by there. *) - let worker_to_master = Event.new_channel () in - (* Signal end of the worker. *) - let worker_finished = ref false in - let worker_finished_mutex = Mutex.create () in - let worker_finished_cond = Condition.create () in - - let select_fd, channel_worker = - make_channel - shard_id - true - string_of_message_to_worker - string_of_message_from_worker - master_to_worker - worker_to_master - in - - let thread_main_worker () = - let at_end () = - channel_worker.close (); - Mutex.lock worker_finished_mutex; - worker_finished := true; - Condition.broadcast worker_finished_cond; - Mutex.unlock worker_finished_mutex - in - try - main_worker_loop - conf Thread.yield channel_worker shard_id map_test_cases - worker_log_file; - at_end () - with e -> - at_end (); - raise e - in - - let thread = Thread.create thread_main_worker () in - - let _, channel_master = - make_channel - master_id - false - string_of_message_from_worker - string_of_message_to_worker - worker_to_master - master_to_worker - in - - let is_running () = - let res = - Mutex.lock worker_finished_mutex; - not !worker_finished - in - Mutex.unlock worker_finished_mutex; - res - in - - let close_worker () = - let killer () = - let total_wait = ref 0.0 in - let step = 0.1 in - Mutex.lock worker_finished_mutex; - while !total_wait < 5.0 && not !worker_finished do - Mutex.unlock worker_finished_mutex; - Thread.delay step; - total_wait := !total_wait +. step; - Mutex.lock worker_finished_mutex - done; - if not !worker_finished then begin - (* This will fail... because probably not implemented. *) - Thread.kill thread; - worker_finished := true; - Condition.broadcast worker_finished_cond - end; - Mutex.unlock worker_finished_mutex - in - let killer_thread = Thread.create killer () in - Mutex.lock worker_finished_mutex; - while not !worker_finished do - Condition.wait worker_finished_cond worker_finished_mutex - done; - Mutex.unlock worker_finished_mutex; - try - Thread.join killer_thread; - Thread.join thread; - None - with e -> - Some (Printf.sprintf - "Exception raised: %s." - (Printexc.to_string e)) - in - { - channel = channel_master; - close_worker = close_worker; - select_fd = select_fd; - shard_id = shard_id; - is_running = is_running; - } - - -let workers_waiting workers timeout = - let channel_timeout = Event.new_channel () in -(* TODO: clean implementation of the timeout. - * Timeout not implemented, because it should be killed in most cases and - * actually Thread.kill is not implemented for systhreads. - * We could do either of this: - * - Thread.time_read + mkpipe - * - use signal ALARM - * - * Patch welcome. - * - * Sylvain Le Gall -- 2013/09/18. - let thread_timeout = - Thread.create - (fun () -> - Thread.delay timeout; - Event.sync (Event.send channel_timeout None)) - () - in - *) - let worker_id_ready = - Event.select - (Event.receive channel_timeout - :: - (List.rev_map - (fun worker -> - Event.wrap - (Event.receive worker.select_fd) - (fun s -> Some s)) - workers)) - in - match worker_id_ready with - | None -> -(* Thread.join thread_timeout; *) - [] - | Some worker_id -> -(* Thread.kill thread_timeout; *) - try - let worker = - List.find - (fun worker -> - worker.shard_id = worker_id) - workers - in - [worker] - with Not_found -> - assert false - -let init () = - OUnitRunner.register "threads" 70 (runner create_worker workers_waiting) diff -Nru ounit-2.0.8/src/oUnitShared.ml ounit-2.2.3/src/oUnitShared.ml --- ounit-2.0.8/src/oUnitShared.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitShared.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,159 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -exception Lock_failure - -type scope = ScopeGlobal | ScopeProcess - -type 'a shared_noscope = - { - lock: 'a -> unit; - unlock: 'a -> unit; - try_lock: 'a -> bool; - } - -type shared = - { - global: int shared_noscope; - process: int shared_noscope; - } - -let get_scoped shared = - function - | ScopeGlobal -> shared.global - | ScopeProcess -> shared.process - - -(* Global variable that need to be set for threads. *) -let mutex_create = - ref (fun () -> - let r = ref false in - - let try_lock () = - if !r then begin - false - end else begin - r := true; - true - end - in - - let lock () = - if not (try_lock ()) then - raise Lock_failure - in - - let unlock () = - r := false - in - - { - lock = lock; - try_lock = try_lock; - unlock = unlock; - }) - -module Mutex = -struct - - type t = int * scope - - let create scope = - (Oo.id (object end), scope) - - let lock shared (id, scope) = - (get_scoped shared scope).lock id - - let try_lock shared (id, scope) = - (get_scoped shared scope).try_lock id - - let unlock shared (id, scope) = - (get_scoped shared scope).unlock id - - let with_lock shared mutex f = - try - let res = - lock shared mutex; - f () - in - unlock shared mutex; - res - with e -> - unlock shared mutex; - raise e - - -end - -(* A simple shared_noscope that works only for 1 process. *) -let noscope_create () = - let state = Hashtbl.create 13 in - let state_mutex = !mutex_create () in - - let get_mutex id = - let mutex = - state_mutex.lock (); - try - Hashtbl.find state id - with Not_found -> - let mutex = !mutex_create () in - Hashtbl.add state id mutex; - mutex - in - state_mutex.unlock (); - mutex - in - - let try_lock id = - (get_mutex id).try_lock () - in - - let lock id = - (get_mutex id).lock () - in - - let unlock id = - (get_mutex id).unlock () - in - { - lock = lock; - unlock = unlock; - try_lock = try_lock; - } - -(* Create a shared, for 1 process. *) -let create () = - let scoped = noscope_create () in - { - global = scoped; - process = scoped; - } diff -Nru ounit-2.0.8/src/oUnitState.ml ounit-2.2.3/src/oUnitState.ml --- ounit-2.0.8/src/oUnitState.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitState.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,282 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(** Manipulate the state of OUnit runner. - *) - -open OUnitLogger -open OUnitTest -open OUnitChooser - -type 'worker next_test_case_t = - | Not_enough_worker - | Try_again - | Next_test_case of path * test_fun * 'worker - | Finished - -type time = float - -type 'worker test_running = - { - test_length: test_length; - deadline: time; - next_health_check: time; - worker: 'worker; - } - -type 'worker t = - { - tests_planned: (path * (test_length * test_fun)) list; - tests_running: (path * ('worker test_running)) list; - tests_passed: (OUnitTest.result_full * OUnitTest.result_list) list; - idle_workers: 'worker list; - chooser: OUnitChooser.chooser; - cache: OUnitCache.cache; - health_check_interval: time; - } - -let health_check_interval = - OUnitConf.make_float - "health_check_interval" - 1.0 - "Seconds between checking health of workers." - -let create conf chooser test_cases = - { - tests_passed = []; - tests_planned = List.map - (fun (test_path, test_length, test_fun) -> - test_path, (test_length, test_fun)) - test_cases; - tests_running = []; - idle_workers = []; - chooser = chooser; - cache = OUnitCache.load conf; - health_check_interval = health_check_interval conf; - } - -let filter_out e lst = List.filter (fun (e', _) -> e <> e') lst - -let maybe_dump_cache conf state = - if state.tests_running = [] && state.tests_planned = [] then - (* We are finished, all results are in, flush the cache. *) - OUnitCache.dump conf - (List.fold_left - (fun cache (path, test_result, _) -> - OUnitCache.add_result path test_result cache) - state.cache - (List.map fst state.tests_passed)); - state - -let add_test_results conf all_test_results state = - let ((test_path, _, _), _) = all_test_results in - let state = - {state with - tests_passed = all_test_results :: state.tests_passed; - tests_planned = filter_out test_path state.tests_planned}; - in - maybe_dump_cache conf state - -let test_finished conf all_test_results worker state = - let ((test_path, _, _), _) = all_test_results in - let state = - {(add_test_results conf all_test_results state) with - tests_running = filter_out test_path state.tests_running; - idle_workers = worker :: state.idle_workers} - in - maybe_dump_cache conf state - -let add_worker worker state = - {state with idle_workers = worker :: state.idle_workers} - -let remove_idle_worker worker state = - let found, idle_workers = - List.fold_left - (fun (found, lst) worker' -> - if worker' == worker then - true, lst - else - found, worker' :: lst) - (false, []) - state.idle_workers - in - if not found then - raise Not_found; - {state with idle_workers = idle_workers} - -let count_worker state = - List.length state.idle_workers + List.length state.tests_running - -let count_tests_running state = - List.length state.tests_running - -let get_workers state = - List.rev_append state.idle_workers - (List.rev_map (fun (_, {worker = worker}) -> worker) state.tests_running) - -let get_idle_workers state = - state.idle_workers - -let is_idle_worker worker state = - List.exists (fun worker' -> worker == worker') state.idle_workers - -let get_tests_running state = - List.map fst state.tests_running - -let rec next_test_case conf logger state = - match state.tests_planned, state.idle_workers with - | [], _ -> - Finished, state - | _, worker :: tl_workers -> - begin - let choice = - state.chooser - { - OUnitChooser. - tests_planned = List.map fst state.tests_planned; - tests_running = List.map fst state.tests_running; - tests_passed = List.map fst state.tests_passed; - cache = state.cache; - } - in - match choice with - | Choose test_path -> - begin - try - let test_length, test_fun = - List.assoc test_path state.tests_planned - in - let now = OUnitUtils.now () in - Next_test_case (test_path, test_fun, worker), - {state with - tests_running = - (test_path, - { - test_length = test_length; - deadline = now +. delay_of_length test_length; - next_health_check = - now +. state.health_check_interval; - worker = worker; - }) :: state.tests_running; - tests_planned = - filter_out test_path state.tests_planned; - idle_workers = - tl_workers} - with Not_found -> - assert false - end - - | ChooseToPostpone -> - Try_again, state - - | ChooseToSkip path -> - let skipped_result = RSkip "Skipped by the chooser." in - OUnitLogger.report logger (TestEvent (path, EStart)); - OUnitLogger.report - logger (TestEvent (path, EResult skipped_result)); - OUnitLogger.report logger (TestEvent (path, EEnd)); - next_test_case - conf logger - (add_test_results conf - ((path, skipped_result, None), []) state) - - | NoChoice -> - Finished, state - - end - | _, [] -> - Not_enough_worker, state - -(** Get all the results. *) -let get_results state = - List.fold_right - (fun (result, other_results) res -> - result :: other_results @ res) - state.tests_passed [] - -(** Get all the workers that need to be checked for their health. *) -let get_worker_need_health_check state = - let now = OUnitUtils.now () in - List.fold_left - (fun lst (test_path, test_running) -> - if test_running.next_health_check <= now then - (test_path, test_running.worker) :: lst - else - lst) - [] - state.tests_running - -(** Update the activity of a worker, this postpone the next health check. *) -let update_test_activity test_path state = - let now = OUnitUtils.now () in - let tests_running = - List.fold_right - (fun (test_path', test_running) lst -> - let test_running = - if test_path' = test_path then - {test_running with - next_health_check = now +. state.health_check_interval} - else - test_running - in - (test_path', test_running) :: lst) - state.tests_running - [] - in - {state with tests_running = tests_running} - -(** Get all the workers that are timed out, i.e. that need to be stopped. *) -let get_worker_timed_out state = - let now = OUnitUtils.now () in - List.fold_left - (fun lst (test_path, test_running) -> - if test_running.deadline <= now then - (test_path, test_running.test_length, test_running.worker) :: lst - else - lst) - [] - state.tests_running - -(** Compute when is the next time, we should either run health check or timeout - a test. - *) -let timeout state = - let now = OUnitUtils.now () in - let next_event_time = - List.fold_left - (fun next_event_time (_, test_running) -> - min test_running.next_health_check - (min test_running.deadline next_event_time)) - (now +. state.health_check_interval) - state.tests_running - in - max 0.1 (next_event_time -. now) diff -Nru ounit-2.0.8/src/oUnitTestData.ml ounit-2.2.3/src/oUnitTestData.ml --- ounit-2.0.8/src/oUnitTestData.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitTestData.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,64 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -let make_filename = List.fold_left Filename.concat - -let testdata_default = - let pwd = Sys.getcwd () in - let is_dir lst = - let dn = make_filename pwd lst in - Sys.file_exists dn && Sys.is_directory dn - in - try - let path = - List.find is_dir - [ - ["test"; "data"]; - ["tests"; "data"]; - ["data"] - ] - in - Some (make_filename pwd path) - with Not_found -> - None - -let testdata_dir = - OUnitConf.make_string_opt - "testdata_dir" - testdata_default - "Location of the test data directory (absolute path)." - -let in_testdata_dir conf path = - match testdata_dir conf with - | Some fn -> make_filename fn path - | None -> - failwith "Test data dir not defined." diff -Nru ounit-2.0.8/src/oUnitTest.ml ounit-2.2.3/src/oUnitTest.ml --- ounit-2.0.8/src/oUnitTest.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitTest.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,411 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -open OUnitUtils - -exception Skip of string -exception Todo of string -exception OUnit_failure of string - -(** See OUnit.mli. *) -type node = ListItem of int | Label of string - -(** See OUnit.mli. *) -type path = node list - -(** See OUnit2.mli. *) -type backtrace = string option - -(* The type of length of a test. *) -type test_length = - | Immediate (* < 1s *) - | Short (* < 1min *) - | Long (* < 10min *) - | Huge (* < 30min *) - | Custom_length of float - -(** See OUnit.mli. *) -type result = - | RSuccess - | RFailure of string * OUnitLogger.position option * backtrace - | RError of string * backtrace - | RSkip of string - | RTodo of string - | RTimeout of test_length - -(* See OUnit.mli. *) -type result_full = (path * result * OUnitLogger.position option) - -type result_list = result_full list - -type ctxt = - (* TODO: hide this to avoid building a context outside. *) - { - conf: OUnitConf.conf; - logger: (path, result) OUnitLogger.logger; - shared: OUnitShared.shared; - path: path; - test_logger: result OUnitLogger.Test.t; - (* TODO: Still a race condition possible, what if another threads - * modify anything during the process (e.g. register tear down). - *) - mutable tear_down: (ctxt -> unit) list; - tear_down_mutex: OUnitShared.Mutex.t; - non_fatal: result_full list ref; - non_fatal_mutex: OUnitShared.Mutex.t; - } - -type log_event_t = (path, result) OUnitLogger.log_event_t -type logger = (path, result) OUnitLogger.logger - -type test_fun = ctxt -> unit - -(* The type of tests. *) -type test = - | TestCase of test_length * test_fun - | TestList of test list - | TestLabel of string * test - -let delay_of_length = - function - | Immediate -> 1.0 - | Short -> 60.0 - | Long -> 600.0 - | Huge -> 1800.0 - | Custom_length f -> f - -let get_shard_id test_ctxt = - test_ctxt.logger.OUnitLogger.lshard - -(** Isolate a function inside a context. All the added tear down will run before - returning. - *) -let section_ctxt ctxt f = - let old_tear_down = - OUnitShared.Mutex.with_lock - ctxt.shared ctxt.tear_down_mutex - (fun () -> ctxt.tear_down) - in - let clean_exit () = - OUnitShared.Mutex.with_lock - ctxt.shared ctxt.tear_down_mutex - (fun () -> - List.iter (fun tear_down -> tear_down ctxt) ctxt.tear_down; - ctxt.tear_down <- old_tear_down) - in - OUnitShared.Mutex.with_lock - ctxt.shared ctxt.tear_down_mutex - (fun () -> ctxt.tear_down <- []); - try - let res = f ctxt in - clean_exit (); - res - with e -> - clean_exit (); - raise e - -(** Create a context and run the function. *) -let with_ctxt conf logger shared non_fatal test_path f = - let ctxt = - { - conf = conf; - logger = logger; - path = test_path; - shared = shared; - test_logger = OUnitLogger.Test.create logger test_path; - tear_down = []; - tear_down_mutex = OUnitShared.Mutex.create OUnitShared.ScopeProcess; - non_fatal = non_fatal; - non_fatal_mutex = OUnitShared.Mutex.create OUnitShared.ScopeProcess; - } - in - section_ctxt ctxt f - -let standard_modules = - [ - "arg.ml"; - "arrayLabels.ml"; - "array.ml"; - "buffer.ml"; - "callback.ml"; - "camlinternalLazy.ml"; - "camlinternalMod.ml"; - "camlinternalOO.ml"; - "char.ml"; - "complex.ml"; - "digest.ml"; - "filename.ml"; - "format.ml"; - "gc.ml"; - "genlex.ml"; - "hashtbl.ml"; - "int32.ml"; - "int64.ml"; - "lazy.ml"; - "lexing.ml"; - "listLabels.ml"; - "list.ml"; - "map.ml"; - "marshal.ml"; - "moreLabels.ml"; - "nativeint.ml"; - "obj.ml"; - "oo.ml"; - "parsing.ml"; - "pervasives.ml"; - "printexc.ml"; - "printf.ml"; - "queue.ml"; - "random.ml"; - "scanf.ml"; - "set.ml"; - "sort.ml"; - "stack.ml"; - "std_exit.ml"; - "stdLabels.ml"; - "stream.ml"; - "stringLabels.ml"; - "string.ml"; - "sys.ml"; - "weak.ml"; - "unix.ml"; - ] - -(** Transform an exception in a result. *) -let result_full_of_exception ctxt e = - let backtrace () = - if Printexc.backtrace_status () then - Some (Printexc.get_backtrace ()) - else - None - in - let locate_exn () = - if Printexc.backtrace_status () then - begin - let lst = - extract_backtrace_position (Printexc.get_backtrace ()) - in - let pos_opt = - try - List.find - (function - | None -> false - | Some (fn, _) -> - not (starts_with ~prefix:"oUnit" (Filename.basename fn)) && - not (List.mem fn standard_modules)) - lst - with Not_found -> - None - in - match pos_opt with - | Some (filename, line) -> - Some {OUnitLogger.filename = filename; line = line} - | None -> - None - end - else - None - in - let result = - match e with - | OUnit_failure s -> RFailure (s, locate_exn (), backtrace ()) - | Skip s -> RSkip s - | Todo s -> RTodo s - | s -> RError (Printexc.to_string s, backtrace ()) - in - let position = - match result with - | RSuccess | RSkip _ | RTodo _ | RTimeout _ -> - None - | RFailure _ | RError _ -> - OUnitLogger.position ctxt.logger - in - ctxt.path, result, position - -let report_result_full ctxt result_full = - let test_path, result, _ = result_full in - OUnitLogger.report ctxt.logger - (OUnitLogger.TestEvent (test_path, OUnitLogger.EResult result)); - result_full - -(** Isolate a function inside a context, just as [!section_ctxt] but don't - propagate a failure, register it for later. - *) -let non_fatal ctxt f = - try - section_ctxt ctxt f - with e -> - let result_full = - report_result_full ctxt (result_full_of_exception ctxt e) - in - OUnitShared.Mutex.with_lock - ctxt.shared ctxt.non_fatal_mutex - (fun () -> - ctxt.non_fatal := result_full :: !(ctxt.non_fatal)) - -(* Some shorthands which allows easy test construction *) -let (>:) s t = TestLabel(s, t) (* infix *) -let (>::) s f = TestLabel(s, TestCase(Short, f)) (* infix *) -let (>:::) s l = TestLabel(s, TestList(l)) (* infix *) - -(* Utility function to manipulate test *) -let rec test_decorate g = - function - | TestCase(l, f) -> - TestCase (l, g f) - | TestList tst_lst -> - TestList (List.map (test_decorate g) tst_lst) - | TestLabel (str, tst) -> - TestLabel (str, test_decorate g tst) - -(* Return the number of available tests *) -let rec test_case_count = - function - | TestCase _ -> 1 - | TestLabel (_, t) -> test_case_count t - | TestList l -> - List.fold_left - (fun c t -> c + test_case_count t) - 0 l - -let string_of_node = - function - | ListItem n -> - string_of_int n - | Label s -> - s - -module Path = -struct - type t = path - - let compare p1 p2 = - Pervasives.compare p1 p2 - - let to_string p = - String.concat ":" (List.rev_map string_of_node p) -end - -module MapPath = Map.Make(Path) - -let string_of_path = - Path.to_string - -(* Returns all possible paths in the test. The order is from test case - to root. - *) -let test_case_paths test = - let rec tcps path test = - match test with - | TestCase _ -> - [path] - - | TestList tests -> - List.concat - (mapi (fun t i -> tcps ((ListItem i)::path) t) tests) - - | TestLabel (l, t) -> - tcps ((Label l)::path) t - in - tcps [] test - -(* Test filtering with their path *) -module SetTestPath = Set.Make(String) - -let test_filter ?(skip=false) only test = - let set_test = - List.fold_left - (fun st str -> SetTestPath.add str st) - SetTestPath.empty - only - in - let rec filter_test path tst = - if SetTestPath.mem (string_of_path path) set_test then - begin - Some tst - end - - else - begin - match tst with - | TestCase (l, f) -> - begin - if skip then - Some - (TestCase - (l, fun ctxt -> - raise (Skip "Test disabled"))) - else - None - end - - | TestList tst_lst -> - begin - let ntst_lst = - fold_lefti - (fun ntst_lst tst i -> - let nntst_lst = - match filter_test ((ListItem i) :: path) tst with - | Some tst -> - tst :: ntst_lst - | None -> - ntst_lst - in - nntst_lst) - [] - tst_lst - in - if not skip && ntst_lst = [] then - None - else - Some (TestList (List.rev ntst_lst)) - end - - | TestLabel (lbl, tst) -> - begin - let ntst_opt = - filter_test - ((Label lbl) :: path) - tst - in - match ntst_opt with - | Some ntst -> - Some (TestLabel (lbl, ntst)) - | None -> - if skip then - Some (TestLabel (lbl, tst)) - else - None - end - end - in - filter_test [] test diff -Nru ounit-2.0.8/src/oUnitThreads.ml ounit-2.2.3/src/oUnitThreads.ml --- ounit-2.0.8/src/oUnitThreads.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitThreads.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - - -let init () = - OUnitShared.mutex_create := - (fun () -> - let mutex = Mutex.create () in - { - OUnitShared. - lock = (fun () -> Mutex.lock mutex); - try_lock = (fun () -> Mutex.try_lock mutex); - unlock = (fun () -> Mutex.unlock mutex); - }); - OUnitRunnerThreads.init () diff -Nru ounit-2.0.8/src/oUnitThreads.mldylib ounit-2.2.3/src/oUnitThreads.mldylib --- ounit-2.0.8/src/oUnitThreads.mldylib 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/src/oUnitThreads.mldylib 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: c233265d9f83eaa73923c9bdefb32777) -OUnitThreads -OUnitRunnerThreads -# OASIS_STOP diff -Nru ounit-2.0.8/src/oUnitThreads.mllib ounit-2.2.3/src/oUnitThreads.mllib --- ounit-2.0.8/src/oUnitThreads.mllib 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/src/oUnitThreads.mllib 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: c233265d9f83eaa73923c9bdefb32777) -OUnitThreads -OUnitRunnerThreads -# OASIS_STOP diff -Nru ounit-2.0.8/src/oUnitUtils.ml ounit-2.2.3/src/oUnitUtils.ml --- ounit-2.0.8/src/oUnitUtils.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/src/oUnitUtils.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,251 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(** - * Utilities for OUnit - * - * @author Sylvain Le Gall - *) - -let is_blank = - function - | ' ' | '\012' | '\n' | '\r' | '\t' -> true - | _ -> false - -let rec trim s = - let strlen = String.length s in - if strlen = 0 then - "" - else if is_blank s.[0] then - trim (String.sub s 1 (strlen - 1)) - else if is_blank s.[strlen - 1] then - trim (String.sub s 0 (strlen - 1)) - else - s - -let trim_comment s = - let buff = Buffer.create (String.length s) in - let idx = ref 0 in - while !idx < String.length s && s.[!idx] != '#' do - Buffer.add_char buff s.[!idx]; - incr idx - done; - Buffer.contents buff - -let split_lines s = - let rev_lst = ref [] in - let buff = Buffer.create 13 in - let flush () = - rev_lst := Buffer.contents buff :: !rev_lst; - Buffer.clear buff - in - if String.length s > 0 then - begin - String.iter - (function - | '\n' -> flush () - | c -> Buffer.add_char buff c) - s; - flush (); - List.rev !rev_lst - end - else - [] - -let starts_with ~prefix s = - if String.length s >= String.length prefix then - String.sub s 0 (String.length prefix) = prefix - else - false - -let start_substr ~prefix s = - if starts_with ~prefix s then begin - let prefix_len = String.length prefix in - true, String.sub s prefix_len (String.length s - prefix_len) - end else begin - false, s - end - -let extract_backtrace_position str = - let prefixes = - [ - "Raised at "; - "Re-raised at "; - "Raised by primitive operation at "; - "Called from "; - ] - in - - let rec extract_one_line s prefixes = - match prefixes with - | [] -> None - | prefix :: tl -> - let really_starts, eol = start_substr ~prefix s in - if really_starts then begin - if eol = "unknown location" then - None - else - try - Scanf.sscanf eol "file \"%s@\", line %d, characters %d-%d" - (fun fn line _ _ -> Some (fn, line)) - with Scanf.Scan_failure msg -> - None - end else begin - extract_one_line s tl - end - in - List.map - (fun s -> extract_one_line s prefixes) - (split_lines str) - -let cmp_float ?(epsilon = 0.00001) a b = - match classify_float a, classify_float b with - | FP_infinite, FP_infinite -> a = b - | FP_infinite, _ | _, FP_infinite | FP_nan, _ | _, FP_nan -> false - | _, _ -> - abs_float (a -. b) <= epsilon *. (abs_float a) || - abs_float (a -. b) <= epsilon *. (abs_float b) - -let buff_format_printf f = - let buff = Buffer.create 13 in - let fmt = Format.formatter_of_buffer buff in - f fmt; - Format.pp_print_flush fmt (); - Buffer.contents buff - -(* Applies function f in turn to each element in list. Function f takes - one element, and integer indicating its location in the list *) -let mapi f l = - let rec rmapi cnt l = - match l with - | [] -> - [] - - | h :: t -> - (f h cnt) :: (rmapi (cnt + 1) t) - in - rmapi 0 l - -let fold_lefti f accu l = - let rec rfold_lefti cnt accup l = - match l with - | [] -> - accup - - | h::t -> - rfold_lefti (cnt + 1) (f accup h cnt) t - in - rfold_lefti 0 accu l - -let now () = - Unix.gettimeofday () - -(* Function which runs the given function and returns the running time - of the function, and the original result in a tuple *) -let time_fun f x = - let begin_time = now () in - let res = f x in - (now () -. begin_time, res) - -let date_iso8601 ?(tz=true) timestamp = - let tm = Unix.gmtime timestamp in - let res = - Printf.sprintf - "%04d-%02d-%02dT%02d:%02d:%02d" - (1900 + tm.Unix.tm_year) - (1 + tm.Unix.tm_mon) - tm.Unix.tm_mday - tm.Unix.tm_hour - tm.Unix.tm_min - tm.Unix.tm_sec - in - if tz then - res ^ "+00:00" - else - res - -let buildir = - (* Detect a location where we can store semi-temporary data: - - it must survive a compilation - - it must be removed with 'make clean' - *) - let pwd = Sys.getcwd () in - let dir_exists fn = Sys.file_exists fn && Sys.is_directory fn in - let concat, dirname = Filename.concat, Filename.dirname in - List.find - dir_exists - [ - concat pwd "_build"; - concat (dirname pwd) "_build"; - concat (dirname (dirname pwd)) "_build"; - pwd - ] - -let failwithf fmt = - Printf.ksprintf failwith fmt - -let opt f = function Some v -> f v | None -> () - -let fqdn () = - try - (Unix.gethostbyname (Unix.gethostname ())).Unix.h_name - with - Not_found -> "localhost" - -let shardf = Printf.sprintf "%s#%02d" (Unix.gethostname ()) - -let string_of_process_status = - function - | Unix.WEXITED n -> - Printf.sprintf "Exited with code %d" n - | Unix.WSIGNALED n -> - Printf.sprintf "Killed by signal %d" n - | Unix.WSTOPPED n -> - Printf.sprintf "Stopped by signal %d" n - -let make_counter () = - let data = Hashtbl.create 13 in - let all () = - Hashtbl.fold - (fun k v lst -> (k, v) :: lst) - data [] - in - let incr k = - let v = - try - Hashtbl.find data k - with Not_found -> - 0 - in - Hashtbl.replace data k (v + 1) - in - all, incr diff -Nru ounit-2.0.8/src/tools/data_gen/data_gen.ml ounit-2.2.3/src/tools/data_gen/data_gen.ml --- ounit-2.0.8/src/tools/data_gen/data_gen.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/tools/data_gen/data_gen.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,19 @@ +let file_to_string f = + let chan = open_in f in + let len = in_channel_length chan in + let res = Bytes.create len in + really_input chan res 0 len; + close_in chan; + Bytes.to_string res + +let _ = + + let css = file_to_string "oUnit.css" in + let js = file_to_string "oUnit.js" in + let chan = open_out "oUnitLoggerHTMLData.ml" in + Printf.fprintf chan + "let oUnit_css = %S;; + let oUnit_js = %S;;" + css js; + + close_out chan diff -Nru ounit-2.0.8/src/tools/data_gen/dune ounit-2.2.3/src/tools/data_gen/dune --- ounit-2.0.8/src/tools/data_gen/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/src/tools/data_gen/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,2 @@ +(executable + (name data_gen)) diff -Nru ounit-2.0.8/_tags ounit-2.2.3/_tags --- ounit-2.0.8/_tags 2018-04-04 06:34:53.000000000 +0000 +++ ounit-2.2.3/_tags 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: cc011bcaa29d48629c61b20c304ab288) -# Ignore VCS directories, you can use the same kind of rule outside -# OASIS_START/STOP if you want to exclude directories that contains -# useless stuff for the build process -true: annot, bin_annot -<**/.svn>: -traverse -<**/.svn>: not_hygienic -".bzr": -traverse -".bzr": not_hygienic -".hg": -traverse -".hg": not_hygienic -".git": -traverse -".git": not_hygienic -"_darcs": -traverse -"_darcs": not_hygienic -# Library oUnitAdvanced -"src/oUnitAdvanced.cmxs": use_oUnitAdvanced -# Library oUnit -"src/oUnit.cmxs": use_oUnit -# Library oUnitThreads -"src/oUnitThreads.cmxs": use_oUnitThreads -: pkg_bytes -: pkg_threads -: pkg_unix -: use_oUnit -: use_oUnitAdvanced -# Executable testFakeHTML -"test/testFakeHTML.byte": pkg_bytes -"test/testFakeHTML.byte": pkg_unix -"test/testFakeHTML.byte": use_oUnit -"test/testFakeHTML.byte": use_oUnitAdvanced -# Executable testFakeRunner -"test/testFakeRunner.byte": pkg_bytes -"test/testFakeRunner.byte": pkg_threads -"test/testFakeRunner.byte": pkg_unix -"test/testFakeRunner.byte": use_oUnit -"test/testFakeRunner.byte": use_oUnitAdvanced -"test/testFakeRunner.byte": use_oUnitThreads -# Executable testFakeShared -"test/testFakeShared.byte": pkg_bytes -"test/testFakeShared.byte": pkg_threads -"test/testFakeShared.byte": pkg_unix -"test/testFakeShared.byte": use_oUnit -"test/testFakeShared.byte": use_oUnitAdvanced -"test/testFakeShared.byte": use_oUnitThreads -: pkg_threads -: use_oUnitThreads -# Executable test -"test/test.byte": pkg_bytes -"test/test.byte": pkg_str -"test/test.byte": pkg_unix -"test/test.byte": use_oUnit -"test/test.byte": use_oUnitAdvanced -: pkg_bytes -: pkg_str -: pkg_unix -: use_oUnit -: use_oUnitAdvanced -# OASIS_STOP -"src/oUnit.odoc": oasis_document_api_ounit -"src/oUnit.ml": oasis_document_api_ounit -"src/api-ounit.docdir": oasis_document_api_ounit diff -Nru ounit-2.0.8/test/common/dune ounit-2.2.3/test/common/dune --- ounit-2.0.8/test/common/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/common/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,6 @@ +(library + (name testcommon) + (modules testCommonRunner segfault) + (c_names segfault) + (wrapped false) + (libraries ounit2 ounit2.advanced)) diff -Nru ounit-2.0.8/test/common/segfault.c ounit-2.2.3/test/common/segfault.c --- ounit-2.0.8/test/common/segfault.c 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/common/segfault.c 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,10 @@ +#include +#include + +value caml_cause_segfault(value unit) +{ + CAMLparam1 (unit); + int *ptr = NULL; + *ptr = 1; + CAMLreturn (Val_unit); +} diff -Nru ounit-2.0.8/test/common/segfault.ml ounit-2.2.3/test/common/segfault.ml --- ounit-2.0.8/test/common/segfault.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/common/segfault.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1 @@ +external cause_segfault: unit -> unit = "caml_cause_segfault" diff -Nru ounit-2.0.8/test/common/testCommonRunner.ml ounit-2.2.3/test/common/testCommonRunner.ml --- ounit-2.0.8/test/common/testCommonRunner.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/common/testCommonRunner.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,53 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +open OUnit2 + +let run_fake_external_prog + ~ctxt ?(runner="sequential") ?exit_code prog args fn = + let env = + Array.of_list + (Array.fold_left + (fun lst e -> + let prefix = "OUNIT_" in + if String.length e >= String.length prefix then begin + let start = String.sub e 0 (String.length prefix) in + if start = prefix then + lst + else + e :: lst + end else + e :: lst) + [] (Unix.environment ())) + in + assert_command ~ctxt ?exit_code ~env + prog ("-output-file" :: fn :: "-runner" :: runner :: args) diff -Nru ounit-2.0.8/test/dune ounit-2.2.3/test/dune --- ounit-2.0.8/test/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,14 @@ +(test + (name test) + (libraries ounit2 ounit2.advanced str testcommon) + (package ounit2) + (deps + test.exe + (:fakeHTML fakeHTML/fakeHTML.exe) + (:fakeRunner fakeRunner/fakeRunner.exe) + (:fakeShared fakeShared/fakeShared.exe) + (:fakeBadFinaliser fakeBadFinaliser/fakeBadFinaliser.exe) + JUnit.xsd) + (action + (run %{test} -fakeHTML %{fakeHTML} -fakeRunner %{fakeRunner} + -fakeShared %{fakeShared} -fakeBadFinaliser %{fakeBadFinaliser}))) diff -Nru ounit-2.0.8/test/fakeBadFinaliser/dune ounit-2.2.3/test/fakeBadFinaliser/dune --- ounit-2.0.8/test/fakeBadFinaliser/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/fakeBadFinaliser/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,3 @@ +(executable + (name fakeBadFinaliser) + (libraries ounit2 testcommon)) diff -Nru ounit-2.0.8/test/fakeBadFinaliser/fakeBadFinaliser.ml ounit-2.2.3/test/fakeBadFinaliser/fakeBadFinaliser.ml --- ounit-2.0.8/test/fakeBadFinaliser/fakeBadFinaliser.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/fakeBadFinaliser/fakeBadFinaliser.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,61 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + + +(* + * Fake test, to test finalisation misbehaving. + *) + +open OUnit2 + + +let finaliser_token = + OUnit2.Conf.make_string "finaliser_token" "abcdef" + "Token to identify to check in the logs the the finaliser has run." + + +let finalise_with_error token _ = + print_endline token; + Segfault.cause_segfault () + + +let suite = + "OUnitFakeBadFinaliser" >::: + [ + "test where the finaliser should fail" >:: + (fun test_ctxt -> + let fake_value = String.make 8 'X' in + Gc.finalise (finalise_with_error (finaliser_token test_ctxt)) fake_value; + assert_equal fake_value "XXXXXXXX"); + ] + +let () = run_test_tt_main suite diff -Nru ounit-2.0.8/test/fakeHTML/dune ounit-2.2.3/test/fakeHTML/dune --- ounit-2.0.8/test/fakeHTML/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/fakeHTML/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,3 @@ +(executable + (name fakeHTML) + (libraries ounit2)) diff -Nru ounit-2.0.8/test/fakeHTML/fakeHTML.ml ounit-2.2.3/test/fakeHTML/fakeHTML.ml --- ounit-2.0.8/test/fakeHTML/fakeHTML.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/fakeHTML/fakeHTML.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,68 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + + +(* + * Fake tests, to test HTML output. + *) + +open OUnit2 + +let suite = + "OUnitLoggerHTML" >::: + [ + "first test" >:: + (fun _ -> + assert_equal 0 1); + + "second test" >:: + (fun _ -> + assert_equal 0 0); + + "third test" >:: + (fun _ -> + skip_if true "skipped because of me"); + + "fourth test" >:: + (fun _ -> + todo "need to make this function"); + + "fifth test" >:: + (fun _ -> + raise Not_found); + + "with symbol" >:: + (fun _ -> + failwith "this is a bad message: '\"&<>") + ] + +let () = run_test_tt_main suite diff -Nru ounit-2.0.8/test/fakeRunner/dune ounit-2.2.3/test/fakeRunner/dune --- ounit-2.0.8/test/fakeRunner/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/fakeRunner/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,3 @@ +(executable + (name fakeRunner) + (libraries ounit2 ounit2.threads testcommon)) diff -Nru ounit-2.0.8/test/fakeRunner/fakeRunner.ml ounit-2.2.3/test/fakeRunner/fakeRunner.ml --- ounit-2.0.8/test/fakeRunner/fakeRunner.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/fakeRunner/fakeRunner.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,85 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(* + * Fake tests, to test runner behavior in some situation. + *) + +open OUnit2 + +let sigsegv = + Conf.make_bool + "sigsegv" + false + "Fail with SIGSEGV." + +let timeout = + Conf.make_bool + "timeout" + false + "Time out." + +let suite = + "TestFakeRunner" >::: + [ + "success" >:: + (fun _ -> assert_equal 0 0); + + "failure" >:: + (fun _ -> assert_equal 0 1); + + "skip" >:: + (fun _ -> skip_if true "skipped because of me"); + + "todo" >:: + (fun _ -> todo "need to make this function"); + + "error" >:: + (fun _ -> raise Not_found); + + "SIGSEGV" >:: + (fun ctxt -> + if sigsegv ctxt then begin + Segfault.cause_segfault () + end); + + "Timeout" >: + (test_case + ~length:(OUnitTest.Custom_length 0.1) + (fun ctxt -> + if timeout ctxt then + Unix.sleep 1)) + ] + +let () = + OUnitThreads.init (); + run_test_tt_main suite diff -Nru ounit-2.0.8/test/fakeShared/dune ounit-2.2.3/test/fakeShared/dune --- ounit-2.0.8/test/fakeShared/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/fakeShared/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,3 @@ +(executable + (name fakeShared) + (libraries ounit2 ounit2.threads)) diff -Nru ounit-2.0.8/test/fakeShared/fakeShared.ml ounit-2.2.3/test/fakeShared/fakeShared.ml --- ounit-2.0.8/test/fakeShared/fakeShared.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/fakeShared/fakeShared.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,70 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + +(* + * Fake tests, to test mutex behavior with different runner. + *) + +open OUnit2 +open OUnitShared + +let test_mutex ctxt mutex = + let shared = ctxt.OUnitTest.shared in + Mutex.lock shared mutex; + (* On Windows, try_lock will succeed if it has been locked by the thread + * itself. + *) + if Sys.os_type <> "Win32" then + assert_bool + "Cannot acquire a locked mutex." + (not (Mutex.try_lock shared mutex)); + Mutex.unlock shared mutex; + assert_bool + "Can acquire an unlocked mutex." + (Mutex.try_lock shared mutex); + Mutex.unlock shared mutex + +let tests = + "Shared" >::: + [ + "MutexGlobal" >:: + (fun ctxt -> + test_mutex ctxt (Mutex.create ScopeGlobal)); + + "MutexProcess" >:: + (fun ctxt -> + test_mutex ctxt (Mutex.create ScopeProcess)); + ] + +let () = + OUnitThreads.init (); + run_test_tt_main tests diff -Nru ounit-2.0.8/test/lwt/dune ounit-2.2.3/test/lwt/dune --- ounit-2.0.8/test/lwt/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/lwt/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,4 @@ +(test + (name test) + (package ounit2-lwt) + (libraries ounit2 ounit2-lwt testcommon)) diff -Nru ounit-2.0.8/test/lwt/test.ml ounit-2.2.3/test/lwt/test.ml --- ounit-2.0.8/test/lwt/test.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/lwt/test.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,52 @@ +(**************************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) +(* Copyright (C) 2010 OCamlCore SARL *) +(* Copyright (C) 2013 Sylvain Le Gall *) +(* *) +(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) +(* and Sylvain Le Gall. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining *) +(* a copy of this document and the OUnit software ("the Software"), to *) +(* deal in the Software without restriction, including without limitation *) +(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) +(* or other liability, whether in an action of contract, tort or *) +(* otherwise, arising from, out of or in connection with the Software or *) +(* the use or other dealings in the software. *) +(* *) +(* See LICENSE.txt for details. *) +(**************************************************************************) + + +(* + * Fake tests, to test HTML output. + *) + +open OUnit2 +open Lwt.Infix + +let suite = + "OUnitLwt" >::: [ + "SimpleAssertion" >:: + (OUnitLwt.lwt_wrapper + (fun ctxt -> + Lwt.return 4 + >>= fun i -> + Lwt.return (assert_equal ~ctxt 4 i))) + ] + +let () = run_test_tt_main suite + diff -Nru ounit-2.0.8/test/lwt/testRunnerProcesses/dune ounit-2.2.3/test/lwt/testRunnerProcesses/dune --- ounit-2.0.8/test/lwt/testRunnerProcesses/dune 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/lwt/testRunnerProcesses/dune 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,6 @@ +(test + (name testRunnerProcesses) + (package ounit2-lwt) + (deps test.txt) + (libraries ounit2 lwt lwt.unix ounit2-lwt) + (action (run %{test} -runner processes))) diff -Nru ounit-2.0.8/test/lwt/testRunnerProcesses/testRunnerProcesses.ml ounit-2.2.3/test/lwt/testRunnerProcesses/testRunnerProcesses.ml --- ounit-2.0.8/test/lwt/testRunnerProcesses/testRunnerProcesses.ml 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/lwt/testRunnerProcesses/testRunnerProcesses.ml 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1,21 @@ +open OUnit2 + +let test = + OUnitTest.TestCase + (OUnitTest.Short, + let open Lwt.Infix in + OUnitLwt.lwt_wrapper + (fun _ctxt -> + Lwt_io.open_file ~mode:Lwt_io.Input "test.txt" + >>= fun channel -> + Lwt_io.read_char channel + >|= fun _ -> ())) + +let test = + (* Running a lot of tests in parallel allows to check for race conditions + * see bug OF#1765 + *) + "testRunnerProcesses" >::: (Array.to_list (Array.make 50 test)) + +let () = + run_test_tt_main test diff -Nru ounit-2.0.8/test/lwt/testRunnerProcesses/test.txt ounit-2.2.3/test/lwt/testRunnerProcesses/test.txt --- ounit-2.0.8/test/lwt/testRunnerProcesses/test.txt 1970-01-01 00:00:00.000000000 +0000 +++ ounit-2.2.3/test/lwt/testRunnerProcesses/test.txt 2020-07-11 15:47:08.000000000 +0000 @@ -0,0 +1 @@ +this is a test. diff -Nru ounit-2.0.8/test/testCommon.ml ounit-2.2.3/test/testCommon.ml --- ounit-2.0.8/test/testCommon.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testCommon.ml 2020-07-11 15:47:08.000000000 +0000 @@ -57,7 +57,7 @@ in (path, test_result', pos) in - List.sort Pervasives.compare (List.rev_map norm_one lst) + List.sort Stdlib.compare (List.rev_map norm_one lst) in assert_equal ~cmp: @@ -77,7 +77,7 @@ match test_result with | RSuccess -> "RSuccess" - | RFailure (str, pos_opt, backtrace) -> + | RFailure (str, _, backtrace) -> spf "RFailure(%S, _, %s)" str (string_of_backtrace backtrace) | RError (str, backtrace) -> @@ -94,3 +94,4 @@ (norm results))) exp res +let skip_if_notunix () = skip_if (Sys.os_type <> "Unix") "Only run on Unix." diff -Nru ounit-2.0.8/test/testConf.ml ounit-2.2.3/test/testConf.ml --- ounit-2.0.8/test/testConf.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testConf.ml 2020-07-11 15:47:08.000000000 +0000 @@ -41,13 +41,13 @@ let bracket_ounitconf = bracket - (fun ctxt -> + (fun _ -> (* TODO: we need a lock here. *) { vint = make_int "int" 0 ""; vstring = make_string "string" "" ""; }) - (fun _ t -> + (fun _ _ -> Hashtbl.remove metaconf "int"; Hashtbl.remove metaconf "string"; (* TODO: release the lock. *) diff -Nru ounit-2.0.8/test/testFakeHTML.ml ounit-2.2.3/test/testFakeHTML.ml --- ounit-2.0.8/test/testFakeHTML.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testFakeHTML.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - - -(* - * Fake tests, to test HTML output. - *) - -open OUnit2 - -let suite = - "OUnitLoggerHTML" >::: - [ - "first test" >:: - (fun ctxt -> - assert_equal 0 1); - - "second test" >:: - (fun ctxt -> - assert_equal 0 0); - - "third test" >:: - (fun ctxt -> - skip_if true "skipped because of me"); - - "fourth test" >:: - (fun ctxt -> - todo "need to make this function"); - - "fifth test" >:: - (fun ctxt -> - raise Not_found); - - "with symbol" >:: - (fun ctxt -> - failwith "this is a bad message: '\"&<>") - ] - -let () = run_test_tt_main suite diff -Nru ounit-2.0.8/test/testFakeRunner.ml ounit-2.2.3/test/testFakeRunner.ml --- ounit-2.0.8/test/testFakeRunner.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testFakeRunner.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,84 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(* - * Fake tests, to test runner behavior in some situation. - *) - -open OUnit2 - -let sigsegv = - Conf.make_bool - "sigsegv" - false - "Fail with SIGSEGV." - -let timeout = - Conf.make_bool - "timeout" - false - "Time out." - -let suite = - "TestFakeRunner" >::: - [ - "success" >:: - (fun ctxt -> assert_equal 0 0); - - "failure" >:: - (fun ctxt -> assert_equal 0 1); - - "skip" >:: - (fun ctxt -> skip_if true "skipped because of me"); - - "todo" >:: - (fun ctxt -> todo "need to make this function"); - - "error" >:: - (fun ctxt -> raise Not_found); - - "SIGSEGV" >:: - (fun ctxt -> - if sigsegv ctxt then - Unix.kill (Unix.getpid ()) 11); - - "Timeout" >: - (test_case - ~length:(OUnitTest.Custom_length 0.1) - (fun ctxt -> - if timeout ctxt then - Unix.sleep 1)) - ] - -let () = - OUnitThreads.init (); - run_test_tt_main suite diff -Nru ounit-2.0.8/test/testFakeShared.ml ounit-2.2.3/test/testFakeShared.ml --- ounit-2.0.8/test/testFakeShared.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testFakeShared.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -(**************************************************************************) -(* The OUnit library *) -(* *) -(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) -(* Copyright (C) 2010 OCamlCore SARL *) -(* Copyright (C) 2013 Sylvain Le Gall *) -(* *) -(* The package OUnit is copyright by Maas-Maarten Zeeman, OCamlCore SARL *) -(* and Sylvain Le Gall. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining *) -(* a copy of this document and the OUnit software ("the Software"), to *) -(* deal in the Software without restriction, including without limitation *) -(* the rights 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 Maas-Maarten Zeeman be liable for any claim, damages *) -(* or other liability, whether in an action of contract, tort or *) -(* otherwise, arising from, out of or in connection with the Software or *) -(* the use or other dealings in the software. *) -(* *) -(* See LICENSE.txt for details. *) -(**************************************************************************) - -(* - * Fake tests, to test mutex behavior with different runner. - *) - -open OUnit2 -open OUnitShared - -let test_mutex ctxt mutex = - let shared = ctxt.OUnitTest.shared in - Mutex.lock shared mutex; - assert_bool - "Cannot acquire a locked mutex." - (not (Mutex.try_lock shared mutex)); - Mutex.unlock shared mutex; - assert_bool - "Can acquire an unlocked mutex." - (Mutex.try_lock shared mutex); - Mutex.unlock shared mutex - -let tests = - "Shared" >::: - [ - "MutexGlobal" >:: - (fun ctxt -> - test_mutex ctxt (Mutex.create ScopeGlobal)); - - "MutexProcess" >:: - (fun ctxt -> - test_mutex ctxt (Mutex.create ScopeProcess)); - ] - -let () = - OUnitThreads.init (); - run_test_tt_main tests diff -Nru ounit-2.0.8/test/testOtherTests.ml ounit-2.2.3/test/testOtherTests.ml --- ounit-2.0.8/test/testOtherTests.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testOtherTests.ml 2020-07-11 15:47:08.000000000 +0000 @@ -35,7 +35,7 @@ let xmllint = Conf.make_exec "xmllint" -let testFakeHTML = Conf.make_exec "testFakeHTML" +let fakeHTML = Conf.make_exec "fakeHTML" let tests = "OtherTests" >::: @@ -47,11 +47,14 @@ *) let () = skip_if (Sys.os_type = "Win32") - "Don't run on Win32." + "Don't run on Win32."; + skip_if (Sys.command ((xmllint ctxt)^" --version 2> /dev/null") == 127) + "xmllint not found."; in - let html_dir = "log-html" in + let html_dir = Filename.concat (Sys.getcwd ()) "log-html" in let junit_xml = Filename.concat html_dir "junit.xml" in let index_html = Filename.concat html_dir "index.html" in + let junit_xsd = Filename.concat (Sys.getcwd ()) "JUnit.xsd" in let link_to_source bn = Sys.remove (Filename.concat html_dir bn); Unix.symlink @@ -80,7 +83,7 @@ assert_command ~ctxt ~exit_code:(Unix.WEXITED 1) - (testFakeHTML ctxt) + (fakeHTML ctxt) ["-output-file"; Filename.concat html_dir "fake-html.log"; "-output-html-dir"; html_dir; "-output-junit-file"; junit_xml]; @@ -103,7 +106,7 @@ assert_command ~ctxt (xmllint ctxt) - ["--noout"; "--nonet"; "--schema"; "test/JUnit.xsd"; junit_xml]; + ["--noout"; "--nonet"; "--schema"; junit_xsd; junit_xml]; assert_command ~ctxt (xmllint ctxt) @@ -112,7 +115,7 @@ ()); "BacktraceProcessing" >:: - (fun ctxt -> + (fun _ -> List.iter (fun (str, exp) -> @@ -150,11 +153,11 @@ let extract_exc e = let _, result, _ = OUnitTest.result_full_of_exception ctxt e in match result with - | OUnitTest.RFailure (str, + | OUnitTest.RFailure (_, Some {OUnitLogger.filename = fn; line = lineno}, _) -> fn, lineno - | e -> + | _ -> assert_failure "Should return a position." in diff -Nru ounit-2.0.8/test/testOUnit2.ml ounit-2.2.3/test/testOUnit2.ml --- ounit-2.0.8/test/testOUnit2.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testOUnit2.ml 2020-07-11 15:47:08.000000000 +0000 @@ -32,12 +32,12 @@ open OUnit2 -let test_normal = "Normal" >:: (fun ctxt -> ()) -let test_assert = "Assert" >:: (fun ctxt -> assert_equal 1 1) -let test_todo = "Todo" >:: (fun ctxt -> todo "test") -let test_skip = "Skip" >:: (fun ctxt -> skip_if true "to be skipped") -let test_fail = "Fail" >:: (fun ctxt -> assert_equal 1 2) -let test_error = "Error" >:: (fun ctxt -> failwith "Not expected") +let test_normal = "Normal" >:: (fun _ -> ()) +let test_assert = "Assert" >:: (fun _ -> assert_equal 1 1) +let test_todo = "Todo" >:: (fun _ -> todo "test") +let test_skip = "Skip" >:: (fun _ -> skip_if true "to be skipped") +let test_fail = "Fail" >:: (fun _ -> assert_equal 1 2) +let test_error = "Error" >:: (fun _ -> failwith "Not expected") let test_ounit2 suite test_ctxt = let log_fn, _ = bracket_tmpfile test_ctxt in @@ -53,7 +53,7 @@ (* TODO: acquire lock *) !OUnitCore.run_test_tt_main_conf in - let override_conf ?preset ?argv extra_specs = + let [@warning "-27"] override_conf ?preset ?argv _ = OUnitCore.run_test_tt_main_conf := old_get_conf; (* TODO: release lock *) conf diff -Nru ounit-2.0.8/test/testOUnitAssert.ml ounit-2.2.3/test/testOUnitAssert.ml --- ounit-2.0.8/test/testOUnitAssert.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testOUnitAssert.ml 2020-07-11 15:47:08.000000000 +0000 @@ -31,7 +31,6 @@ (**************************************************************************) open OUnitTest -open OUnitAssert open OUnit2 let test_assert_raises _ = @@ -70,7 +69,7 @@ assert_bool "true" true; assert_raises (OUnit_failure "false") (fun _ -> assert_bool "false" false) -let test_case_skip ctxt = +let test_case_skip _ = begin try skip_if false "test" @@ -79,7 +78,7 @@ end; assert_raises (Skip "test") (fun _ -> skip_if true "test") -let test_case_todo ctxt = +let test_case_todo _ = assert_raises (Todo "test") (fun _ -> todo "test") let test_assert_command ctxt = diff -Nru ounit-2.0.8/test/testOUnitBracket.ml ounit-2.2.3/test/testOUnitBracket.ml --- ounit-2.0.8/test/testOUnitBracket.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testOUnitBracket.ml 2020-07-11 15:47:08.000000000 +0000 @@ -78,20 +78,43 @@ "Temporary directory doesn't exist anymore." (not (Sys.file_exists dn))); + "tmpdir_with_symlink" >:: + (fun test_ctxt -> + let () = TestCommon.skip_if_notunix () in + let tmpdn = bracket_tmpdir test_ctxt in + let tmpdn2 = Filename.concat tmpdn "bar" in + let _ = + Unix.mkdir tmpdn2 0700; + assert_bool + "Directory outside of temporary directory exists." + (Sys.file_exists tmpdn2); + with_bracket_holder + test_ctxt bracket_tmpdir + (fun dn -> + let target = Filename.concat dn "symlink" in + Unix.symlink tmpdn target) + in + assert_bool + "Directory outside of temporary directory still exists." + (Sys.file_exists tmpdn2)); + "chdir" >:: (fun test_ctxt -> let tmpdn = bracket_tmpdir test_ctxt in + let orgdn = Sys.getcwd () in let () = with_bracket test_ctxt (bracket_chdir tmpdn) - (fun _ (test_ctxt : OUnitTest.ctxt) -> - assert_equal - ~printer:(fun s -> s) - tmpdn - (Sys.getcwd ())) + (fun _ (_ : OUnitTest.ctxt) -> + assert_bool + (Printf.sprintf + "Expected to have changed to a new directory, but still in %s" + orgdn) + (orgdn <> (Sys.getcwd ()))) in assert_bool - "Not in temporary directory anymore." - (tmpdn <> Sys.getcwd ())); - + (Printf.sprintf + "Expected to be back in the original directory, but still in %s" + (Sys.getcwd ())) + (orgdn = Sys.getcwd ())); ] diff -Nru ounit-2.0.8/test/testOUnitChooser.ml ounit-2.2.3/test/testOUnitChooser.ml --- ounit-2.0.8/test/testOUnitChooser.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testOUnitChooser.ml 2020-07-11 15:47:08.000000000 +0000 @@ -134,7 +134,7 @@ "Chooser" >::: [ "failfirst" >:: - (fun test_ctxt -> + (fun _ -> check_choices failfirst [test "foo"] [choose "foo"]; diff -Nru ounit-2.0.8/test/testOUnitDiff.ml ounit-2.2.3/test/testOUnitDiff.ml --- ounit-2.0.8/test/testOUnitDiff.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testOUnitDiff.ml 2020-07-11 15:47:08.000000000 +0000 @@ -44,7 +44,7 @@ module DiffListSimpleInt = OUnitDiff.ListSimpleMake(EInt) -let test_diff ctxt = +let test_diff _ = let lst_exp = [1; 2; 3; 4; 5] in diff -Nru ounit-2.0.8/test/testOUnitTest.ml ounit-2.2.3/test/testOUnitTest.ml --- ounit-2.0.8/test/testOUnitTest.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testOUnitTest.ml 2020-07-11 15:47:08.000000000 +0000 @@ -34,7 +34,7 @@ open TestCommon open OUnit2 -let test_case = TestCase (Short, fun ctxt -> ()) +let test_case = TestCase (Short, fun _ -> ()) let labeled_test_case = TestLabel ("label", test_case) let suite_a = TestLabel ("suite_a", TestList [test_case]) let suite_b = TestLabel ("suite_b", TestList [labeled_test_case]) @@ -45,7 +45,7 @@ [] -> "" | h::t -> (string_of_path h) ^ "\n" ^ (string_of_paths t) -let test_case_filter ctxt = +let test_case_filter _ = let assert_test_case_count exp tst_opt = match tst_opt with | Some tst -> @@ -64,7 +64,7 @@ assert_test_case_count 2 (test_filter ["suite_c:0";"suite_c:1:label"] suite_c) -let test_case_decorate ctxt = +let test_case_decorate _ = assert_equal_test_result [ [Label "label"; ListItem 1; Label "suite_c"], @@ -88,11 +88,11 @@ ] (perform_test (test_decorate - (fun _ -> (fun ctxt -> assert_failure "fail")) + (fun _ -> (fun _ -> assert_failure "fail")) suite_c)) (* Test which checks if the test case count function works correctly *) -let test_case_count ctxt = +let test_case_count _ = let assert_equal ?msg = assert_equal ?msg ~printer:string_of_int in assert_equal 0 (test_case_count (TestList [])); assert_equal 0 (test_case_count (TestLabel("label", TestList []))); @@ -194,4 +194,3 @@ "test_case_decorate" >:: test_case_decorate; "test_non_fatal" >:: test_non_fatal; ] - diff -Nru ounit-2.0.8/test/testRunner.ml ounit-2.2.3/test/testRunner.ml --- ounit-2.0.8/test/testRunner.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testRunner.ml 2020-07-11 15:47:08.000000000 +0000 @@ -31,8 +31,10 @@ (**************************************************************************) open OUnit2 +open TestCommon -let testFakeRunner = Conf.make_exec "testFakeRunner" +let fakeRunner = Conf.make_exec "fakeRunner" +let fakeBadFinaliser = Conf.make_exec "fakeBadFinaliser" type test_results = { @@ -53,15 +55,13 @@ test_results.failures test_results.skip test_results.todo test_results.timeout + let run_test_fake_runner ctxt runner args = let fn, _ = bracket_tmpfile ctxt in let () = - assert_command - ~ctxt - ~exit_code:(Unix.WEXITED 1) - ~env:[||] - (testFakeRunner ctxt) - ("-output-file" :: fn :: "-runner" :: runner :: args); + TestCommonRunner.run_fake_external_prog + ~ctxt ~exit_code:(Unix.WEXITED 1) ~runner + (fakeRunner ctxt) args fn in let mk str = @@ -124,6 +124,7 @@ timeout = !timeout; } + let check_standard_results ?(extra_errors=0) ?(extra_timeouts=0) test_results = assert_equal ~msg:"test results" @@ -139,8 +140,6 @@ } test_results -let skip_if_notunix () = skip_if (Sys.os_type <> "Unix") "Only run on Unix." - let tests = "Runner" >::: [ @@ -157,6 +156,31 @@ in check_standard_results test_results); + "ProcessesWithBadFinaliser" >:: + (fun ctxt -> + let () = skip_if_notunix () in + let finaliser_token = "1234566789" in + let fn, _ = bracket_tmpfile ctxt in + let () = + TestCommonRunner.run_fake_external_prog + ~ctxt ~runner:"processes" ~exit_code:(Unix.WEXITED 1) + (fakeBadFinaliser ctxt) + ["-shards"; "2"; "-finaliser-token"; finaliser_token] + fn + in + let chn = open_in fn in + let str = Str.regexp (Str.quote finaliser_token) in + let token_found = ref false in + try + while true do + let line = input_line chn in + if Str.string_match str line 0 then + token_found := true + done; + assert_bool "Finaliser token found in the logs." !token_found + with End_of_file -> + close_in chn); + "Processes#1" >:: (fun ctxt -> let test_results = diff -Nru ounit-2.0.8/test/testShared.ml ounit-2.2.3/test/testShared.ml --- ounit-2.0.8/test/testShared.ml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/test/testShared.ml 2020-07-11 15:47:08.000000000 +0000 @@ -31,16 +31,15 @@ (**************************************************************************) open OUnit2 +open TestCommon -let testFakeShared = Conf.make_exec "testFakeShared" +let fakeShared = Conf.make_exec "fakeShared" let run_test_fake_shared ctxt runner args = let fn, _ = bracket_tmpfile ctxt in - assert_command - ~ctxt - ~exit_code:(Unix.WEXITED 0) - (testFakeShared ctxt) - ("-output-file" :: fn :: "-runner" :: runner :: args) + TestCommonRunner.run_fake_external_prog + ~ctxt ~exit_code:(Unix.WEXITED 0) ~runner + (fakeShared ctxt) args fn let tests = "Shared" >::: @@ -51,6 +50,7 @@ "Processes" >:: (fun ctxt -> + skip_if_notunix (); run_test_fake_shared ctxt "processes" ["-shards"; "2"]); "Threads" >:: diff -Nru ounit-2.0.8/tools/ci/build.bash ounit-2.2.3/tools/ci/build.bash --- ounit-2.0.8/tools/ci/build.bash 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/tools/ci/build.bash 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -. "$(dirname $0)/packages.bash" || exit 1 -. "$(dirname $0)/opam.bash" || exit 1 -mkdir dist || true -opam install "${OPAM_PKGS[@]}" -export OCAMLRUNPARAM=b -ocaml setup.ml -distclean -ocaml setup.ml -configure \ - --enable-tests \ - ${CONFIGURE_ARGS} -ocaml setup.ml -build -ocaml setup.ml -test ${TEST_ARGS} diff -Nru ounit-2.0.8/tools/ci/opam.bash ounit-2.2.3/tools/ci/opam.bash --- ounit-2.0.8/tools/ci/opam.bash 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/tools/ci/opam.bash 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -################################################################################ -# OASIS: architecture for building OCaml libraries and applications # -# # -# Copyright (C) 2011-2016, Sylvain Le Gall # -# Copyright (C) 2008-2011, OCamlCore SARL # -# # -# 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, with the OCaml static compilation # -# exception. # -# # -# 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 file COPYING 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 St, Fifth Floor, Boston, MA 02110-1301 USA # -################################################################################ - -export OPAMYES=1 -OPAMROOT="${OPAMROOT:="$(pwd)/.opam"}" -export OPAMROOT -if [ -f "$OPAMROOT/config" ]; then - opam update - opam upgrade -else - opam init -fi -if [ -n "${OPAM_SWITCH}" ]; then - opam switch ${OPAM_SWITCH} -fi -eval `opam config env` - diff -Nru ounit-2.0.8/tools/ci/packages.bash ounit-2.2.3/tools/ci/packages.bash --- ounit-2.0.8/tools/ci/packages.bash 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/tools/ci/packages.bash 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -OPAM_PKGS=() -OPAM_PKGS+=( "base-bytes") -OPAM_PKGS+=( "base-unix" ) -OPAM_PKGS+=( "ocamlfind>=1.3.1" ) -OPAM_PKGS+=( "oasis" ) diff -Nru ounit-2.0.8/tools/ci/travis.bash ounit-2.2.3/tools/ci/travis.bash --- ounit-2.0.8/tools/ci/travis.bash 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/tools/ci/travis.bash 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -OPAMROOT="$HOME/.opam" -. $(dirname "$0")/build.bash diff -Nru ounit-2.0.8/.travis.yml ounit-2.2.3/.travis.yml --- ounit-2.0.8/.travis.yml 2018-04-04 06:34:34.000000000 +0000 +++ ounit-2.2.3/.travis.yml 2020-07-11 15:47:08.000000000 +0000 @@ -1,25 +1,56 @@ language: c -sudo: false -addons: - apt: - sources: - - avsm - packages: - - ocaml - - ocaml-native-compilers - - opam - - texlive-latex-recommended - - libxml2-utils -branches: - except: - - opam/unstable - - opam/testing -script: bash -ex ./tools/ci/travis.bash +sudo: required +install: test -e .travis.opam.sh || wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh +script: bash -ex .travis-opam.sh env: - - OPAM_SWITCH=system - - OPAM_SWITCH=4.02.3 # Debian stretch - - OPAM_SWITCH=4.05.0 # Debian sid - - OPAM_SWITCH=4.06.0 # HEAD -cache: - directories: - - $HOME/.opam + global: + - OUNIT_CI=true +matrix: + include: + - name: "ounit: linux" + os: linux + env: OCAML_VERSION=4.10 PACKAGE="ounit" + + - name: "ounit-lwt: linux" + os: linux + env: OCAML_VERSION=4.10 PACKAGE="ounit-lwt" + + - name: "ounit2: linux" + apt: + packages: + - libxml2-utils + os: linux + env: OCAML_VERSION=4.10 PACKAGE="ounit2" + + - name: "ounit2-lwt: linux" + os: linux + env: OCAML_VERSION=4.10 PACKAGE="ounit2-lwt" + + - name: "ounit2: reverse dependencies with linux" + os: linux + env: OCAML_VERSION=4.10 PACKAGE="ounit2" REVDEPS="mock-ounit junit_ounit pa_ounit qcheck-ounit" POST_INSTALL_HOOK="opam install -t fileutils" + + - name: "ounit2: old ocaml release with linux" + os: linux + env: OCAML_VERSION=4.04 PACKAGE="ounit2" + + - name: "ounit: MacOSX" + os: osx + env: OCAML_VERSION=4.10 PACKAGE="ounit" REVDEPS="junit_ounit" + cache: + directories: + - $HOME/Library/Caches/Homebrew + + - name: "ounit2: MacOSX" + os: osx + env: OCAML_VERSION=4.10 PACKAGE="ounit2" REVDEPS="junit_ounit" + cache: + directories: + - $HOME/Library/Caches/Homebrew + + - name: "ounit2-lwt: MacOSX" + os: osx + env: OCAML_VERSION=4.10 PACKAGE="ounit2-lwt" + cache: + directories: + - $HOME/Library/Caches/Homebrew