swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

18
unikernel/duniverse/ocaml-cstruct/.drone.yml Normal file
View file

@ -0,0 +1,18 @@
kind: pipeline
name: amd
platform:
os: linux
arch: amd64
steps:
- name: build
image: ocaml/opam:debian-ocaml-4.12-afl
commands:
- sudo chown -R opam .
- git -C /home/opam/opam-repository pull origin 1ce065bc0cbef7bc06effcd3865af0d430c6273b && opam update
- opam pin add -n .
- opam depext -u cstruct-async cstruct-lwt cstruct-unix cstruct ppx_cstruct
- opam install -y .
- opam install -y dune crowbar fmt 'bun>=0.3.4'
- opam exec -- dune build @fuzz --no-buffer

5
unikernel/duniverse/ocaml-cstruct/.gitattributes vendored Normal file
View file

@ -0,0 +1,5 @@
# Default behaviour, for if core.autocrlf isn't set
* text=auto
.azure-pipelines.sh text eol=lf
ppx_test/errors/* text eol=lf

57
unikernel/duniverse/ocaml-cstruct/.github/workflows/test.yml vendored Normal file
View file

@ -0,0 +1,57 @@
name: Cstruct
on: [push, pull_request]
jobs:
latest:
name: Latest
runs-on: ${{ matrix.operating-system }}
strategy:
fail-fast: false
matrix:
ocaml-version: [ '4.13.1', '4.10.0', '4.08.1' ]
operating-system: [macos-latest, ubuntu-latest, windows-latest]
steps:
- uses: actions/checkout@v2
- uses: avsm/setup-ocaml@v1
with:
ocaml-version: ${{ matrix.ocaml-version }}
- run: opam pin add -n .
- name: Packages
run: opam depext -yt cstruct cstruct-sexp cstruct-unix cstruct-lwt
- name: Build
run: opam install -t cstruct cstruct-sexp cstruct-unix cstruct-lwt
ppx:
name: PPX
runs-on: ${{ matrix.operating-system }}
strategy:
fail-fast: false
matrix:
ocaml-version: [ '4.13.1', '4.10.0', '4.08.1' ]
operating-system: [macos-latest, ubuntu-latest, windows-latest]
steps:
- uses: actions/checkout@v2
- uses: avsm/setup-ocaml@v1
with:
ocaml-version: ${{ matrix.ocaml-version }}
- run: opam pin add -n .
- name: Packages
run: opam depext -yt ppx_cstruct
- name: Build
run: opam install -t ppx_cstruct
async:
name: Async
runs-on: ${{ matrix.operating-system }}
strategy:
fail-fast: false
matrix:
ocaml-version: [ '4.13.1', '4.10.0', '4.08.1' ]
operating-system: [macos-latest, ubuntu-latest]
steps:
- uses: actions/checkout@v2
- uses: avsm/setup-ocaml@v1
with:
ocaml-version: ${{ matrix.ocaml-version }}
- run: opam pin add -n .
- name: Packages
run: opam depext -yt cstruct-async
- name: Dependencies
run: opam install -t cstruct-async

5
unikernel/duniverse/ocaml-cstruct/.gitignore vendored Normal file
View file

@ -0,0 +1,5 @@
_build/
.merlin
*.install
.*.swp
_opam

2
unikernel/duniverse/ocaml-cstruct/.ocamlformat Normal file
View file

@ -0,0 +1,2 @@
version=0.20.1
disable=true

584
unikernel/duniverse/ocaml-cstruct/CHANGES.md Normal file
View file

@ -0,0 +1,584 @@
v6.2.0 2023-02-20
-----------------
- Add `sub_copy` function (@c-cube, #305)
- Fix documentation (@MisterDA, #304)
- Add `to_hex_string` function (@c-cube, #306)
- Fix documentation and use `Cstruct.length` instead of `Cstruct.len` (@reynir, #307)
- Deprecate `copy` function (alias of `to_string`) (will be removed at the next minor release)
(@reynir, #308)
v6.1.1 2022-07-24
-----------------
- ppx_cstruct: remove superfluous stdlib-shims dependency (@hannesm #300)
v6.1.0 2022-03-29
-----------------
**breaking changes**
- The deprecated functions `Cstruct.len`, `Cstruct.add_len`, `Cstruct.set_len`,
and `Cstruct.blit_to_string` have been removed (@hannesm #291)
- Implement host_endian (@haesbaert #292, fixes #72)
- Compatibility with OCaml 5.0.0 (@dinosaure #294)
- Drop support of OCaml < 4.08.0, remove bigarray-compat dependency
(@hannesm #298)
- Fix year in changes of 6.0.1 (@reynir #297)
v6.0.1 2021-06-25
-----------------
**breaking changes**
- `Cstruct.len` is deprecated, it will be deleted at the next
release. You should use `Cstruct.length` instead.
(@dinosaure, @hannesm, #284)
- Remove color from ppx's binary to replicate diff of errors in
any contexts (@dinosaure, @sternenseemann, #285)
- Add `shiftv` (@talex5, @avsm, @dinosaure, #287)
- Use `Bytes_val` if available (@hannesm, @avsm, @dinosaure, #286)
v6.0.0 2020-09-10
-----------------
**breaking changes**
- Add the function `Cstruct.length`, `Cstruct.len` will
be deprecated to next release (@dinosaure, @hannesm, @avsm, #279)
- `Cstruct.to_string` requires 2 optional arguments `?off` and `?len`
(@hannesm, @cfcs, @talex5, @dinosaure, #262)
- Use `ppxlib` instead `ppx_tools_versioned`
(@pveber, @avsm, @dinosaure, #280)
- Delete the support of old version of OCaml (< 4.07.0) for `ppx_cstruct`
(@avsm, @dinosaure, #280)
- Add useful functions to be able to parse some contents
with `Cstruct.t` like the `astring` library (#227,
@dinosaure, @avsm, @samoht, @hannesm).
- Improve the interface of `Cstruct.t` with capabilities
(@hannesm, @cfcs, @talex5, @dinosaure, #262)
v5.2.0 2020-06-10
-----------------
Upgrade the `ppx_cstruct` library to use the OCaml 4.11
AST rather than than OCaml 4.04, which in turn should
make it easier to port to ppxlib in the future and
improve interoperability with other PPXs (@bikallem #275).
Also upgrades build files to use dune 2.0 (@bikallem #275)
and fixes the GitHub Actions versions (@smorimoto #273)
and also test OCaml 4.10.0 (@avsm).
v5.1.1 2019-11-23
-----------------
This is a point release to fix a regression in 5.1.0
on compilers earlier than 4.07.
The release also fixes the test suite and CI on compilers
greater than 4.07.
v5.1.0 2019-11-23
-----------------
- Do not issue deprecation warnings when using OCaml 4.08.0
and cstruct-ppx with enums due to `Pervasives` (#269 @cypheon @hannesm)
- Tighten parsing of the `[@len]` attribute to ensure it is a
valid, positive integer (#265 @emillon)
- Update JavaScript bindings to latest `Js_of_ocaml` 3.5.0
interfaces (@hhugo #268)
v5.0.0 2019-04-19
-----------------
**Security**: This release tightens bounds checks to ensure
that data outside a given view (but still inside the underlying
buffer) cannot be accessed.
- `sub` does more checks (#244 #245 @hannesm @talex5 review by @dinosaure)
- `add_len` and `set_len` are now deprecated and will be removed
in a future release. (#251 @hannesm)
- do not add user-provided data for bounds checks
(#253 @hannesm, report and review by @talex5)
- improve CI to add fuzzing (#255 #252 @avsm @yomimono @talex5)
**Remove Unix dependency**: cstruct now uses the new `bigarray-compat`
library instead of Bigarray directly, to avoid a dependency on Unix
when using OCaml compilers less than 4.06.0. This will break downstream
libraries that do not have a direct dependency on `Bigarray`. Simply
fix it in your library by adding a `bigarray` dependency in your dune
file. (#247 @TheLortex)
**Capability module**: To improve the safety of future code with stronger type
checking, this release introduces a new `Cstruct_cap` module which makes the
underlying Cstruct an abstract type instead of a record. In return for this
extra abstraction, the module can enforce read-only, write only, and read/write
buffers by tracking them as phantom type variables. Although this library
shares an implementation internally with classic `Cstruct`, it is a significant
revision and so we will be gradually migrating to it. Feedback on it is
welcome! (#237 @dinosaure and many excited reviewers)
**Ppx compare functions**: A new `compare_X` function is generated for
`cenum` declarations. This respects custom ids supplied in the cenum
declaration and so is more robust than polymorphic compare (#248 @emillon)
The CI has also been switched over to both Azure Pipelines and Drone in
addition to Travis, and as a result the tests all run on Windows, macOS,
various Linux distributions, on x86 and arm64 machines, and runs AFL
fuzz tests on the Drone cloud (#255 @avsm).
v4.0.0 2019-03-25
-----------------
- Sexplib is now an optional library for the base `Cstruct` module.
A new `Cstruct_sexp` module has been introduced with the serialiser
functions, contained within the `cstruct-sexp` opam package.
To convert old code, simply use `Cstruct_sexp.t` instead of
`Cstruct.t` in a record type for which you are using `[@@deriving sexp]`.
This is a type alias to `Cstruct.t` but also has the right
sexp-conversion functions in scope. There is an example of this
in the `ppx_test/with-sexp` directory in the source repo.
When you have converted and released your library, add an
opam constraint of `cstruct {>="4.0.0"}` to your own opam
packages to ensure that they pick up this version of the library.
(fixes #222, @avsm)
- JavaScript stubs are now installed using the jsoo mechanism
rather than a manual specification (#241 @jonludlam)
- Use computed versions in opam files to ensure that dependent
opam packages such as cstruct-async get the same base version
of cstruct to avoid mismatches. (@avsm)
- Add a ppx test suite to checks that all error paths in ppx
handling are reachable and have meaningful location info (#238 @emillon)
v3.7.0 2019-03-10
-----------------
- Improve performance by not doing redundant bounds checks
in both the Bigarray and Cstruct level (#236 @Reperator @chambart)
- Ignore fields starting wih `_` by skipping code generation
but still respecting the space usage of that field. This was
a convention before but is now enforced by the code generator
to save space in the output (#233 @emillon)
- More warnings suppression for sizeof and enums (#231 @emillon)
v3.6.0 2019-03-01
-----------------
- A `[%%cstruct type ...]` declaration generates many values that
are potentially unused. The code generator in `ppx_cstruct` now
guarantees that there will be no more "unused value" (warning 32)
statements from use of the ppx form. (#228 @emillon)
- Actually run the ppx tests instead of just building them.
(#227 @emillon to fix #226 from @XVilka)
v3.5.0 2019-02-26
-----------------
- Remove trailing spaces in hexdump output (#219 @emillon)
- Add `Cstruct.rev` to allocate a reversed cstruct (#221 @emillon)
- `Cstruct_unix` now uses the post-OCaml 4.06 `Unix.map_file`
instead of the deprecated Bigarray `map_file` that was removed
in OCaml 4.08 (@avsm, see ocaml/ocaml#2263)
- Remove unnecessary `(wrapped false)` in the build system (@avsm)
- Correct ocamldoc to the right `cstruct-ppx` package pointer (@avsm)
v3.4.0 2019-02-02
-----------------
- Remove old compatibility packages for `cstruct.lwt`, `cstruct.async`,
`cstruct.ppx` and `cstruct.unix`. These were deprecated in
cstruct.3.0.0 in favour of counter part libraries with a dash
in the name (`cstruct-lwt`, `cstruct-async`, `cstruct.unix`)
or `ppx_cstruct` for the PPX extension. (@avsm)
v3.3.0 2019-01-22
-----------------
- Support for bi-endian cstructs that generate both sets of accessor
functions (#212 by @XVilka). This generates both `BE` and `LE`
modules to use as needed.
- Modify `of_string` and `of_bytes` to have an option `?off`
offset argument into the source bytes. (#208 by @XVilka)
- Improve tests to work on 32-bit architectures and handle
Gc better (@samoht)
- Do not depend explicitly on deprecated `ppx_driver`. This was
primarily there for older compilers, and new uses should be
based around `ppxlib`. (#201 by @edwintorok).
- Upgrade opam metadata to 2.0 format. (#217 by @XVilka @avsm)
- Upgrade to dune from jbuilder and support dune-release instead
of topkg (@avsm)
v3.2.1 2017-12-13
-----------------
- improve performance by using primitives instead of C stubs. the performance
regression was introduced in #177 in 3.2.0 (#195 by @pqwy)
v3.2.0 2017-11-17
-----------------
- wrap `hexdump_pp` output in a box (#175 by @cfcs)
- remove dependency on `ocplib-endian` (#177 by @hannesm)
- add `of_hex: string -> t` (#179 by @hannesm and @pqwy)
- add `to_bytes: t -> Bytes.t` (#183 by @hannesm)
- add `empty: t` (#184 by @hannesm)
- sub: check the bounds more carefully for overflow (#185 by @hannesm)
- cstruct-unix: fix the build on OCaml 4.06.0 (#187 by @djs55)
- travis: test OCaml 4.04.2 and 4.06.0 (#186 by @hannesm)
v3.1.1 2017-07-13
-----------------
- `check_alignment` now treats a large alignment as an unsigned value
and so doesnt raise a signal (#171 by @yallop)
- Improve Windows support by avoiding `void *` pointer arithmetic and
have more portable headers in the C stubs (#170 by @fdopen)
v3.1.0 2017-07-12
-----------------
- Fix arithmetic overflow in `Cstruct.lenv` and `copyv` (#159 by @yallop)
- Reject negative destination offsets in `blit` (#160 by @yallop)
- Add AFL fuzz tests using Crowbar, which independently discovered
#160 and also an overflow in `of_bigarray` and `sub`, now bith
fixed (#164 by @talex5)
- Improve performance of several allocation functions by eliminating an
unnecessary buffer zero step (#158 by @hannesm)
- Compile the source tree with stricter flags, including dead variable
detection and deprecation warnings (#157 by @samoht)
- Bump the required minimum OCaml version up to 4.03.0 (due to #157).
v3.0.2 2017-06-14
-----------------
- fix the `cstruct-async` package build, and depend on the latest
Async packages (>="v0.9.0") as part of this. (#152 @jnfoster)
v3.0.1 2017-06-09
-----------------
- ppx: remove an errant standalone initialiser that was messing up
the composition of cstruct with other `ppx_driver` based ppx converters
(most notably `ppx_sexp_conv`. If you are having trouble with using
`ppx_cstruct` with other drivers, put a constraint on `ppx_cstruct>=3.0.1`.
(#151 #150 #149 #148 via @djs55 @g2p @avsm @diml).
- ppx: also add a test case for `cstruct` and `lwt` working together, but
this will not work until a `lwt>3.0` release happens.
- Update opam rules to use `jbuilder subst` for version information
in the distribution.
- Fix tests so that `check_alignment` expects a negative result.
- Add opam test target for core library.
v3.0.0 2017-05-11
-----------------
- Split up OPAM packages into multiple independent ones. We now
have a standalone `cstruct`, and then separate `cstruct-lwt`,
`cstruct-async`, `cstruct-unix` packages, and a `ppx_cstruct`
package for the syntax extension. Transitional findlib packages
with the old scheme are available, but now packages should migrate
to using `cstruct-async` instead of `cstruct.async` for example.
This has the added benefit of the OPAM package names now matching
the findlib names. (#138 by @avsm @rgrinberg).
- Port build to [jbuilder](https://github.com/janestreet/jbuilder).
See the README for local development instructions.
- Ensure that `check_alignment` only takes a non-zero argument
for alignment (#143 #145 by @cfcs @avsm).
v2.4.1 2017-05-03
-----------------
- fix missing `ppx_tools_versioned` dependency (#136, @let-def)
v2.4.0 2017-03-30
-----------------
Distribute the PPX extension so that it is compatible with Jbuilder.
`ppx_cstruct` is now distributed as both a library and a binary.
Findlib predicates are used to distinguish usage:
- the binary is used for toplevel and simple -ppx building
- the library is used for linking custom rewriters
- `-package cstruct.ppx` alone uses the binary for rewriting.
- `-package cstruct.ppx` -predicates custom_ppx,ppx_driver" is used to link the rewriter.
To use the PPX extension in jbuilder, just add:
```
(libraries (cstruct))
(preprocess (pps (cstruct.ppx)))
```
to your `jbuild` file. This may be renamed to `ppx_cstruct` in a
future release so that the PPX dependency is decoupled from the main
library, so this `cstruct.ppx` is intended to be transitional as it
is what was originally used.
v2.3.3 2017-03-28
-----------------
* Port ppx extension to use `ocaml-migrate-parsetree` so it should
also compile on future revisions of OCaml (#127 via @let-def).
v2.3.2 2017-03-03
-----------------
* Add support for OCaml 4.05 for the PPX extension.
* Docs: correct to description of shift function (#121 via @orbifx).
v2.3.1 2016-12-10
-----------------
* Fix a memory leak in the exception printing code (#130 via @djs55)
* Appveyor CI fixes (#130 via @avsm)
* Fix typo in docstring (#117 via @yomimono)
* Fix opam base-unix dependency (#115 via @avsm)
v2.3.0 2016-08-16
-----------------
* Add `Cstruct.of_bytes/to_bytes`. In common with the existing
implementation, this relies on the representation of bytes and string
being the same, which is true as of OCaml 4.04 and lower (#105 via @yallop).
* Support OCaml 4.04 (#111 via @gasche).
v2.2.0 2016-06-30
-----------------
* Make `create` zero out the new buffer. The new `create_unsafe`
function can be used if you want to trade safety for speed.
v2.1.0 2016-05-04
-----------------
* Add `hexdump_pp` that uses the Format module. This works better with the
Logs library than using `hexdump_to_buffer`, and also makes it easy to
indent the hexdump (#100 via @talex5).
v2.0.0 2016-04-26
-----------------
* Remove camlp4 extension as it is no longer maintained (#95).
* Add support for OCaml 4.03 in the PPX extension (#96).
* Minimum supported OCaml version for the library is now 4.02.3.
* Fix parsing of high int32 `@@enum` values.
* Move `Cstruct.check_alignment` into the stubs. Before this patch
we returned the buffer address from C and then calculated using
OCaml's boxed `Int64.t`. This patch reduces minor allocations by
performing the calculation in the C stubs. This makes the function
suitable for use in an assert in a performance sensitive path.
v1.9.0 2016-02-19
-----------------
* Add support for a ppx-based extension that uses the extension point
support in OCaml 4.02 and higher to generate Cstruct and Cenum
function definitions. The new syntax is documented in the README file.
v1.8.0 2016-01-05
-----------------
* Add support for `-safe-string` in OCaml 4.02 upwards.
The main change is to rename `blit_to_string` to `blit_to_bytes` and
change its type so that it writes to bytes rather than string
(#74 by @yallop).
* Remove strong build-time dependency on `camlp4` in the base library.
The `sexplib` functions were only used in the interface, so replace them
with manually written ones. This also enables compatibility with latest
Core that has switched to ppx.
* Add multi-distro testing via Travis/Docker containers.
v1.7.1 2015-12-15
-----------------
* Correct error output for `LE.get_uint16` on invalid bounds (#75)
* Fix `fillv`. If the source didn't fit in the buffer then we
skipped the amount we wanted to copy, not the amount actually copied (#77).
v1.7.0 2015-07-11
-----------------
* Add `Cstruct.concat` and `Cstruct.append` (#57, @pqwy)
* Add `js_of_ocaml` stubs (#63, #64, @djs55)
v1.6.0 2015-03-28
-----------------
* Add `memset` to set all the bytes of a cstruct value efficiently (#49)
* More useful `Invalid_argument` parameters (#48).
* Fix `to_sexp` to expose only the current view (#44 from David Kaloper).
* Add `compare` and `equal` (#23, #24 and #45 from David Kaloper).
* Add `fillv` to copy over a list of buffers (from Thomas Leonard).
* Shift to centralised Travis scripts.
v1.5.0 2014-11-24
-----------------
* Make `camlp4` an optional build-time dependency (#35).
* Remove `ounit` as a dependency in the `opam` file.
* Improve `opam` description file for OPAM 1.2 workflow (#36).
* Refresh Merlin IDE description (#37).
v1.4.0 2014-08-10
-----------------
Comprehensive addition of bounds checking to all cstruct operations
(from @pqwy in #33). The major changes are:
* Disallow negative indexing with all cstruct accessors.
* Disallow negative `sub` and `shift` operations.
* Make sure `of_bigarray` cannot create invalid `cstruct` values.
v1.3.1 2014-07-10
-----------------
* Also bounds test single-byte operations on views (#31 via @pqwy).
v1.3.0 2014-07-04
-----------------
* Add bounds checks for `Cstruct.BE/LE` functions that violate a view.
Previously, only bounds errors on the underlying buffers would raise.
Bug #25, reported by Mindy Preston in mirage/mirage-tcpip#56.
* Add 'Lwt_cstruct.complete' to ensure that `read`/`write` operatiosn
run to completion.
* Add `Sexplib` conversion functions to `Cstruct.t` values (#27 #22).
v1.2.0 2014-06-06
-----------------
Add a `sexp` optional decorator to `cenum` to output the values as s-expressions.
This is compatible with the `sexplib` convention. The syntax is;
```
cenum foo64 {
ONE64;
TWO64;
THREE64
} as uint64_t(sexp)
```
And `sexp_of_foo64` and `foo64_of_sexp` functions will also be available.
The representation of the Sexp is the string representation of the enum.
v1.1.0 2014-02-19
-----------------
* Improve bounds checks on sub, shift, set_len, add_len.
* Add `to_bigarray` to convert back into a Bigarray slice.
v1.0.1 2013-12-09
-----------------
* Fix Cstruct.shift function
v1.0.0 2013-12-05
-----------------
* Remove IPv4/IPv6 types (now moved to `ocaml-ipaddr`).
* Improved ocamldoc for the interface.
* More conservative bounds checking in the length manipulation functions.
* Build C stubs with `-Wall`.
v0.8.1 2013-11-06
-----------------
* Trailing semicolons are allowed in cstruct field definitions.
* Buffer elements can be any primitive integer, not just `uint8`.
v0.8.0 2013-10-13
-----------------
* Improved ocamldoc for BE/LE modules.
* Add Travis-CI test scripts and fix `test.sh` script compilation.
* Support int32/int64 constant values in cenum like `VAL = 0xffffffffl`, useful for 32-bit hosts.
* Check and raise error in case of negative offsets for blits (#4).
* Correctly preserve the sequence after a constant constructor is set during a `cenum` definition.
* Do not repeat the `sizeof_<field>` binding for every get/set field (should be no externally observable change).
* Add `Cstruct.hexdump_to_buffer` to make spooling hexdump output easier.
* Generate `hexdump_foo` and `hexdump_foo_to_buffer` prettyprinting functions for a `cstruct foo`.
v0.7.1 2013-03-06
-----------------
* Add `Async_cstruct.Pipe` to map pipes of `Cstruct` buffers to strings or `Bigsubstring`.
v0.7.0 2013-02-25
-----------------
* Add zero-copy conversion functions to/from the Core `Bigsubstring`.
* Add an `of_string` function to simplify the construction from OCaml values.
* Add Async interface to interoperate with Jane Street Core code.
v0.6.2 2013-02-08
-----------------
* Add experimental `cstruct.obuild` for the `obuild` build tool.
* Use bounds checked version of all functions in the external interface.
* Expose the `Cstruct.debug` to dump internal state of a buffer to a string.
* Add `set_len` and `add_len` to manipulate the total-length field directly.
v0.6.1 2012-12-20
-----------------
* Add `sendto`, `read` and `recvfrom` functions to the Lwt subpackage.
v0.6.0 2012-12-20
-----------------
* Add fast bigarray<->string functions to replace byte-by-byte copies.
* Add an Lwt sub-package to expose a write call.
* Depend on ocplib-endian for fast low-level parsing of integers.
* Make `Cstruct.t` a record type that doesn't use Bigarray slicing
to provide views onto buffers. This lets views be allocated directly
on the minor heap rather than forcing a major heap allocation. It
does alter the external API, so previous users of cstruct wont work.
v0.5.3 2012-12-16
-----------------
* No functional changes, just OASIS packaging fix to right version.
v0.5.2 2012-12-11
-----------------
* Remove the separate `xen` and `unix` subdirectories, as the
portable `Bigarray` is now provided by the `xenbigarray` package.
v0.5.1 2012-09-28
-----------------
* Add `string_to_<cenum>` function to match the `<cenum>_to_string`,
primarily to help with command-line parsing of enum arguments.
v0.5.0 2012-09-20
-----------------
* Add a signature generator for cstruct and cenum to permit their use in `.mli` files.
* Use the more reliable revised syntax camlp4 quotation expander, to avoid
broken AST output from antiquotations.
* Switch the `xen/` version over to using OASIS also.
v0.4.0 2012-09-02
-----------------
* Fix META file for use with Xen
v0.3 2012-08-25
--------------
* Initial public release

28
unikernel/duniverse/ocaml-cstruct/LICENSE.md Normal file
View file

@ -0,0 +1,28 @@
Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
Copyright (c) 2012 Pierre Chambart
Copyright (c) Christiano F. Haesbaert <haesbaert@haesbaert.org>
Copyright (c) Citrix Inc
Copyright (c) David Sheets <sheets@alum.mit.edu>
Copyright (c) Drup <drupyog@zoho.com>
Copyright (c) Hannes Mehnert <hannes@mehnert.org>
Copyright (c) Jeremy Yallop <yallop@gmail.com>
Copyright (c) Mindy Preston <meetup@yomimono.org>
Copyright (c) Nicolas Ojeda Bar <n.oje.bar@gmail.com>
Copyright (c) Richard Mortier <mort@cantab.net>
Copyright (c) Rudi Grinberg <rudi.grinberg@gmail.com>
Copyright (c) Thomas Gazagnaire <thomas@gazagnaire.com>
Copyright (c) Thomas Leonard <talex5@gmail.com>
Copyright (c) Vincent Bernardoff <vb@luminar.eu.org>
Copyright (c) pqwy <david@numm.org>
Permission to use, copy, modify, and distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

21
unikernel/duniverse/ocaml-cstruct/Makefile Normal file
View file

@ -0,0 +1,21 @@
.PHONY: all clean fuzz build-fuzz
all:
dune build
clean:
dune clean
test:
dune runtest
doc:
dune build @doc
build-fuzz:
dune build fuzz/fuzz.exe
fuzz: build-fuzz
mkdir -p _build/in
echo > _build/in/empty
afl-fuzz -i _build/in -o _build/out -- _build/default/fuzz/fuzz.exe @@

208
unikernel/duniverse/ocaml-cstruct/README.md Normal file
View file

@ -0,0 +1,208 @@
Cstruct - access C-like structures directly from OCaml
------------------------------------------------------
Cstruct is a library and syntax extension to make it easier to access C-like
structures directly from OCaml. It supports both reading and writing to these
structures, and they are accessed via the `Bigarray` module.
## Installation
This repository provides several packages that can be installed via the
[opam](https://opam.ocaml.org) package manager:
- `cstruct`: the core Cstruct library
- `cstruct-sexp`: serialisers into s-expression format of Cstructs
- `cstruct-unix`: provide Unix variations of the read/write functions using file descriptors
- `cstruct-async`: provide [Async](https://github.com/janestreet/async) Pipe and Bigstring support
- `cstruct-lwt`: provide [Lwt](https://ocsigen.org/lwt) variants of read/write functions
- `ppx_cstruct`: a [PPX](https://caml.inria.fr/pub/docs/manual-ocaml/extn.html#sec248) syntax extension (see below)
The libraries depend on OCaml version 4.08.0 and later, since it provides a
[ppx](http://whitequark.org/blog/2014/04/16/a-guide-to-extension-points-in-ocaml/)
extension point. The old
[camlp4](http://caml.inria.fr/pub/docs/manual-camlp4/manual002.html)
syntax extension is nolonger available; the last cstruct release which contained it
was v1.9.0.
### Local development
You can build the library via [dune](https://github.com/ocaml/dune),
using `make` or `dune build` directly. Since everything is built via dune,
you can also place this repository within a wider dune workspace in order to
make local modifications across repositories.
### Documentation
A documentation of the last version of `cstruct` is available [here](https://mirage.github.io/ocaml-cstruct).
## Usage
### PPX
The PPX processor is used by passing the OCaml source code through the
`ppx_cstruct` binary. An example pcap description is:
```
[%%cstruct
type pcap_header = {
magic_number: uint32_t; (* magic number *)
version_major: uint16_t; (* major version number *)
version_minor: uint16_t; (* minor version number *)
thiszone: uint32_t; (* GMT to local correction *)
sigfigs: uint32_t; (* accuracy of timestamps *)
snaplen: uint32_t; (* max length of captured packets, in octets *)
network: uint32_t; (* data link type *)
} [@@little_endian]]
[%%cstruct
type pcap_packet = {
ts_sec: uint32_t; (* timestamp seconds *)
ts_usec: uint32_t; (* timestamp microseconds *)
incl_len: uint32_t; (* number of octets of packet saved in file *)
orig_len: uint32_t; (* actual length of packet *)
} [@@little_endian]]
[%%cstruct
type ethernet = {
dst: uint8_t [@len 6];
src: uint8_t [@len 6];
ethertype: uint16_t;
} [@@big_endian]]
[%%cstruct
type ipv4 = {
hlen_version: uint8_t;
tos: uint8_t;
len: uint16_t;
id: uint16_t;
off: uint16_t;
ttl: uint8_t;
proto: uint8_t;
csum: uint16_t;
src: uint8_t [@len 4];
dst: uint8_t [@len 4];
} [@@big_endian]]
```
This auto-generates generates functions of the form below in the `ml` file:
```
let sizeof_pcap_packet = 16
let get_pcap_packet_ts_sec v = Cstruct.LE.get_uint32 v 0
let set_pcap_packet_ts_sec v x = Cstruct.LE.set_uint32 v 0 x
let get_pcap_packet_ts_usec v = Cstruct.LE.get_uint32 v 4
let set_pcap_packet_ts_usec v x = Cstruct.LE.set_uint32 v 4 x
let get_pcap_packet_incl_len v = Cstruct.LE.get_uint32 v 8
let set_pcap_packet_incl_len v x = Cstruct.LE.set_uint32 v 8 x
let get_pcap_packet_orig_len v = Cstruct.LE.get_uint32 v 12
let set_pcap_packet_orig_len v x = Cstruct.LE.set_uint32 v 12 x
let sizeof_ethernet = 14
let get_ethernet_dst src = Cstruct.sub src 0 6
let copy_ethernet_dst src = Cstruct.copy src 0 6
let set_ethernet_dst src srcoff dst =
Cstruct.blit_from_string src srcoff dst 0 6
let blit_ethernet_dst src srcoff dst = Cstruct.blit src srcoff dst 0 6
let get_ethernet_src src = Cstruct.sub src 6 6
let copy_ethernet_src src = Cstruct.copy src 6 6
let set_ethernet_src src srcoff dst =
Cstruct.blit_from_string src srcoff dst 6 6
let blit_ethernet_src src srcoff dst = Cstruct.blit src srcoff dst 6 6
let get_ethernet_ethertype v = Cstruct.BE.get_uint16 v 12
let set_ethernet_ethertype v x = Cstruct.BE.set_uint16 v 12 x
```
The `mli` file will have signatures of this form:
```
val sizeof_pcap_packet : int
val get_pcap_packet_ts_sec : Cstruct.t -> Cstruct.uint32
val set_pcap_packet_ts_sec : Cstruct.t -> Cstruct.uint32 -> unit
val get_pcap_packet_ts_usec : Cstruct.t -> Cstruct.uint32
val set_pcap_packet_ts_usec : Cstruct.t -> Cstruct.uint32 -> unit
val get_pcap_packet_incl_len : Cstruct.t -> Cstruct.uint32
val set_pcap_packet_incl_len : Cstruct.t -> Cstruct.uint32 -> unit
val get_pcap_packet_orig_len : Cstruct.t -> Cstruct.uint32
val set_pcap_packet_orig_len : Cstruct.t -> Cstruct.uint32 -> unit
val hexdump_pcap_packet_to_buffer : Buffer.t -> pcap_packet -> unit
val hexdump_pcap_packet : Cstruct.t -> unit
val sizeof_ethernet : int
val get_ethernet_dst : Cstruct.t -> Cstruct.t
val copy_ethernet_dst : Cstruct.t -> string
val set_ethernet_dst : string -> int -> Cstruct.t -> unit
val blit_ethernet_dst : Cstruct.t -> int -> Cstruct.t -> unit
val get_ethernet_src : Cstruct.t -> Cstruct.t
val copy_ethernet_src : Cstruct.t -> string
val set_ethernet_src : string -> int -> Cstruct.t -> unit
val blit_ethernet_src : Cstruct.t -> int -> Cstruct.t -> unit
val get_ethernet_ethertype : Cstruct.t -> Cstruct.uint16
val set_ethernet_ethertype : Cstruct.t -> Cstruct.uint16 -> unit
val hexdump_ethernet_to_buffer : Buffer.t -> Cstruct.t -> unit
val hexdump_ethernet : Cstruct.t -> unit
```
The `hexdump` functions above are convenient pretty-printing functions
to help you debug, and aren't intended to be high performance.
You can also declare C-like enums:
```
[%%cenum
type foo32 =
| ONE32
| TWO32 [@id 0xfffffffel]
| THREE32
[@@uint32_t]
]
[%%cenum
type bar16 =
| ONE [@id 1]
| TWO
| FOUR [@id 4]
| FIVE
[@@uint16_t]
]
```
This generates signatures of the form:
```
type foo32 = | ONE32 | TWO32 | THREE32
val int_to_foo32 : int32 -> foo32 option
val foo32_to_int : foo32 -> int32
val foo32_to_string : foo32 -> string
val string_to_foo32 : string -> foo32 option
val compare_foo32 : foo32 -> foo32 -> int
type bar16 = | ONE | TWO | FOUR | FIVE
val int_to_bar16 : int -> bar16 option
val bar16_to_int : bar16 -> int
val bar16_to_string : bar16 -> string
val string_to_bar16 : string -> bar16 option
val compare_bar16 : bar16 -> bar16 -> int
```
Comparisons will be done relatively to the constructor ids.
You can also add a `(sexp)` decorator to output s-expression convertors
for use with the `sexplib` library.
```
[%%cenum
type foo64 =
| ONE64
| TWO64
| THREE64
[@@uint64_t] [@@sexp]
]
```
And `sexp_of_foo64` and `foo64_of_sexp` functions will also be available.
The representation of the Sexp is the string representation of the enum.
If you do use the sexp decorator, then you will also need to add
`sexplib` to the dependency list for your package (both in the
`dune` file and the `opam` file).
Please see the `ppx_test/` directory for more in-depth examples.

51
unikernel/duniverse/ocaml-cstruct/async/async_cstruct.ml Normal file
View file

@ -0,0 +1,51 @@
(*
* Copyright (c) 2013 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Core
open Async
let to_bigsubstring t =
Bigsubstring.create
~pos:t.Cstruct.off
~len:t.Cstruct.len
t.Cstruct.buffer
let of_bigsubstring t =
Cstruct.of_bigarray
~off:(Bigsubstring.pos t)
~len:(Bigsubstring.length t)
(Bigsubstring.base t)
let read rd t =
Reader.read_bigsubstring rd (to_bigsubstring t)
let schedule_write wr t =
let open Cstruct in
Writer.schedule_bigstring ~pos:t.off ~len:t.len wr t.buffer
module Pipe = struct
let map_string rd wr =
let rd = Pipe.map rd ~f:Cstruct.to_string in
let rd',wr' = Pipe.create () in
don't_wait_for (Pipe.transfer rd' wr ~f:Cstruct.of_string);
rd,wr'
let map_bigsubstring rd wr =
let rd = Pipe.map rd ~f:to_bigsubstring in
let rd',wr' = Pipe.create () in
don't_wait_for (Pipe.transfer rd' wr ~f:of_bigsubstring);
rd,wr'
end

36
unikernel/duniverse/ocaml-cstruct/async/async_cstruct.mli Normal file
View file

@ -0,0 +1,36 @@
(*
* Copyright (c) 2013 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Core
open Async
val to_bigsubstring : Cstruct.t -> Bigsubstring.t
val of_bigsubstring : Bigsubstring.t -> Cstruct.t
val read: Reader.t -> Cstruct.t -> int Reader.Read_result.t Deferred.t
val schedule_write: Writer.t -> Cstruct.t -> unit
module Pipe : sig
val map_string :
Cstruct.t Pipe.Reader.t ->
Cstruct.t Pipe.Writer.t ->
(string Pipe.Reader.t * string Pipe.Writer.t)
val map_bigsubstring :
Cstruct.t Pipe.Reader.t ->
Cstruct.t Pipe.Writer.t ->
(Bigsubstring.t Pipe.Reader.t * Bigsubstring.t Pipe.Writer.t)
end

5
unikernel/duniverse/ocaml-cstruct/async/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name async_cstruct)
(wrapped false)
(public_name cstruct-async)
(libraries core cstruct async async_unix))

29
unikernel/duniverse/ocaml-cstruct/cstruct-async.opam Normal file
View file

@ -0,0 +1,29 @@
version: "6.2.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: ["Anil Madhavapeddy" "Richard Mortier" "Thomas Gazagnaire"
"Pierre Chambart" "David Kaloper" "Jeremy Yallop" "David Scott"
"Mindy Preston" "Thomas Leonard" "Etienne Millon" ]
homepage: "https://github.com/mirage/ocaml-cstruct"
license: "ISC"
dev-repo: "git+https://github.com/mirage/ocaml-cstruct.git"
bug-reports: "https://github.com/mirage/ocaml-cstruct/issues"
tags: [ "org:mirage" "org:ocamllabs" ]
doc: "https://mirage.github.io/ocaml-cstruct/"
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
]
depends: [
"ocaml" {>= "4.08.0"}
"dune" {>= "2.0.0"}
"async" {>= "v0.9.0"}
"async_unix" {>= "v0.9.0"}
"core" {>= "v0.9.0"}
"cstruct" {=version}
]
synopsis: "Access C-like structures directly from OCaml"
description: """
Cstruct is a library and syntax extension to make it easier to access C-like
structures directly from OCaml. It supports both reading and writing to these
structures, and they are accessed via the `Bigarray` module."""

31
unikernel/duniverse/ocaml-cstruct/cstruct-lwt.opam Normal file
View file

@ -0,0 +1,31 @@
version: "6.2.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: ["Anil Madhavapeddy" "Richard Mortier" "Thomas Gazagnaire"
"Pierre Chambart" "David Kaloper" "Jeremy Yallop" "David Scott"
"Mindy Preston" "Thomas Leonard" "Etienne Millon" ]
homepage: "https://github.com/mirage/ocaml-cstruct"
license: "ISC"
dev-repo: "git+https://github.com/mirage/ocaml-cstruct.git"
bug-reports: "https://github.com/mirage/ocaml-cstruct/issues"
doc: "https://mirage.github.io/ocaml-cstruct/"
tags: [ "org:mirage" "org:ocamllabs" ]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
]
depends: [
"ocaml" {>= "4.08.0"}
"base-unix"
"dune" {>= "2.0.0"}
"lwt"
"cstruct" {=version}
]
synopsis: "Access C-like structures directly from OCaml"
description: """
Cstruct is a library and syntax extension to make it easier to access C-like
structures directly from OCaml. It supports both reading and writing to these
structures, and they are accessed via the `Bigarray` module."""
url {
src: "git+https://github.com/mirage/ocaml-cstruct.git"
}

32
unikernel/duniverse/ocaml-cstruct/cstruct-sexp.opam Normal file
View file

@ -0,0 +1,32 @@
version: "6.2.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: ["Anil Madhavapeddy" "Richard Mortier" "Thomas Gazagnaire"
"Pierre Chambart" "David Kaloper" "Jeremy Yallop" "David Scott"
"Mindy Preston" "Thomas Leonard" "Anton Kochkov" "Etienne Millon" ]
homepage: "https://github.com/mirage/ocaml-cstruct"
license: "ISC"
dev-repo: "git+https://github.com/mirage/ocaml-cstruct.git"
bug-reports: "https://github.com/mirage/ocaml-cstruct/issues"
doc: "https://mirage.github.io/ocaml-cstruct/"
tags: [ "org:mirage" "org:ocamllabs" ]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
depends: [
"ocaml" {>= "4.08.0"}
"dune" {>= "2.0.0"}
"sexplib"
"cstruct" {=version}
"alcotest" {with-test}
]
synopsis: "S-expression serialisers for C-like structures"
description: """
Cstruct is a library and syntax extension to make it easier to access C-like
structures directly from OCaml. It supports both reading and writing to these
structures, and they are accessed via the `Bigarray` module.
This library provides Sexplib serialisers for the Cstruct.t values."""

30
unikernel/duniverse/ocaml-cstruct/cstruct-unix.opam Normal file
View file

@ -0,0 +1,30 @@
version: "6.2.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: ["Anil Madhavapeddy" "Richard Mortier" "Thomas Gazagnaire"
"Pierre Chambart" "David Kaloper" "Jeremy Yallop" "David Scott"
"Mindy Preston" "Thomas Leonard" "Etienne Millon" ]
homepage: "https://github.com/mirage/ocaml-cstruct"
license: "ISC"
dev-repo: "git+https://github.com/mirage/ocaml-cstruct.git"
bug-reports: "https://github.com/mirage/ocaml-cstruct/issues"
doc: "https://mirage.github.io/ocaml-cstruct/"
tags: [ "org:mirage" "org:ocamllabs" ]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
]
depends: [
"ocaml" {>= "4.06.0"}
"dune" {>= "2.0.0"}
"base-unix"
"cstruct" {=version}
]
synopsis: "Access C-like structures directly from OCaml"
description: """
Cstruct is a library and syntax extension to make it easier to access C-like
structures directly from OCaml. It supports both reading and writing to these
structures, and they are accessed via the `Bigarray` module.
"""

31
unikernel/duniverse/ocaml-cstruct/cstruct.opam Normal file
View file

@ -0,0 +1,31 @@
version: "6.2.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: ["Anil Madhavapeddy" "Richard Mortier" "Thomas Gazagnaire"
"Pierre Chambart" "David Kaloper" "Jeremy Yallop" "David Scott"
"Mindy Preston" "Thomas Leonard" "Anton Kochkov" "Etienne Millon" ]
homepage: "https://github.com/mirage/ocaml-cstruct"
license: "ISC"
dev-repo: "git+https://github.com/mirage/ocaml-cstruct.git"
bug-reports: "https://github.com/mirage/ocaml-cstruct/issues"
doc: "https://mirage.github.io/ocaml-cstruct/"
tags: [ "org:mirage" "org:ocamllabs" ]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
depends: [
"ocaml" {>= "4.08.0"}
"dune" {>= "2.0.0"}
"alcotest" {with-test}
"fmt" {>= "0.8.9"}
"crowbar" {with-test}
]
conflicts: [ "js_of_ocaml" {<"3.5.0"} ]
synopsis: "Access C-like structures directly from OCaml"
description: """
Cstruct is a library and syntax extension to make it easier to access C-like
structures directly from OCaml. It supports both reading and writing to these
structures, and they are accessed via the `Bigarray` module."""

6
unikernel/duniverse/ocaml-cstruct/dune-project Normal file
View file

@ -0,0 +1,6 @@
(lang dune 2.0)
(allow_approximate_merlin)
(name cstruct)
(version v6.2.0)

12
unikernel/duniverse/ocaml-cstruct/fuzz/dune Normal file
View file

@ -0,0 +1,12 @@
(executable
(name fuzz)
(libraries cstruct bigarray cstruct-sexp crowbar fmt))
(rule
(alias fuzz)
(deps
fuzz.exe
(source_tree input))
(action
(run timeout --preserve-status 30m bun -v --input=input --output=output --
./fuzz.exe)))

178
unikernel/duniverse/ocaml-cstruct/fuzz/fuzz.ml Normal file
View file

@ -0,0 +1,178 @@
open Crowbar
[@@@warning "-3"]
let create x =
match Cstruct.create x with
| c -> assert (x >= 0); c
| exception Invalid_argument _ -> assert (x <= 0); bad_test ()
let create_sub x start len =
try
let c = Cstruct.create_unsafe x in
for i = 0 to len - 1 do
Cstruct.set_uint8 c i i
done;
Cstruct.sub c start len
with Invalid_argument _ -> bad_test ()
let cstruct = choose [
map [int8] create;
map [range 0x10000; int; int] create_sub;
]
let bytes = map [bytes] Bytes.unsafe_of_string
let buffer = map [uint8] Bigarray.(Array1.create Char c_layout)
let pp_cstruct f c = Format.pp_print_string f (Cstruct.debug c)
let check_within ~base x =
check Cstruct.(base.off <= x.off);
check Cstruct.(base.off + base.len >= x.off + x.len);
check Cstruct.(x.len >= 0 && x.len <= base.len)
let () =
(* assert (Array.length Sys.argv = 2); (* Prevent accidentally running in quickcheck mode *) *)
add_test ~name:"blit" [cstruct; int; cstruct; int; int] (fun src srcoff dst dstoff len ->
try Cstruct.blit src srcoff dst dstoff len
with Invalid_argument _ ->
check (srcoff < 0 || srcoff > Cstruct.length src ||
dstoff < 0 || dstoff > Cstruct.length src ||
len < 0 ||
len > Cstruct.length src - srcoff ||
len > Cstruct.length dst - dstoff)
);
add_test ~name:"sexp" [buffer] (fun b ->
b |> Cstruct_sexp.sexp_of_buffer |> Cstruct_sexp.buffer_of_sexp
|> check_eq
~cmp:(fun x y -> Cstruct.compare (Cstruct.of_bigarray x) (Cstruct.of_bigarray y))
b
);
add_test ~name:"of_bigarray" [buffer; option int; option int] (fun b off len ->
match Cstruct.of_bigarray b ?off ?len with
| c -> check (Cstruct.length c <= Bigarray.Array1.dim b)
| exception Invalid_argument _ -> ()
);
add_test ~name:"get_char" [cstruct; int] (fun c off ->
let in_range = off >= 0 && off < Cstruct.length c in
match Cstruct.get_char c off with
| _ -> check in_range
| exception Invalid_argument _ -> check (not in_range)
);
add_test ~name:"set_char" [cstruct; int] (fun c off ->
let in_range = off >= 0 && off < Cstruct.length c in
match Cstruct.set_char c off 'x' with
| () -> check in_range
| exception Invalid_argument _ -> check (not in_range)
);
add_test ~name:"sub" [cstruct; int; int] (fun base off len ->
match Cstruct.sub base off len with
| sub ->
check_within ~base sub;
check (Cstruct.length sub = len)
| exception Invalid_argument _ ->
check (off < 0 || len < 0 || off + len < 0 || off + len > Cstruct.length base)
);
add_test ~name:"shift" [cstruct; int] (fun base off ->
match Cstruct.shift base off with
| sub ->
check_within ~base sub;
check (Cstruct.length sub = max (Cstruct.length base - off) 0);
| exception Invalid_argument _ -> check (off < 0 || off > Cstruct.length base)
);
add_test ~name:"shiftv" [list cstruct; int] (fun ts n ->
match Cstruct.shiftv ts n with
| exception Invalid_argument _ -> check (n < 0 || n > Cstruct.lenv ts)
| ts' ->
assert (Cstruct.equal (Cstruct.concat ts') (Cstruct.shift (Cstruct.concat ts) n));
assert ((Cstruct.lenv ts = n) = (ts' = []));
match ts' with
| hd :: _ -> assert (not (Cstruct.is_empty hd))
| [] -> ()
);
add_test ~name:"copy" [cstruct; int; int] (fun base off len ->
match Cstruct.copy base off len with
| x ->
check (String.length x = len);
check (String.equal x (Cstruct.sub base off len |> Cstruct.to_string))
| exception Invalid_argument _ ->
check (off < 0 || len < 0 || off + len < 0 || off + len > Cstruct.length base)
);
add_test ~name:"blit_from_bytes" [bytes; int; cstruct; int; int] (fun src srcoff dst dstoff len ->
match Cstruct.blit_from_bytes src srcoff dst dstoff len with
| () -> check (Cstruct.equal (Cstruct.sub (Cstruct.of_bytes src) srcoff len)
(Cstruct.sub dst dstoff len))
| exception Invalid_argument _ ->
check (srcoff < 0 || srcoff > Bytes.length src ||
dstoff < 0 || dstoff > Bytes.length src ||
len < 0 ||
len > Bytes.length src - srcoff ||
len > Cstruct.length dst - dstoff)
);
add_test ~name:"blit_to_bytes" [cstruct; int; bytes; int; int] (fun src srcoff dst dstoff len ->
match Cstruct.blit_to_bytes src srcoff dst dstoff len with
| () -> check (Cstruct.equal (Cstruct.sub src srcoff len)
(Cstruct.sub (Cstruct.of_bytes dst) dstoff len))
| exception Invalid_argument _ ->
check (srcoff < 0 || srcoff > Cstruct.length src ||
dstoff < 0 || dstoff > Cstruct.length src ||
len < 0 ||
len > Cstruct.length src - srcoff ||
len > Bytes.length dst - dstoff)
);
add_test ~name:"memset" [cstruct; int; int] (fun c x i ->
guard (i >= 0 && i < Cstruct.length c);
Cstruct.memset c x;
check (Cstruct.get_uint8 c i = x land 0xff)
);
add_test ~name:"split" [cstruct; option int; int] (fun base start len ->
match Cstruct.split ?start base len with
| c1, c2 ->
check_within ~base c1;
check_within ~base c2;
let start = match start with None -> 0 | Some x -> x in
check (Cstruct.equal (Cstruct.sub base start len) c1);
check (Cstruct.equal (Cstruct.shift base (start + len)) c2)
| exception Invalid_argument _ -> ()
);
add_test ~name:"BE.set_uint64" [cstruct; int] (fun c off ->
let in_range = off >= 0 && off < Cstruct.length c - 7 in
match Cstruct.BE.set_uint64 c off 42L with
| () -> check in_range
| exception Invalid_argument _ -> check (not in_range)
);
add_test ~name:"lenv" [list cstruct] (fun cs ->
check (Cstruct.lenv cs >= 0)
);
add_test ~name:"copyv" [list cstruct] (fun cs ->
check (String.equal (Cstruct.copyv cs) (Cstruct.concat cs |> Cstruct.to_string))
);
add_test ~name:"fillv" [list cstruct; cstruct] (fun src dst ->
let copied, rest = Cstruct.fillv ~src ~dst in
check (copied + Cstruct.lenv rest = Cstruct.lenv src);
(* OCaml tends to underestimate how much space bigarrays are using: *)
Gc.minor ()
);
add_test ~name:"concat" [list cstruct] (fun cs ->
let x = Cstruct.concat cs in
check (Cstruct.length x = Cstruct.lenv cs)
);
add_test ~name:"span" [ cstruct; list char ] (fun cs p ->
let sat chr = List.exists ((=) chr) p in
let a, b = Cstruct.span ~sat cs in
let r = Cstruct.concat [ a; b ] in
check (Cstruct.to_string r = Cstruct.to_string cs));
add_test ~name:"cut" [ cstruct; cstruct; ] (fun buf sep ->
guard (Cstruct.length sep > 0);
( match Cstruct.cut ~sep buf with
| Some (l, r) ->
let r = Cstruct.concat [ l; sep; r; ] in
check (Cstruct.to_string r = Cstruct.to_string buf)
| None -> () ));
add_test ~name:"cuts" [ cstruct; cstruct; ] (fun buf sep ->
guard (Cstruct.length sep > 0);
let lst = Cstruct.cuts ~sep buf in
let lst = List.map Cstruct.to_string lst in
let res = String.concat (Cstruct.to_string sep) lst in
check (res = Cstruct.to_string buf));

1
unikernel/duniverse/ocaml-cstruct/fuzz/input/start Normal file
View file

@ -0,0 +1 @@
bactrian

53
unikernel/duniverse/ocaml-cstruct/lib/cstruct.js Normal file
View file

@ -0,0 +1,53 @@
/*
* Copyright (c) 2015 Citrix Inc
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*/
//Provides: caml_blit_bigstring_to_bigstring
//Requires: caml_bigstring_blit_ba_to_ba
var caml_blit_bigstring_to_bigstring = caml_bigstring_blit_ba_to_ba
//Provides: caml_blit_bigstring_to_string
//Requires: caml_bigstring_blit_ba_to_bytes
var caml_blit_bigstring_to_string = caml_bigstring_blit_ba_to_bytes
//Provides: caml_blit_string_to_bigstring
//Requires: caml_bigstring_blit_string_to_ba
var caml_blit_string_to_bigstring = caml_bigstring_blit_string_to_ba
//Provides: caml_compare_bigstring
//Requires: caml_int_compare, caml_ba_get_1
function caml_compare_bigstring(buf1, buf1_off, buf2, buf2_off, len) {
var i, r;
for (i = 0; i < len; i++) {
r = caml_int_compare(caml_ba_get_1(buf1, buf1_off + i), caml_ba_get_1(buf2, buf2_off + i));
if (r != 0) return r;
}
return 0;
}
//Provides: caml_fill_bigstring
//Requires: caml_ba_set_1
function caml_fill_bigstring(buf, buf_off, buf_len, v) {
var i;
for (i = 0; i < buf_len; i++) {
caml_ba_set_1(buf, buf_off + i, v);
}
return 0;
}
//Provides: caml_check_alignment_bigstring
function caml_check_alignment_bigstring(buf, ofs, alignment) {
return true; // FIXME: No concept of a fixed buffer address?
}

963
unikernel/duniverse/ocaml-cstruct/lib/cstruct.ml Normal file
View file

@ -0,0 +1,963 @@
(*
* Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
type buffer = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
(* Note:
*
* We try to maintain the property that no constructed [t] can ever point out of
* its underlying buffer. This property is guarded by all of the constructing
* functions and the fact that the type is private, and used by various
* functions that would otherwise be completely unsafe.
*
* Furthermore, no operation on [t] is allowed to extend the view on the
* underlying Bigarray structure, only narrowing is allowed.
*
* All well-intended souls are kindly invited to cross-check that the code
* indeed maintains this invariant.
*)
type t = {
buffer: buffer;
off : int;
len : int;
}
let pp_t ppf t =
Format.fprintf ppf "[%d,%d](%d)" t.off t.len (Bigarray.Array1.dim t.buffer)
let string_t ppf str =
Format.fprintf ppf "[%d]" (String.length str)
let bytes_t ppf str =
Format.fprintf ppf "[%d]" (Bytes.length str)
let err fmt =
let b = Buffer.create 20 in (* for thread safety. *)
let ppf = Format.formatter_of_buffer b in
let k ppf = Format.pp_print_flush ppf (); invalid_arg (Buffer.contents b) in
Format.kfprintf k ppf fmt
let err_of_bigarray t = err "Cstruct.of_bigarray off=%d len=%d" t
let err_sub t = err "Cstruct.sub: %a off=%d len=%d" pp_t t
let err_shift t = err "Cstruct.shift %a %d" pp_t t
let err_shiftv n = err "Cstruct.shiftv short by %d" n
let err_copy_to_string caller t = err "Cstruct.%s %a off=%d len=%d" caller pp_t t
let err_to_hex_string t = err "Cstruct.to_hex_string %a off=%d len=%d" pp_t t
let err_blit_src src dst =
err "Cstruct.blit src=%a dst=%a src-off=%d len=%d" pp_t src pp_t dst
let err_blit_dst src dst =
err "Cstruct.blit src=%a dst=%a dst-off=%d len=%d" pp_t src pp_t dst
let err_blit_from_string_src src dst =
err "Cstruct.blit_from_string src=%a dst=%a src-off=%d len=%d"
string_t src pp_t dst
let err_blit_from_string_dst src dst =
err "Cstruct.blit_from_string src=%a dst=%a dst-off=%d len=%d"
string_t src pp_t dst
let err_blit_from_bytes_src src dst =
err "Cstruct.blit_from_bytes src=%a dst=%a src-off=%d len=%d"
bytes_t src pp_t dst
let err_blit_from_bytes_dst src dst =
err "Cstruct.blit_from_bytes src=%a dst=%a dst-off=%d len=%d"
bytes_t src pp_t dst
let err_blit_to_bytes_src src dst =
err "Cstruct.blit_to_bytes src=%a dst=%a src-off=%d len=%d"
pp_t src bytes_t dst
let err_blit_to_bytes_dst src dst=
err "Cstruct.blit_to_bytes src=%a dst=%a dst-off=%d len=%d"
pp_t src bytes_t dst
let err_invalid_bounds f =
err "invalid bounds in Cstruct.%s %a off=%d len=%d" f pp_t [@@inline never]
let err_split t = err "Cstruct.split %a start=%d off=%d" pp_t t
let err_iter t = err "Cstruct.iter %a i=%d len=%d" pp_t t
let of_bigarray ?(off=0) ?len buffer =
let dim = Bigarray.Array1.dim buffer in
let len =
match len with
| None -> dim - off
| Some len -> len in
if off < 0 || len < 0 || off + len < 0 || off + len > dim then err_of_bigarray off len
else { buffer; off; len }
let to_bigarray buffer =
Bigarray.Array1.sub buffer.buffer buffer.off buffer.len
let create_unsafe len =
let buffer = Bigarray.(Array1.create char c_layout len) in
{ buffer ; len ; off = 0 }
let check_bounds t len =
len >= 0 && Bigarray.Array1.dim t.buffer >= len
let empty = create_unsafe 0
external check_alignment_bigstring : buffer -> int -> int -> bool = "caml_check_alignment_bigstring"
let check_alignment t alignment =
if alignment > 0 then
check_alignment_bigstring t.buffer t.off alignment
else invalid_arg "check_alignment must be positive integer"
type byte = char
let byte (i:int) : byte = Char.chr i
let byte_to_int (b:byte) = int_of_char b
type uint8 = int
type uint16 = int
type uint32 = int32
type uint64 = int64
let debug t =
let max_len = Bigarray.Array1.dim t.buffer in
if t.off+t.len > max_len || t.len < 0 || t.off < 0 then (
Format.printf "ERROR: t.off+t.len=%d %a\n%!" (t.off+t.len) pp_t t;
assert false;
) else
Format.asprintf "%a" pp_t t
let sub t off len =
(* from https://github.com/mirage/ocaml-cstruct/pull/245
Cstruct.sub should select what a programmer intuitively expects a
sub-cstruct to be. I imagine holding out my hands, with the left
representing the start offset and the right the end. I think of a
sub-cstruct as any span within this range. If I move my left hand only to
the right (new_start >= t.off), and my right hand only to the left
(new_end <= old_end), and they don't cross (new_start <= new_end), then I
feel sure the result will be a valid sub-cstruct. And if I violate any one
of these constraints (e.g. moving my left hand further left), then I feel
sure that the result wouldn't be something I'd consider to be a sub-cstruct.
Wrapping considerations in modular arithmetic:
Note that if x is non-negative, and x + y wraps, then x + y must be
negative. This is easy to see with modular arithmetic because if y is
negative then the two arguments will cancel to some degree the result
cannot be further from zero than one of the arguments. If y is positive
then x + y can wrap, but even max_int + max_int doesn't wrap all the way to
zero.
The three possibly-wrapping operations are:
new_start = t.off + off. t.off is non-negative so if this wraps then
new_start will be negative and will fail the new_start >= t.off test.
new_end = new_start + len. The above test ensures that new_start is
non-negative in any successful return. So if this wraps then new_end will
be negative and will fail the new_start <= new_end test.
old_end = t.off + t.len. This uses only the existing trusted values. It
could only wrap if the underlying bigarray had a negative length! *)
let new_start = t.off + off in
let new_end = new_start + len in
let old_end = t.off + t.len in
if new_start >= t.off && new_end <= old_end && new_start <= new_end then
{ t with off = new_start ; len }
else
err_sub t off len
let shift t amount =
let off = t.off + amount in
let len = t.len - amount in
if amount < 0 || amount > t.len || not (check_bounds t (off+len)) then
err_shift t amount
else { t with off; len }
let rec skip_empty = function
| t :: ts when t.len = 0 -> skip_empty ts
| x -> x
let rec shiftv ts = function
| 0 -> skip_empty ts
| n ->
match ts with
| [] -> err_shiftv n
| t :: ts when n >= t.len -> shiftv ts (n - t.len)
| t :: ts -> shift t n :: ts
external unsafe_blit_bigstring_to_bigstring : buffer -> int -> buffer -> int -> int -> unit = "caml_blit_bigstring_to_bigstring" [@@noalloc]
external unsafe_blit_string_to_bigstring : string -> int -> buffer -> int -> int -> unit = "caml_blit_string_to_bigstring" [@@noalloc]
external unsafe_blit_bytes_to_bigstring : Bytes.t -> int -> buffer -> int -> int -> unit = "caml_blit_string_to_bigstring" [@@noalloc]
external unsafe_blit_bigstring_to_bytes : buffer -> int -> Bytes.t -> int -> int -> unit = "caml_blit_bigstring_to_string" [@@noalloc]
external unsafe_compare_bigstring : buffer -> int -> buffer -> int -> int -> int = "caml_compare_bigstring" [@@noalloc]
external unsafe_fill_bigstring : buffer -> int -> int -> int -> unit = "caml_fill_bigstring" [@@noalloc]
let copy_to_string caller src srcoff len =
if len < 0 || srcoff < 0 || src.len - srcoff < len then
err_copy_to_string caller src srcoff len
else
let b = Bytes.create len in
unsafe_blit_bigstring_to_bytes src.buffer (src.off+srcoff) b 0 len;
(* The following call is safe, since b is not visible elsewhere. *)
Bytes.unsafe_to_string b
let copy = copy_to_string "copy"
let blit src srcoff dst dstoff len =
if len < 0 || srcoff < 0 || src.len - srcoff < len then
err_blit_src src dst srcoff len
else if dstoff < 0 || dst.len - dstoff < len then
err_blit_dst src dst dstoff len
else
unsafe_blit_bigstring_to_bigstring src.buffer (src.off+srcoff) dst.buffer
(dst.off+dstoff) len
let sub_copy cstr off len : t =
let cstr2 = create_unsafe len in
blit cstr off cstr2 0 len;
cstr2
let blit_from_string src srcoff dst dstoff len =
if len < 0 || srcoff < 0 || dstoff < 0 || String.length src - srcoff < len then
err_blit_from_string_src src dst srcoff len
else if dst.len - dstoff < len then
err_blit_from_string_dst src dst dstoff len
else
unsafe_blit_string_to_bigstring src srcoff dst.buffer (dst.off+dstoff) len
let blit_from_bytes src srcoff dst dstoff len =
if len < 0 || srcoff < 0 || dstoff < 0 || Bytes.length src - srcoff < len then
err_blit_from_bytes_src src dst srcoff len
else if dst.len - dstoff < len then
err_blit_from_bytes_dst src dst dstoff len
else
unsafe_blit_bytes_to_bigstring src srcoff dst.buffer (dst.off+dstoff) len
let blit_to_bytes src srcoff dst dstoff len =
if len < 0 || srcoff < 0 || dstoff < 0 || src.len - srcoff < len then
err_blit_to_bytes_src src dst srcoff len
else if Bytes.length dst - dstoff < len then
err_blit_to_bytes_dst src dst dstoff len
else
unsafe_blit_bigstring_to_bytes src.buffer (src.off+srcoff) dst dstoff len
let compare t1 t2 =
let l1 = t1.len
and l2 = t2.len in
match compare l1 l2 with
| 0 ->
( match unsafe_compare_bigstring t1.buffer t1.off t2.buffer t2.off l1 with
| 0 -> 0
| r -> if r < 0 then -1 else 1 )
| r -> r
let equal t1 t2 = compare t1 t2 = 0
(* Note that this is only safe as long as all [t]s are coherent. *)
let memset t x = unsafe_fill_bigstring t.buffer t.off t.len x
let create len =
let t = create_unsafe len in
memset t 0;
t
let set_uint8 t i c =
if i >= t.len || i < 0 then err_invalid_bounds "set_uint8" t i 1
else Bigarray.Array1.set t.buffer (t.off+i) (Char.unsafe_chr c)
let set_char t i c =
if i >= t.len || i < 0 then err_invalid_bounds "set_char" t i 1
else Bigarray.Array1.set t.buffer (t.off+i) c
let get_uint8 t i =
if i >= t.len || i < 0 then err_invalid_bounds "get_uint8" t i 1
else Char.code (Bigarray.Array1.get t.buffer (t.off+i))
let get_char t i =
if i >= t.len || i < 0 then err_invalid_bounds "get_char" t i 1
else Bigarray.Array1.get t.buffer (t.off+i)
external ba_set_int16 : buffer -> int -> uint16 -> unit = "%caml_bigstring_set16u"
external ba_set_int32 : buffer -> int -> uint32 -> unit = "%caml_bigstring_set32u"
external ba_set_int64 : buffer -> int -> uint64 -> unit = "%caml_bigstring_set64u"
external ba_get_int16 : buffer -> int -> uint16 = "%caml_bigstring_get16u"
external ba_get_int32 : buffer -> int -> uint32 = "%caml_bigstring_get32u"
external ba_get_int64 : buffer -> int -> uint64 = "%caml_bigstring_get64u"
external swap16 : int -> int = "%bswap16"
external swap32 : int32 -> int32 = "%bswap_int32"
external swap64 : int64 -> int64 = "%bswap_int64"
let set_uint16 swap p t i c =
if i > t.len - 2 || i < 0 then err_invalid_bounds (p ^ ".set_uint16") t i 2
else ba_set_int16 t.buffer (t.off+i) (if swap then swap16 c else c) [@@inline]
let set_uint32 swap p t i c =
if i > t.len - 4 || i < 0 then err_invalid_bounds (p ^ ".set_uint32") t i 4
else ba_set_int32 t.buffer (t.off+i) (if swap then swap32 c else c) [@@inline]
let set_uint64 swap p t i c =
if i > t.len - 8 || i < 0 then err_invalid_bounds (p ^ ".set_uint64") t i 8
else ba_set_int64 t.buffer (t.off+i) (if swap then swap64 c else c) [@@inline]
let get_uint16 swap p t i =
if i > t.len - 2 || i < 0 then err_invalid_bounds (p ^ ".get_uint16") t i 2
else
let r = ba_get_int16 t.buffer (t.off+i) in
if swap then swap16 r else r [@@inline]
let get_uint32 swap p t i =
if i > t.len - 4 || i < 0 then err_invalid_bounds (p ^ ".get_uint32") t i 4
else
let r = ba_get_int32 t.buffer (t.off+i) in
if swap then swap32 r else r [@@inline]
let get_uint64 swap p t i =
if i > t.len - 8 || i < 0 then err_invalid_bounds (p ^ ".get_uint64") t i 8
else
let r = ba_get_int64 t.buffer (t.off+i) in
if swap then swap64 r else r [@@inline]
module BE = struct
let set_uint16 t i c = set_uint16 (not Sys.big_endian) "BE" t i c [@@inline]
let set_uint32 t i c = set_uint32 (not Sys.big_endian) "BE" t i c [@@inline]
let set_uint64 t i c = set_uint64 (not Sys.big_endian) "BE" t i c [@@inline]
let get_uint16 t i = get_uint16 (not Sys.big_endian) "BE" t i [@@inline]
let get_uint32 t i = get_uint32 (not Sys.big_endian) "BE" t i [@@inline]
let get_uint64 t i = get_uint64 (not Sys.big_endian) "BE" t i [@@inline]
end
module LE = struct
let set_uint16 t i c = set_uint16 Sys.big_endian "LE" t i c [@@inline]
let set_uint32 t i c = set_uint32 Sys.big_endian "LE" t i c [@@inline]
let set_uint64 t i c = set_uint64 Sys.big_endian "LE" t i c [@@inline]
let get_uint16 t i = get_uint16 Sys.big_endian "LE" t i [@@inline]
let get_uint32 t i = get_uint32 Sys.big_endian "LE" t i [@@inline]
let get_uint64 t i = get_uint64 Sys.big_endian "LE" t i [@@inline]
end
module HE = struct
let set_uint16 t i c = set_uint16 false "HE" t i c [@@inline]
let set_uint32 t i c = set_uint32 false "HE" t i c [@@inline]
let set_uint64 t i c = set_uint64 false "HE" t i c [@@inline]
let get_uint16 t i = get_uint16 false "HE" t i [@@inline]
let get_uint32 t i = get_uint32 false "HE" t i [@@inline]
let get_uint64 t i = get_uint64 false "HE" t i [@@inline]
end
let length { len ; _ } = len
(** [sum_lengths ~caller acc l] is [acc] plus the sum of the lengths
of the elements of [l]. Raises [Invalid_argument caller] if
arithmetic overflows. *)
let rec sum_lengths_aux ~caller acc = function
| [] -> acc
| h :: t ->
let sum = length h + acc in
if sum < acc then invalid_arg caller
else sum_lengths_aux ~caller sum t
let sum_lengths ~caller l = sum_lengths_aux ~caller 0 l
let lenv l = sum_lengths ~caller:"Cstruct.lenv" l
let copyv ts =
let sz = sum_lengths ~caller:"Cstruct.copyv" ts in
let dst = Bytes.create sz in
let _ = List.fold_left
(fun off src ->
let x = length src in
unsafe_blit_bigstring_to_bytes src.buffer src.off dst off x;
off + x
) 0 ts in
(* The following call is safe, since dst is not visible elsewhere. *)
Bytes.unsafe_to_string dst
let fillv ~src ~dst =
let rec aux dst n = function
| [] -> n, []
| hd::tl ->
let avail = length dst in
let first = length hd in
if first <= avail then (
blit hd 0 dst 0 first;
aux (shift dst first) (n + first) tl
) else (
blit hd 0 dst 0 avail;
let rest_hd = shift hd avail in
(n + avail, rest_hd :: tl)
) in
aux dst 0 src
let to_string ?(off=0) ?len:sz t =
let len = match sz with None -> length t - off | Some l -> l in
copy_to_string "to_string" t off len
let to_hex_string ?(off=0) ?len:sz t : string =
let[@inline] nibble_to_char (i:int) : char =
if i < 10 then
Char.chr (i + Char.code '0')
else
Char.chr (i - 10 + Char.code 'a')
in
let len = match sz with None -> length t - off | Some l -> l in
if len < 0 || off < 0 || t.len - off < len then
err_to_hex_string t off len
else (
let out = Bytes.create (2 * len) in
for i=0 to len-1 do
let c = Char.code @@ Bigarray.Array1.get t.buffer (i+t.off+off) in
Bytes.set out (2*i) (nibble_to_char (c lsr 4));
Bytes.set out (2*i+1) (nibble_to_char (c land 0xf));
done;
Bytes.unsafe_to_string out
)
let to_bytes ?off ?len t =
Bytes.unsafe_of_string (to_string ?off ?len t)
let [@inline always] of_data_abstract blitfun lenfun ?allocator ?(off=0) ?len buf =
let buflen =
match len with
| None -> lenfun buf - off
| Some len -> len in
match allocator with
| None ->
let c = create_unsafe buflen in
blitfun buf off c 0 buflen;
c
| Some fn ->
let c = fn buflen in
blitfun buf off c 0 buflen;
{ c with len = buflen }
let of_string ?allocator ?off ?len buf =
of_data_abstract blit_from_string String.length ?allocator ?off ?len buf
let of_bytes ?allocator ?off ?len buf =
of_data_abstract blit_from_bytes Bytes.length ?allocator ?off ?len buf
let of_hex ?(off=0) ?len str =
let str =
let l = match len with None -> String.length str - off | Some l -> l in
String.sub str off l
in
let string_fold ~f ~z str =
let st = ref z in
( String.iter (fun c -> st := f !st c) str ; !st )
in
let hexdigit p = function
| 'a' .. 'f' as x -> int_of_char x - 87
| 'A' .. 'F' as x -> int_of_char x - 55
| '0' .. '9' as x -> int_of_char x - 48
| x ->
Format.ksprintf invalid_arg "of_hex: invalid character at pos %d: %C" p x
in
let whitespace = function
| ' ' | '\t' | '\r' | '\n' -> true
| _ -> false
in
match
string_fold
~f:(fun (cs, i, p, acc) ->
let p' = succ p in
function
| char when whitespace char -> (cs, i, p', acc)
| char ->
match acc, hexdigit p char with
| (None , x) -> (cs, i, p', Some (x lsl 4))
| (Some y, x) -> set_uint8 cs i (x lor y) ; (cs, succ i, p', None))
~z:(create_unsafe (String.length str lsr 1), 0, 0, None)
str
with
| _ , _, _, Some _ ->
Format.ksprintf invalid_arg "of_hex: odd numbers of characters"
| cs, i, _, _ -> sub cs 0 i
let hexdump_pp fmt t =
let before fmt =
function
| 0 -> ()
| 8 -> Format.fprintf fmt " ";
| _ -> Format.fprintf fmt " "
in
let after fmt =
function
| 15 -> Format.fprintf fmt "@;"
| _ -> ()
in
Format.pp_open_vbox fmt 0 ;
for i = 0 to length t - 1 do
let column = i mod 16 in
let c = Char.code (Bigarray.Array1.get t.buffer (t.off+i)) in
Format.fprintf fmt "%a%.2x%a" before column c after column
done ;
Format.pp_close_box fmt ()
let hexdump = Format.printf "@\n%a@." hexdump_pp
let hexdump_to_buffer buf t =
let f = Format.formatter_of_buffer buf in
Format.fprintf f "@\n%a@." hexdump_pp t
let split ?(start=0) t off =
try
let header =sub t start off in
let body = sub t (start+off) (length t - off - start) in
header, body
with Invalid_argument _ -> err_split t start off
type 'a iter = unit -> 'a option
let iter lenfn pfn t =
let body = ref (Some t) in
let i = ref 0 in
fun () ->
match !body with
|Some buf when length buf = 0 ->
body := None;
None
|Some buf -> begin
match lenfn buf with
|None ->
body := None;
None
|Some plen ->
incr i;
let p,rest =
try split buf plen with Invalid_argument _ -> err_iter buf !i plen
in
body := Some rest;
Some (pfn p)
end
|None -> None
let rec fold f next acc = match next () with
| None -> acc
| Some v -> fold f next (f acc v)
let append cs1 cs2 =
let l1 = length cs1 and l2 = length cs2 in
let cs = create_unsafe (l1 + l2) in
blit cs1 0 cs 0 l1 ;
blit cs2 0 cs l1 l2 ;
cs
let concat = function
| [] -> create_unsafe 0
| [cs] -> cs
| css ->
let result = create_unsafe (sum_lengths ~caller:"Cstruct.concat" css) in
let aux off cs =
let n = length cs in
blit cs 0 result off n ;
off + n in
ignore @@ List.fold_left aux 0 css ;
result
let rev t =
let n = length t in
let out = create_unsafe n in
for i_src = 0 to n - 1 do
let byte = get_uint8 t i_src in
let i_dst = n - 1 - i_src in
set_uint8 out i_dst byte
done;
out
(* Convenience function. *)
external unsafe_blit_string_to_bigstring
: string -> int -> buffer -> int -> int -> unit
= "caml_blit_string_to_bigstring"
[@@noalloc]
let get { buffer; off; len; } zidx =
if zidx < 0 || zidx >= len then invalid_arg "index out of bounds" ;
Bigarray.Array1.get buffer (off + zidx)
let get_byte { buffer; off; len; } zidx =
if zidx < 0 || zidx >= len then invalid_arg "index out of bounds" ;
Char.code (Bigarray.Array1.get buffer (off + zidx))
let string ?(off= 0) ?len str =
let str_len = String.length str in
let len = match len with None -> str_len | Some len -> len in
if off < 0 || len < 0 || off + len > str_len then invalid_arg "index out of bounds" ;
let buffer = Bigarray.(Array1.create char c_layout str_len) in
unsafe_blit_string_to_bigstring str 0 buffer 0 str_len ;
of_bigarray ~off ~len buffer
let buffer ?(off= 0) ?len buffer =
let buffer_len = Bigarray.Array1.dim buffer in
let len = match len with None -> buffer_len - off | Some len -> len in
if off < 0 || len < 0 || off + len > buffer_len then invalid_arg "index out of bounds" ;
of_bigarray ~off ~len buffer
let start_pos { off; _ } = off
let stop_pos { off; len; _ } = off + len
let head ?(rev= false) ({ len; _ } as cs) =
if len = 0 then None
else Some (get_char cs (if rev then len - 1 else 0))
let tail ?(rev= false) ({ buffer; off; len; } as cs) =
if len = 0 then cs
else if rev then of_bigarray ~off ~len:(len - 2) buffer
else of_bigarray ~off:(off + 1) ~len:(len - 1) buffer
let is_empty { len; _ } = len = 0
let is_prefix ~affix:({ len= alen; _ } as affix)
({ len; _ } as cs) =
if alen > len then false
else
let max_zidx = alen - 1 in
let rec loop i =
if i > max_zidx then true
else if get_char affix i <> get_char cs i
then false else loop (succ i) in
loop 0
let is_infix ~affix:({ len= alen; _ } as affix)
({ len; _ } as cs) =
if alen > len then false
else
let max_zidx_a = alen - 1 in
let max_zidx_s = len - alen in
let rec loop i k =
if i > max_zidx_s then false
else if k > max_zidx_a then true
else if k > 0 then
if get_char affix k = get_char cs (i + k)
then loop i (succ k)
else loop (succ i) 0
else if get_char affix 0 = get_char cs i
then loop i 1
else loop (succ i) 0 in
loop 0 0
let is_suffix ~affix:({ len= alen; _ } as affix)
({ len; _ } as cs) =
if alen > len then false
else
let max_zidx = alen - 1 in
let max_zidx_a = alen - 1 in
let max_zidx_s = len - 1 in
let rec loop i =
if i > max_zidx then true
else if get_char affix (max_zidx_a - i) <> get_char cs (max_zidx_s - i)
then false else loop (succ i) in
loop 0
let for_all sat cs =
let rec go acc i =
if i < length cs
then go (sat (get_char cs i) && acc) (succ i)
else acc in
go true 0
let exists sat cs =
let rec go acc i =
if i < length cs
then go (sat (get_char cs i) || acc) (succ i)
else acc in
go false 0
let start { buffer; off; _ } =
of_bigarray buffer ~off ~len:0
let stop { buffer; off; len; } =
of_bigarray buffer ~off:(off + len) ~len:0
let is_white = function ' ' | '\t' .. '\r' -> true | _ -> false
let trim ?(drop = is_white) ({ buffer; off; len; } as cs) =
if len = 0 then cs
else
let max_zpos = len in
let max_zidx = len - 1 in
let rec left_pos i =
if i > max_zidx then max_zpos
else if drop (get_char cs i) then left_pos (succ i) else i in
let rec right_pos i =
if i < 0 then 0
else if drop (get_char cs i) then right_pos (pred i) else succ i in
let left = left_pos 0 in
if left = max_zpos
then of_bigarray buffer ~off:((off * 2 + len) / 2) ~len:0
else
let right = right_pos max_zidx in
if left = 0 && right = max_zpos then cs
else of_bigarray buffer ~off:(off + left) ~len:(right - left)
let fspan ~min ~max ~sat ({ buffer= v; off; len; } as cs) =
if min < 0 then invalid_arg "span: negative min" ;
if max < 0 then invalid_arg "span: negative max" ;
if min > max || max = 0 then (buffer ~off:off ~len:0 v, cs)
else
let max_zidx = len - 1 in
let max_zidx =
let k = max - 1 in
if k > max_zidx || k < 0 then max_zidx else k in
let need_zidx = min in
let rec loop i =
if i <= max_zidx && sat (get_char cs i) then loop (i + 1)
else if i < need_zidx || i = 0 then buffer ~off:off ~len:0 v, cs
else if i = len then (cs, buffer ~off:(off + len) ~len:0 v)
else buffer ~off:off ~len:i v, buffer ~off:(off + i) ~len:(len - i) v in
loop 0
let rspan ~min ~max ~sat ({ buffer= v; off; len; } as cs) =
if min < 0 then invalid_arg "span: negative min" ;
if max < 0 then invalid_arg "span: negative max" ;
if min > max || max = 0 then (cs, buffer ~off:(off + len) ~len:0 v)
else
let max_zidx = len - 1 in
let min_zidx =
let k = len - max in if k < 0 then 0 else k in
let need_zidx = len - min - 1 in
let rec loop i =
if i >= min_zidx && sat (get_char cs i) then loop (i - 1)
else if i > need_zidx || i = max_zidx then (cs, buffer ~off:(off + len) ~len:0 v)
else if i < 0 then (buffer ~off:off ~len:0 v, cs)
else (buffer ~off:off ~len:(i + 1) v, buffer ~off:(off + i + 1) ~len:(len - (i + 1)) v) in
loop max_zidx
let span ?(rev= false) ?(min= 0) ?(max= max_int) ?(sat= fun _ -> true) cs =
match rev with
| true -> rspan ~min ~max ~sat cs
| false -> fspan ~min ~max ~sat cs
let take ?(rev= false) ?min ?max ?sat cs =
(if rev then snd else fst) @@ span ~rev ?min ?max ?sat cs
let drop ?(rev= false) ?min ?max ?sat cs =
(if rev then fst else snd) @@ span ~rev ?min ?max ?sat cs
let fcut ~sep:({ len= sep_len; _ } as sep)
({ buffer= v; off; len; } as cs) =
if sep_len = 0 then invalid_arg "cut: empty separator" ;
let max_sep_zidx = sep_len - 1 in
let max_s_zidx = len - sep_len in
let rec check_sep i k =
if k > max_sep_zidx
then Some (buffer ~off:off ~len:i v,
buffer ~off:(off + i + sep_len) ~len:(len - i - sep_len) v)
else if get_char cs (i + k) = get_char sep k
then check_sep i (k + 1)
else scan (i + 1)
and scan i =
if i > max_s_zidx then None
else if get_char cs i = get_char sep 0
then check_sep i 1
else scan (i + 1) in
scan 0
let rcut ~sep:({ len= sep_len; _ } as sep) ({ buffer= v; off; len; } as cs) =
if sep_len = 0 then invalid_arg "cut: empty separator" ;
let max_sep_zidx = sep_len - 1 in
let max_s_zidx = len - 1 in
let rec check_sep i k =
if k > max_sep_zidx then Some (buffer ~off:off ~len:i v,
buffer ~off:(off + i + sep_len) ~len:(len - i - sep_len) v)
else if get_char cs (i + k) = get_char sep k
then check_sep i (k + 1)
else rscan (i - 1)
and rscan i =
if i < 0 then None
else if get_char cs i = get_char sep 0
then check_sep i 1
else rscan (i - 1) in
rscan (max_s_zidx - max_sep_zidx)
let cut ?(rev= false) ~sep cs = match rev with
| true -> rcut ~sep cs
| false -> fcut ~sep cs
let add_sub ~no_empty buf ~off ~len acc =
if len = 0
then ( if no_empty then acc else buffer ~off ~len buf :: acc )
else buffer ~off ~len buf :: acc
let fcuts ~no_empty ~sep:({ len= sep_len; _ } as sep)
({ buffer; off; len; } as cs) =
if sep_len = 0 then invalid_arg "cuts: empty separator" ;
let max_sep_zidx = sep_len - 1 in
let max_s_zidx = len - sep_len in
let rec check_sep zanchor i k acc =
if k > max_sep_zidx
then
let new_start = i + sep_len in
scan new_start new_start (add_sub ~no_empty buffer ~off:(off + zanchor) ~len:(i - zanchor) acc)
else
if get_char cs (i + k) = get_char sep k
then check_sep zanchor i (k + 1) acc
else scan zanchor (i + 1) acc
and scan zanchor i acc =
if i > max_s_zidx
then
if zanchor = 0 then (if no_empty && len = 0 then [] else [ cs ])
else List.rev (add_sub ~no_empty buffer ~off:(off + zanchor) ~len:(len - zanchor) acc)
else
if get_char cs i = get_char sep 0
then check_sep zanchor i 1 acc
else scan zanchor (i + 1) acc in
scan 0 0 []
let rcuts ~no_empty ~sep:({ len= sep_len; _ } as sep)
({ buffer; len; _ } as cs) =
if sep_len = 0 then invalid_arg "cuts: empty separator" ;
let s_len = len in
let max_sep_zidx = sep_len - 1 in
let max_s_zidx = len - 1 in
let rec check_sep zanchor i k acc =
if k > max_sep_zidx
then let off = i + sep_len in
rscan i (i - sep_len) (add_sub ~no_empty buffer ~off ~len:(zanchor - off) acc)
else
if get_char cs (i + k) = get_char cs k
then check_sep zanchor i (k + 1) acc
else rscan zanchor (i - 1) acc
and rscan zanchor i acc =
if i < 0 then
if zanchor = s_len then ( if no_empty && s_len = 0 then [] else [ cs ])
else add_sub ~no_empty buffer ~off:0 ~len:zanchor acc
else
if get_char cs i = get_char sep 0
then check_sep zanchor i 1 acc
else rscan zanchor (i - 1) acc in
rscan s_len (max_s_zidx - max_sep_zidx) []
let cuts ?(rev= false) ?(empty= true) ~sep cs = match rev with
| true -> rcuts ~no_empty:(not empty) ~sep cs
| false -> fcuts ~no_empty:(not empty) ~sep cs
let fields ?(empty= false) ?(is_sep= is_white) ({ buffer; off; len; } as cs) =
let no_empty = not empty in
let max_pos = len in
let rec loop i end_pos acc =
if i < 0 then begin
if end_pos = len
then ( if no_empty && len = 0 then [] else [ cs ])
else add_sub ~no_empty buffer ~off:off ~len:(end_pos - (i + 1)) acc
end else begin
if not (is_sep (get_char cs i))
then loop (i - 1) end_pos acc
else loop (i - 1) i (add_sub ~no_empty buffer ~off:(off + i + 1) ~len:(end_pos - (i + 1)) acc)
end in
loop (max_pos - 1) max_pos []
let ffind sat ({ buffer= v; len; _ } as cs) =
let max_idx = len - 1 in
let rec loop i =
if i > max_idx then None
else if sat (get_char cs i)
then Some (buffer ~off:i ~len:1 v)
else loop (i + 1) in
loop 0
let rfind sat ({ buffer= v; len; _ } as cs) =
let rec loop i =
if i < 0 then None
else if sat (get_char cs i)
then Some (buffer ~off:i ~len:1 v)
else loop (i - 1) in
loop (len - 1)
let find ?(rev= false) sat cs = match rev with
| true -> rfind sat cs
| false -> ffind sat cs
let ffind_sub ~sub:({ len= sub_len; _ } as sub) ({ buffer= v; off; len; } as cs) =
if sub_len > len then None
else
let max_zidx_sub = sub_len - 1 in
let max_zidx_s = len - sub_len in
let rec loop i k =
if i > max_zidx_s then None
else if k > max_zidx_sub then Some (buffer v ~off:(off + i) ~len:sub_len)
else if k > 0
then ( if get_char sub k = get_char cs (i + k)
then loop i (k + 1)
else loop (i + 1) 0 )
else if get_char sub 0 = get_char cs i
then loop i 1
else loop (i + 1) 0 in
loop 0 0
let rfind_sub ~sub:({ len= sub_len; _ } as sub) ({ buffer= v; len; _ } as cs) =
if sub_len > len then None
else
let max_zidx_sub = sub_len - 1 in
let rec loop i k =
if i < 0 then None
else if k > max_zidx_sub then Some (buffer v ~off:i ~len:sub_len)
else if k > 0
then ( if get_char sub k = get_char cs (i + k)
then loop i (k + 1)
else loop (i - 1) 0 )
else if get_char sub 0 = get_char cs i
then loop i 1
else loop (i - 1) 0 in
loop (len - sub_len) 0
let find_sub ?(rev= false) ~sub cs = match rev with
| true -> rfind_sub ~sub cs
| false -> ffind_sub ~sub cs
let filter sat ({ len; _ } as cs) =
if len = 0 then empty
else
let b = create len in
let max_zidx = len - 1 in
let rec loop b k i =
if i > max_zidx
then (if k = len then b else sub b 0 k)
else
let chr = get_char cs i in
if sat chr then ( set_char b k chr ; loop b (k + 1) (i + 1))
else loop b k (i + 1) in
loop b 0 0
let filter_map f ({ len; _ } as cs) =
if len = 0 then empty
else
let b = create len in
let max_zidx = len - 1 in
let rec loop b k i =
if i > max_zidx
then (if k = len then b else sub b 0 k)
else match f (get_char cs i) with
| Some chr ->
set_char b i chr ;
loop b (k + 1) (i + 1)
| None ->
loop b k (i + 1) in
loop b 0 0
let map f ({ len; _ } as cs) =
if len = 0 then empty
else
let b = create len in
for i = 0 to len - 1 do
set_char b i (f (get_char cs i))
done ; b
let mapi f ({ len; _ } as cs) =
if len = 0 then empty
else
let b = create len in
for i = 0 to len - 1 do
set_char b i (f i (get_char cs i))
done ; b

838
unikernel/duniverse/ocaml-cstruct/lib/cstruct.mli Normal file
View file

@ -0,0 +1,838 @@
(*
* Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** Manipulate external memory buffers as C-like structures.
Cstruct is a library and ppx rewriter to make it easier to access C-like
structures directly from OCaml. It supports both reading and writing to these
memory buffers, and they are accessed via the [Bigarray] module.
The library interface below is intended to be used in conjunction with the
ppx rewriter that is also supplied with this library (in the [cstruct-ppx]
ocamlfind package).
An example description for the pcap packet format is:
{[
[%%cstruct
type pcap_header = {
magic_number: uint32_t; (* magic number *)
version_major: uint16_t; (* major version number *)
version_minor: uint16_t; (* minor version number *)
thiszone: uint32_t; (* GMT to local correction *)
sigfigs: uint32_t; (* accuracy of timestamps *)
snaplen: uint32_t; (* max length of captured packets, in octets *)
network: uint32_t; (* data link type *)
} [@@little_endian]
]
[%%cstruct
type pcap_packet = {
ts_sec: uint32_t; (* timestamp seconds *)
ts_usec: uint32_t; (* timestamp microseconds *)
incl_len: uint32_t; (* number of octets of packet saved in file *)
orig_len: uint32_t; (* actual length of packet *)
} [@@little_endian]
]
[%%cstruct
type ethernet = {
dst: uint8_t; [@len 6];
src: uint8_t; [@len 6];
ethertype: uint16_t;
} [@@big_endian]
]
[%%cstruct
type ipv4 = {
hlen_version: uint8_t;
tos: uint8_t;
len: uint16_t;
id: uint16_t;
off: uint16_t;
ttl: uint8_t;
proto: uint8_t;
csum: uint16_t;
src: uint8_t; [@len 4];
dst: uint8_t; [@len 4]
} [@@big_endian]
]
]}
These will expand to get and set functions for every field, with types
appropriate to the particular definition. For instance:
{[
val get_pcap_packet_ts_sec : Cstruct.t -> Cstruct.uint32
val set_pcap_packet_ts_sec : Cstruct.t -> Cstruct.uint32 -> unit
val get_pcap_packet_ts_usec : Cstruct.t -> Cstruct.uint32
val set_pcap_packet_ts_usec : Cstruct.t -> Cstruct.uint32 -> unit
val get_pcap_packet_incl_len : Cstruct.t -> Cstruct.uint32
val set_pcap_packet_incl_len : Cstruct.t -> Cstruct.uint32 -> unit
val get_pcap_packet_orig_len : Cstruct.t -> Cstruct.uint32
val set_pcap_packet_orig_len : Cstruct.t -> Cstruct.uint32 -> unit
val hexdump_pcap_packet_to_buffer : Buffer.t -> Cstruct.t -> unit
]}
The buffers generate a different set of functions. For the [ethernet]
definitions, we have:
{[
val sizeof_ethernet : int
val get_ethernet_dst : Cstruct.t -> Cstruct.t
val copy_ethernet_dst : Cstruct.t -> string
val set_ethernet_dst : string -> int -> Cstruct.t -> unit
val blit_ethernet_dst : Cstruct.t -> int -> Cstruct.t -> unit
val get_ethernet_src : Cstruct.t -> Cstruct.t
val copy_ethernet_src : Cstruct.t -> string
]}
You can also declare C-like enums:
{[
[%%cenum
type foo32 =
| ONE32
| TWO32 [@id 0xfffffffel]
| THREE32
[@@uint32_t]
]
[%%cenum
type bar16 =
| ONE [@id 1]
| TWO
| FOUR [@id 4
| FIVE
[@@uint16_t]
]
]}
This generates signatures of the form:
{[
type foo32 = | ONE32 | TWO32 | THREE32
val int_to_foo32 : int32 -> foo32 option
val foo32_to_int : foo32 -> int32
val foo32_to_string : foo32 -> string
val string_to_foo32 : string -> foo32 option
type bar16 = | ONE | TWO | FOUR | FIVE
val int_to_bar16 : int -> bar16 option
val bar16_to_int : bar16 -> int
val bar16_to_string : bar16 -> string
val string_to_bar16 : string -> bar16 option
]}
*)
(** {2 Base types } *)
type buffer = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
(** Type of a buffer. A cstruct is composed of an underlying buffer
and position/length within this buffer. *)
type t = private {
buffer: buffer;
off : int;
len : int;
}
(** Type of a cstruct. *)
type byte = char
(** A single byte type *)
val byte : int -> byte
(** [byte v] convert [v] to a single byte.
@raise Invalid_argument if [v] is negative or greater than 255. *)
type uint8 = int
(** 8-bit unsigned integer. The representation is currently an
unboxed OCaml integer. *)
type uint16 = int
(** 16-bit unsigned integer. The representation is currently an
unboxed OCaml integer. *)
type uint32 = int32
(** 32-bit unsigned integer. The representation is currently a
boxed OCaml int32. *)
type uint64 = int64
(** 64-bit unsigned integer. The representation is currently a
boxed OCaml int64. *)
(** {2 Creation and conversion} *)
val empty : t
(** [empty] is the cstruct of length 0. *)
val of_bigarray: ?off:int -> ?len:int -> buffer -> t
(** [of_bigarray ~off ~len b] is the cstruct contained in [b] starting
at offset [off] (default [0]) of length [len]
(default [Bigarray.Array1.dim b - off]). *)
val to_bigarray: t -> buffer
(** [to_bigarray t] converts a {!t} into a {!type:buffer} Bigarray, using
the Bigarray slicing to allocate a fresh array that preserves
sharing of the underlying buffer. *)
val create : int -> t
(** [create len] is a fresh cstruct of size [len] with an offset of 0,
filled with zero bytes. *)
val create_unsafe : int -> t
(** [create_unsafe len] is a cstruct of size [len] with an offset of 0.
Note that the returned cstruct will contain arbitrary data,
likely including the contents of previously-deallocated cstructs.
Beware!
Forgetting to replace this data could cause your application
to leak sensitive information.
*)
val of_string: ?allocator:(int -> t) -> ?off:int -> ?len:int -> string -> t
(** [of_string ~allocator ~off ~len str] is the cstruct representation of [str]
slice located at offset [off] (default [0]) and of length [len] (default
[String.length str - off]),
with the underlying buffer allocated by [alloc]. If [allocator] is not
provided, [create] is used.
@raise Invalid_argument if [off] or [len] is negative, or
[String.length str - off] < [len].
*)
val of_bytes: ?allocator:(int -> t) -> ?off:int -> ?len:int -> bytes -> t
(** [of_bytes ~allocator byt] is the cstruct representation of [byt]
slice located at offset [off] (default [0]) and of length [len] (default
[Bytes.length byt - off]),
with the underlying buffer allocated by [alloc]. If [allocator] is not
provided, [create] is used.
@raise Invalid_argument if [off] or [len] is negative, or
[Bytes.length str - off] < [len]. *)
val of_hex: ?off:int -> ?len:int -> string -> t
(** [of_hex ~off ~len str] is the cstruct [cs]. Every pair of hex-encoded
characters in [str] starting at offset [off] (default [0]) of length [len]
(default [String.length str - off]) are converted to one byte in [cs].
Whitespaces (space, newline, tab, carriage return) in [str] are skipped.
@raise Invalid_argument if the input string contains invalid characters or
has an odd numbers of non-whitespace characters, or if [off] or [len] are
negative, or [String.length str - off] < [len]. *)
(** {2 Comparison } *)
val equal : t -> t -> bool
(** [equal t1 t2] is [true] iff [t1] and [t2] correspond to the same sequence of
bytes. *)
val compare : t -> t -> int
(** [compare t1 t2] gives an unspecified total ordering over {!t}. *)
(** {2 Getters and Setters } *)
val byte_to_int : byte -> int
(** Convert a byte to an integer *)
val check_bounds : t -> int -> bool
(** [check_bounds cstr len] is [true] if [len] is a non-negative integer and
[cstr.buffer]'s size is greater or equal than [len] [false] otherwise.*)
val check_alignment : t -> int -> bool
(** [check_alignment cstr alignment] is [true] if the first byte stored
within [cstr] is at a memory address where [address mod alignment = 0],
[false] otherwise.
Typical uses are to check a buffer is aligned to a page or disk sector
boundary.
@raise Invalid_argument if [alignment] is not a positive integer. *)
val get_char: t -> int -> char
(** [get_char t off] returns the character contained in the cstruct
at offset [off].
@raise Invalid_argument if the offset exceeds cstruct length. *)
val get_uint8: t -> int -> uint8
(** [get_uint8 t off] returns the byte contained in the cstruct
at offset [off].
@raise Invalid_argument if the offset exceeds cstruct length. *)
val set_char: t -> int -> char -> unit
(** [set_char t off c] sets the byte contained in the cstruct
at offset [off] to character [c].
@raise Invalid_argument if the offset exceeds cstruct length. *)
val set_uint8: t -> int -> uint8 -> unit
(** [set_uint8 t off c] sets the byte contained in the cstruct
at offset [off] to byte [c].
@raise Invalid_argument if the offset exceeds cstruct length. *)
val sub: t -> int -> int -> t
(** [sub cstr off len] is [{ t with off = t.off + off; len }]
@raise Invalid_argument if the offset exceeds cstruct length. *)
val sub_copy: t -> int -> int -> t
(** [sub_copy cstr off len] is a new copy of [sub cstr off len],
that does not share the underlying buffer of [cstr].
@raise Invalid_argument if the offset exceeds cstruct length. *)
val shift: t -> int -> t
(** [shift cstr len] is [{ cstr with off=t.off+len; len=t.len-len }]
@raise Invalid_argument if the offset exceeds cstruct length. *)
val copy: t -> int -> int -> string
[@@ocaml.alert deprecated "this is just like [to_string] without defaults, were you looking for [sub_copy]?"]
(** [copy cstr off len] is the string representation of the segment of
[t] starting at [off] of size [len]. It is equivalent to
[Cstruct.to_string cstr ~off ~len].
@raise Invalid_argument if [off] and [len] do not designate a
valid segment of [t]. *)
val blit: t -> int -> t -> int -> int -> unit
(** [blit src srcoff dst dstoff len] copies [len] characters from
cstruct [src], starting at index [srcoff], to cstruct [dst],
starting at index [dstoff]. It works correctly even if [src] and
[dst] are the same string, and the source and destination
intervals overlap.
@raise Invalid_argument if [srcoff] and [len] do not designate a
valid segment of [src], or if [dstoff] and [len] do not designate
a valid segment of [dst]. *)
val blit_from_string: string -> int -> t -> int -> int -> unit
(** [blit_from_string src srcoff dst dstoff len] copies [len]
characters from string [src], starting at index [srcoff], to
cstruct [dst], starting at index [dstoff].
@raise Invalid_argument if [srcoff] and [len] do not designate a
valid substring of [src], or if [dstoff] and [len] do not
designate a valid segment of [dst]. *)
val blit_from_bytes: bytes -> int -> t -> int -> int -> unit
(** [blit_from_bytes src srcoff dst dstoff len] copies [len]
characters from bytes [src], starting at index [srcoff], to
cstruct [dst], starting at index [dstoff].
@raise Invalid_argument if [srcoff] and [len] do not designate a
valid subsequence of [src], or if [dstoff] and [len] do not
designate a valid segment of [dst]. *)
val blit_to_bytes: t -> int -> bytes -> int -> int -> unit
(** [blit_to_bytes src srcoff dst dstoff len] copies [len] characters
from cstruct [src], starting at index [srcoff], to the [dst] buffer,
starting at index [dstoff].
@raise Invalid_argument if [srcoff] and [len] do not designate a
valid segment of [src], or if [dstoff] and [len] do not designate
a valid segment of [dst]. *)
val memset: t -> int -> unit
(** [memset t x] sets all the bytes of [t] to [x land 0xff]. *)
val split: ?start:int -> t -> int -> t * t
(** [split ~start cstr len] is a tuple containing the cstruct
extracted from [cstr] at offset [start] (default: 0) of length
[len] as first element, and the rest of [cstr] as second
element.
@raise Invalid_argument if [start] exceeds the cstruct length,
or if there is a bounds violation of the cstruct via [len+start]. *)
val to_string: ?off:int -> ?len:int -> t -> string
(** [to_string ~off ~len t] will allocate a fresh OCaml [string] and copy the
contents of the cstruct starting at offset [off] (default [0]) of length
[len] (default [Cstruct.length t - off]) into it, and return that string.
@raise Invalid_argument if [off] or [len] is negative, or
[Cstruct.length t - off] < [len]. *)
val to_hex_string : ?off:int -> ?len:int -> t -> string
(** [to_hex_string ~off ~len t] is a fresh OCaml [string] containing
the hex representation of [sub t off len]. It is therefore of length
[2 * len]. This string can be read back into a Cstruct using {!of_hex}.
@raise Invalid_argument if [off] or [len] is negative, or
if [Cstruct.length t - off < len].
@since 6.2 *)
val to_bytes: ?off:int -> ?len:int -> t -> bytes
(** [to_bytes ~off ~len t] will allocate a fresh OCaml [bytes] and copy the
contents of the cstruct starting at offset [off] (default [0]) of length
[len] (default [Cstruct.length t - off]) into it, and return that bytes.
@raise Invalid_argument if [off] or [len] is negative, or
[Cstruct.length str - off] < [len]. *)
module BE : sig
(** Get/set big-endian integers of various sizes. The second
argument of those functions is the position relative to the
current offset of the cstruct. *)
val get_uint16: t -> int -> uint16
(** [get_uint16 cstr off] is the 16 bit long big-endian unsigned
integer stored in [cstr] at offset [off].
@raise Invalid_argument if the buffer is too small. *)
val get_uint32: t -> int -> uint32
(** [get_uint32 cstr off] is the 32 bit long big-endian unsigned
integer stored in [cstr] at offset [off].
@raise Invalid_argument if the buffer is too small. *)
val get_uint64: t -> int -> uint64
(** [get_uint64 cstr off] is the 64 bit long big-endian unsigned
integer stored in [cstr] at offset [off].
@raise Invalid_argument if the buffer is too small. *)
val set_uint16: t -> int -> uint16 -> unit
(** [set_uint16 cstr off i] writes the 16 bit long big-endian
unsigned integer [i] at offset [off] of [cstr].
@raise Invalid_argument if the buffer is too small. *)
val set_uint32: t -> int -> uint32 -> unit
(** [set_uint32 cstr off i] writes the 32 bit long big-endian
unsigned integer [i] at offset [off] of [cstr].
@raise Invalid_argument if the buffer is too small. *)
val set_uint64: t -> int -> uint64 -> unit
(** [set_uint64 cstr off i] writes the 64 bit long big-endian
unsigned integer [i] at offset [off] of [cstr].
@raise Invalid_argument if the buffer is too small. *)
end
module LE : sig
(** Get/set little-endian integers of various sizes. The second
argument of those functions is the position relative to the
current offset of the cstruct. *)
val get_uint16: t -> int -> uint16
(** [get_uint16 cstr off] is the 16 bit long little-endian unsigned
integer stored in [cstr] at offset [off].
@raise Invalid_argument if the buffer is too small. *)
val get_uint32: t -> int -> uint32
(** [get_uint32 cstr off] is the 32 bit long little-endian unsigned
integer stored in [cstr] at offset [off].
@raise Invalid_argument if the buffer is too small. *)
val get_uint64: t -> int -> uint64
(** [get_uint64 cstr off] is the 64 bit long little-endian unsigned
integer stored in [cstr] at offset [off].
@raise Invalid_argument if the buffer is too small. *)
val set_uint16: t -> int -> uint16 -> unit
(** [set_uint16 cstr off i] writes the 16 bit long little-endian
unsigned integer [i] at offset [off] of [cstr].
@raise Invalid_argument if the buffer is too small. *)
val set_uint32: t -> int -> uint32 -> unit
(** [set_uint32 cstr off i] writes the 32 bit long little-endian
unsigned integer [i] at offset [off] of [cstr].
@raise Invalid_argument if the buffer is too small. *)
val set_uint64: t -> int -> uint64 -> unit
(** [set_uint64 cstr off i] writes the 64 bit long little-endian
unsigned integer [i] at offset [off] of [cstr].
@raise Invalid_argument if the buffer is too small. *)
end
module HE : sig
(** Get/set host-endian integers of various sizes. The second
argument of those functions is the position relative to the
current offset of the cstruct. *)
val get_uint16: t -> int -> uint16
(** [get_uint16 cstr off] is the 16 bit long host-endian unsigned
integer stored in [cstr] at offset [off].
@raise Invalid_argument if the buffer is too small. *)
val get_uint32: t -> int -> uint32
(** [get_uint32 cstr off] is the 32 bit long host-endian unsigned
integer stored in [cstr] at offset [off].
@raise Invalid_argument if the buffer is too small. *)
val get_uint64: t -> int -> uint64
(** [get_uint64 cstr off] is the 64 bit long host-endian unsigned
integer stored in [cstr] at offset [off].
@raise Invalid_argument if the buffer is too small. *)
val set_uint16: t -> int -> uint16 -> unit
(** [set_uint16 cstr off i] writes the 16 bit long host-endian
unsigned integer [i] at offset [off] of [cstr].
@raise Invalid_argument if the buffer is too small. *)
val set_uint32: t -> int -> uint32 -> unit
(** [set_uint32 cstr off i] writes the 32 bit long host-endian
unsigned integer [i] at offset [off] of [cstr].
@raise Invalid_argument if the buffer is too small. *)
val set_uint64: t -> int -> uint64 -> unit
(** [set_uint64 cstr off i] writes the 64 bit long host-endian
unsigned integer [i] at offset [off] of [cstr].
@raise Invalid_argument if the buffer is too small. *)
end
(** {2 Debugging } *)
val hexdump: t -> unit
(** When the going gets tough, the tough hexdump their cstructs
and peer at it until the bug disappears. This will directly
prettyprint the contents of the cstruct to the standard output. *)
val hexdump_to_buffer: Buffer.t -> t -> unit
(** [hexdump_to_buffer buf c] will append the pretty-printed hexdump
of the cstruct [c] to the buffer [buf]. *)
val hexdump_pp: Format.formatter -> t -> unit
(** [hexdump_pp f c] pretty-prints a hexdump of [c] to [f]. *)
val debug: t -> string
(** [debug t] will print out the internal details of a cstruct such
as its base offset and the length, and raise an assertion failure
if invariants have been violated. Not intended for casual use. *)
(** {2 List of buffers} *)
val lenv: t list -> int
(** [lenv cstrs] is the combined length of all cstructs in [cstrs].
@raise Invalid_argument if computing the sum overflows. *)
val copyv: t list -> string
(** [copyv cstrs] is the string representation of the concatenation of
all cstructs in [cstrs].
@raise Invalid_argument if the length of the result would
exceed [Sys.max_string_length]. *)
val fillv: src:t list -> dst:t -> int * t list
(** [fillv ~src ~dst] copies from [src] to [dst] until [src] is exhausted or [dst] is full.
Returns the number of bytes copied and the remaining data from [src], if any.
This is useful if you want buffer data into fixed-sized chunks. *)
val shiftv: t list -> int -> t list
(** [shiftv ts n] is [ts] without the first [n] bytes.
It has the property that [equal (concat (shiftv ts n)) (shift (concat ts) n)].
This operation is fairly fast, as it will share the tail of the list.
The first item in the returned list is never an empty cstruct,
so you'll get [[]] if and only if [lenv ts = n]. *)
(** {2 Iterations} *)
type 'a iter = unit -> 'a option
(** Type of an iterator. *)
val iter: (t -> int option) -> (t -> 'a) -> t -> 'a iter
(** [iter lenf of_cstr cstr] is an iterator over [cstr] that returns
elements of size [lenf cstr] and type [of_cstr cstr]. *)
val fold: ('b -> 'a -> 'b) -> 'a iter -> 'b -> 'b
(** [fold f iter acc] is [(f iterN accN ... (f iter acc)...)]. *)
val append: t -> t -> t
(** [append t1 t2] is the concatenation [t1 || t2]. *)
val concat: t list -> t
(** [concat ts] is the concatenation of all the [ts]. It is not guaranteed that
* the result is a newly created [t] in the zero- and one-element cases. *)
val rev: t -> t
(** [rev t] is [t] in reverse order. The return value is a freshly allocated
cstruct, and the argument is not modified. *)
(** {1 Helpers to parse.}
[Cstruct] is used to manipulate {i payloads} which can be formatted
according an {{:https://perdu.com/}RFC} or an user-defined format. In such context, this module
provides utilities to be able to easily {i parse} {i payloads}.
Due to the type {!Cstruct.t}, no copy are done when you use these utilities
and you are able to extract your information without a big performance cost.
More precisely, each values returned by these utilities will be located into
the minor-heap where the base buffer will never be copied or relocated.
For instance, to parse a Git tree object:
{v
entry := perm ' ' name '\000' 20byte
tree := entry *
v}
{[
open Cstruct
let ( >>= ) = Option.bind
let rec hash_of_name ~name payload =
if is_empty payload then raise Not_found
else
cut ~sep:(v " ") payload >>= fun (_, payload) ->
cut ~sep:(v "\000") payload >>= fun (name', payload) ->
if name = name' then with_range ~len:20 payload
else hash_of_name ~name (shift payload 20)
]}
A [Cstruct] defines a possibly empty subsequence of bytes in a {e base}
buffer (a {!Bigarray.Array1.t}).
The positions of a buffer [b] of length [l] are the slits found
before each byte and after the last byte of the buffer. They are
labelled from left to right by increasing number in the range \[[0];[l]\].
{v
positions 0 1 2 3 4 l-1 l
+---+---+---+---+ +-----+
indices | 0 | 1 | 2 | 3 | ... | l-1 |
+---+---+---+---+ +-----+
v}
The [i]th byte index is between positions [i] and [i+1].
Formally we define a subbuffer of [b] as being a subsequence
of bytes defined by a {e off} position and a {e len} number. When
[len] is [0] the subbuffer is {e empty}. Note that for a given
base buffer there are as many empty subbuffers as there are positions
in the buffer.
Like in strings, we index the bytes of a subbuffer using zero-based
indices.
*)
val get : t -> int -> char
(** [get cs zidx] is the byte of [cs] at its zero-based index [zidx].
It's an alias of {!get_char}.
@raise Invalid_argument if [zidx] is not an index of [cs]. *)
val get_byte : t -> int -> int
(** [get_byte cs zidx] is [Char.code (get cs zidx)]. It's an alias of {!get_uint8}. *)
val string : ?off:int -> ?len:int -> string -> t
(** [string ~off ~len str] is the subbuffer of [str] that starts at position [off]
(defaults to [0]) and stops at position [off + len] (defaults to
[String.length str]). [str] is fully-replaced by an fresh allocated
{!type:buffer}.
@raise Invalid_argument if [off] or [off + len] are not positions of [str].
*)
val buffer : ?off:int -> ?len:int -> buffer -> t
(** [buffer ~off ~len buffer] is the sub-part of [buffer] that starts at
position [off] (default to [0]) and stops at position [off + len] (default to
[Bigarray.Array1.dim buffer]). [buffer] is used as the base buffer of the
returned value (no major-heap allocation are performed).
@raise Invalid_argument if [off] or [off + len] are not positions of
[buffer]. *)
val start_pos : t -> int
(** [start_pos cs] is [cs]'s start position in the base {!type:buffer}. *)
val stop_pos : t -> int
(** [stop_pos cs] is [cs]'s stop position in the base {!type:buffer}. *)
val length : t -> int
(** Returns the length of the current cstruct view. Note that this
length is potentially smaller than the actual size of the underlying
buffer, as the [sub] function can construct a smaller view. *)
val head : ?rev:bool -> t -> char option
(** [head cs] is [Some (get cs h)] with [h = 0] if [rev = false] (default) or [h
= length cs - 1] if [rev = true]. [None] is returned if [cs] is empty. *)
val tail : ?rev:bool -> t -> t
(** [tail cs] is [cs] without its first ([rev] is [false], default) or last
([rev] is [true]) byte or [cs] is empty. *)
val is_empty : t -> bool
(** [is_empty cs] is [length cs = 0]. *)
val is_prefix : affix:t -> t -> bool
(** [is_prefix ~affix cs] is [true] iff [affix.[zidx] = cs.[zidx]] for all
indices [zidx] of [affix]. *)
val is_suffix : affix:t -> t -> bool
(** [is_suffix ~affix cs] is [true] iff [affix.[n - zidx] = cs.[m - zidx]] for
all indices [zidx] of [affix] with [n = length affix - 1] and [m = length cs
- 1]. *)
val is_infix : affix:t -> t -> bool
(** [is_infix ~affix cs] is [true] iff there exists an index [z] in [cs] such
that for all indices [zidx] of [affix] we have [affix.[zidx] = cs.[z +
zidx]]. *)
val for_all : (char -> bool) -> t -> bool
(** [for_all p cs] is [true] iff for all indices [zidx] of [cs], [p cs.[zidx] =
true]. *)
val exists : (char -> bool) -> t -> bool
(** [exists p cs] is [true] iff there exists an index [zidx] of [cs] with [p
cs.[zidx] = true]. *)
val start : t -> t
(** [start cs] is the empty sub-part at the start position of [cs]. *)
val stop : t -> t
(** [stop cs] is the empty sub-part at the stop position of [cs]. *)
val trim : ?drop:(char -> bool) -> t -> t
(** [trim ~drop cs] is [cs] with prefix and suffix bytes satisfying [drop] in
[cs] removed. [drop] defaults to [function ' ' | '\r' .. '\t' -> true | _ ->
false]. *)
val span : ?rev:bool -> ?min:int -> ?max:int -> ?sat:(char -> bool) -> t -> t * t
(** [span ~rev ~min ~max ~sat cs] is [(l, r)] where:
{ul
{- if [rev] is [false] (default), [l] is at least [min] and at most
[max] consecutive [sat] satisfying initial bytes of [cs] or {!empty}
if there are no such bytes. [r] are the remaining bytes of [cs].}
{- if [rev] is [true], [r] is at least [min] and at most [max]
consecutive [sat] satisfying final bytes of [cs] or {!empty}
if there are no such bytes. [l] are the remaining bytes of [cs].}}
If [max] is unspecified the span is unlimited. If [min] is unspecified
it defaults to [0]. If [min > max] the condition can't be satisfied and
the left or right span, depending on [rev], is always empty. [sat]
defaults to [(fun _ -> true)].
The invariant [l ^ r = s] holds.
For instance, the {i ABNF} expression:
{v
time := 1*10DIGIT
v}
can be translated to:
{[
let (time, _) = span ~min:1 ~max:10 is_digit cs in
]}
@raise Invalid_argument if [max] or [min] is negative. *)
val take : ?rev:bool -> ?min:int -> ?max:int -> ?sat:(char -> bool) -> t -> t
(** [take ~rev ~min ~max ~sat cs] is the matching span of {!span} without the remaining one.
In other words:
{[(if rev then snd else fst) @@ span ~rev ~min ~max ~sat cs]} *)
val drop : ?rev:bool -> ?min:int -> ?max:int -> ?sat:(char -> bool) -> t -> t
(** [drop ~rev ~min ~max ~sat cs] is the remaining span of {!span} without the matching one.
In other words:
{[(if rev then fst else snd) @@ span ~rev ~min ~max ~sat cs]} *)
val cut : ?rev:bool -> sep:t -> t -> (t * t) option
(** [cut ~sep cs] is either the pair [Some (l, r)] of the two
(possibly empty) sub-buffers of [cs] that are delimited by the first
match of the non empty separator string [sep] or [None] if [sep] can't
be matched in [cs]. Matching starts from the beginning of [cs] ([rev] is
[false], default) or the end ([rev] is [true]).
The invariant [l ^ sep ^ r = s] holds.
For instance, the {i ABNF} expression:
{v
field_name := *PRINT
field_value := *ASCII
field := field_name ":" field_value
v}
can be translated to:
{[
match cut ~sep:":" value with
| Some (field_name, field_value) -> ...
| None -> invalid_arg "invalid field"
]}
@raise Invalid_argument if [sep] is the empty buffer. *)
val cuts : ?rev:bool -> ?empty:bool -> sep:t -> t -> t list
(** [cuts ~sep cs] is the list of all sub-buffers of [cs] that are
delimited by matches of the non empty separator [sep]. Empty sub-buffers are
omitted in the list if [empty] is [false] (default to [true]).
Matching separators in [cs] starts from the beginning of [cs]
([rev] is [false], default) or the end ([rev] is [true]). Once
one is found, the separator is skipped and matching starts again,
that is separator matches can't overlap. If there is no separator
match in [cs], the list [[cs]] is returned.
The following invariants hold:
{ul
{- [concat ~sep (cuts ~empty:true ~sep cs) = cs]}
{- [cuts ~empty:true ~sep cs <> []]}}
For instance, the {i ABNF} expression:
{v
arg := *(ASCII / ",") ; any characters exclude ","
args := arg *("," arg)
v}
can be translated to:
{[
let args = cuts ~sep:"," buffer in
]}
@raise Invalid_argument if [sep] is the empty buffer. *)
val fields : ?empty:bool -> ?is_sep:(char -> bool) -> t -> t list
(** [fields ~empty ~is_sep cs] is the list of (possibly empty)
sub-buffers that are delimited by bytes for which [is_sep] is
[true]. Empty sub-buffers are omitted in the list if [empty] is
[false] (defaults to [true]). [is_sep c] if it's not define by the
user is [true] iff [c] is an US-ASCII white space character,
that is one of space [' '] ([0x20]), tab ['\t'] ([0x09]), newline
['\n'] ([0x0a]), vertical tab ([0x0b]), form feed ([0x0c]), carriage
return ['\r'] ([0x0d]). *)
val find : ?rev:bool -> (char -> bool) -> t -> t option
(** [find ~rev sat cs] is the sub-buffer of [cs] (if any) that spans
the first byte that satisfies [sat] in [cs] after position [start cs]
([rev] is [false], default) or before [stop cs] ([rev] is [true]).
[None] is returned if there is no matching byte in [s]. *)
val find_sub : ?rev:bool -> sub:t -> t -> t option
(** [find_sub ~rev ~sub cs] is the sub-buffer of [cs] (if any) that spans
the first match of [sub] in [cs] after position [start cs]
([rev] is [false], default) or before [stop cs] ([rev] is [true]).
Only bytes are compared and [sub] can be on a different base buffer.
[None] is returned if there is no match of [sub] in [s]. *)
val filter : (char -> bool) -> t -> t
(** [filter sat cs] is the buffer made of the bytes of [cs] that satisfy [sat],
in the same order. *)
val filter_map : (char -> char option) -> t -> t
(** [filter_map f cs] is the buffer made of the bytes of [cs] as mapped by
[f], in the same order. *)
val map : (char -> char) -> t -> t
(** [map f cs] is [cs'] with [cs'.[i] = f cs.[i]] for all indices [i]
of [cs]. [f] is invoked in increasing index order. *)
val mapi : (int -> char -> char) -> t -> t
(** [map f cs] is [cs'] with [cs'.[i] = f i cs.[i]] for all indices [i]
of [cs]. [f] is invoked in increasing index order. *)
(**/**)
val sum_lengths : caller:string -> t list -> int
(** [sum_lengths ~caller acc l] is [acc] plus the sum of the lengths
of the elements of [l]. Raises [Invalid_argument caller] if
arithmetic overflows. *)

73
unikernel/duniverse/ocaml-cstruct/lib/cstruct_cap.ml Normal file
View file

@ -0,0 +1,73 @@
(*
* Copyright (c) 2012-2019 Anil Madhavapeddy <anil@recoil.org>
* Copyright (c) 2019 Romain Calascibetta <romain.calascibetta@gmail.com>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
include (Cstruct : module type of Cstruct with type t := Cstruct.t)
type 'a rd = < rd: unit; .. > as 'a
type 'a wr = < wr: unit; .. > as 'a
type 'a t = Cstruct.t
type rdwr = < rd: unit; wr: unit; >
type ro = < rd: unit; >
type wo = < wr: unit; >
external ro : 'a rd t -> ro t = "%identity"
external wo : 'a wr t -> wo t = "%identity"
let of_string = Cstruct.of_string ?allocator:None
let of_bytes = Cstruct.of_bytes ?allocator:None
let pp ppf t = Cstruct.hexdump_pp ppf t
let length = Cstruct.length
let blit src ~src_off dst ~dst_off ~len =
Cstruct.blit src src_off dst dst_off len
[@@inline]
let blit_from_string src ~src_off dst ~dst_off ~len =
Cstruct.blit_from_string src src_off dst dst_off len
[@@inline]
let blit_from_bytes src ~src_off dst ~dst_off ~len =
Cstruct.blit_from_bytes src src_off dst dst_off len
[@@inline]
let blit_to_bytes src ~src_off dst ~dst_off ~len =
Cstruct.blit_to_bytes src src_off dst dst_off len
[@@inline]
let sub t ~off ~len =
Cstruct.sub t off len
[@@inline]
let sub_copy t ~off ~len =
Cstruct.sub_copy t off len
[@@inline]
let unsafe_to_bigarray = Cstruct.to_bigarray
let concat vss =
let res = create_unsafe (Cstruct.sum_lengths ~caller:"Cstruct.Cap.concat" vss) in
let go off v =
let len = Cstruct.length v in
Cstruct.blit v 0 res off len ;
off + len in
let len = List.fold_left go 0 vss in
assert (len = Cstruct.length res) ;
res

672
unikernel/duniverse/ocaml-cstruct/lib/cstruct_cap.mli Normal file
View file

@ -0,0 +1,672 @@
(*
* Copyright (c) 2012-2019 Anil Madhavapeddy <anil@recoil.org>
* Copyright (c) 2019 Romain Calascibetta <romain.calascibetta@gmail.com>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** Raw memory buffers with capabilities
[Cstruct_cap] wraps OCaml Stdlib's
{{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Bigarray.html}Bigarray}
module. Each [t] consists of a proxy (consisting of offset, length, and the
actual {!Bigarray.t} buffer). The goal of this module is two-fold: enable
zero-copy - the underlying buffer is shared by most of the functions - and
static checking of read and write capabilities to the underlying buffer
(using phantom types).
Each ['a t] is parameterized by the available capabilities: read ([rd]) and
write ([wr]): to access the contents of the buffer the [read] capability is
necessary, for modifying the content of the buffer the [write] capability is
necessary. Capabilities can only be dropped, never gained, to a buffer. If
code only has read capability, this does not mean that there is no other code
fragment with write capability to the underlying buffer.
The functions that retrieve bytes ({!get_uint8} etc.) require a [read]
capability, functions mutating the underlying buffer ({!set_uint8} etc.)
require a [write] capability. Allocation of a buffer (via {!create}, ...)
returns a [t] with read and write capabilities. {!val:ro} drops the write
capability, {!val:wo} drops the read capability. The only exception is
{!unsafe_to_bigarray} that returns the underlying [Bigarray.t].
Accessors and mutators for fixed size integers (8, 16, 32, 64 bit) are
provided for big-endian and little-endian encodings. *)
(** {2 Types} *)
type 'a rd = < rd: unit; .. > as 'a
(** Type of read capability. *)
type 'a wr = < wr: unit; .. > as 'a
(** Type of write capability. *)
type 'a t
(** Type of cstruct with capabilities ['a]. *)
type buffer = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
(** Type of buffer. A {!t} is composed of an underlying buffer. *)
type rdwr = < rd: unit; wr: unit; >
(** Type of both read and write capability. *)
type ro = < rd: unit; >
(** Type of only read capability. *)
type wo = < wr: unit; >
(** Type of only write capability. *)
type uint8 = int
(** 8-bit unsigned integer. *)
type uint16 = int
(** 16-bit unsigned integer. *)
type uint32 = int32
(** 32-bit unsigned integer. *)
type uint64 = int64
(** 64-bit unsigned integer. *)
(** {2 Capabilities} *)
val ro : 'a rd t -> ro t
(** [ro t] is [t'] with only read capability. *)
val wo : 'a wr t -> wo t
(** [wo t] is [t'] with only write capability. *)
(** {2 Basic operations} *)
val equal : 'a rd t -> 'b rd t -> bool
(** [equal a b] is [true] iff [a] and [b] correspond to the same sequence of
bytes (it uses [memcmp] internally). Both [a] and [b] need at least read
capability {!rd}. *)
val compare : 'a rd t -> 'b rd t -> int
(** [compare a b] gives an unspecified total ordering over {!t}. Both [a] and
[b] need at least read capability {!rd}. *)
val pp : Format.formatter -> 'a rd t -> unit
(** [pp ppf t] pretty-prints [t] on [ppf]. [t] needs read capability {!rd}. *)
val length : 'a t -> int
(** [length t] return length of [t]. Note that this length is potentially
smaller than the actual size of the underlying buffer, as functions such as
{!sub}, {!shift}, and {!split} can construct a smaller view. *)
val check_alignment : 'a t -> int -> bool
(** [check_alignment t alignment] is [true] if the first byte stored
in the underlying buffer of [t] is at a memory address where
[address mod alignment = 0], [false] otherwise. The [mod] used has the
C/OCaml semantic (which differs from Python).
Typical uses are to check a buffer is aligned to a page or disk sector
boundary.
@raise Invalid_argument if [alignment] is not a positive integer. *)
val lenv : 'a t list -> int
(** [lenv vs] is the combined length of all {!t} in [vs].
@raise Invalid_argument if computing the sum overflows. *)
(** {2 Constructors} *)
val create : int -> rdwr t
(** [create len] allocates a buffer and proxy with both read and write
capabilities of size [len]. It is filled with zero bytes. *)
val create_unsafe : int -> rdwr t
(** [create_unsafe len] allocates a buffer and proxy with both read and
write capabilities of size [len].
Note that the returned [t] will contain arbitrary data, likely including
the contents of previously-deallocated cstructs.
Beware!
Forgetting to replace this data could cause your application to leak
sensitive information. *)
(** {2 Subviews} *)
val sub : 'a t -> off:int -> len:int -> 'a t
(** [sub t ~off ~len] returns a proxy which shares the underlying buffer of [t].
It is sliced at offset [off] and of length [len]. The returned value has the
same capabilities as [t].
@raise Invalid_argument if the offset exceeds [t] length. *)
val sub_copy : 'a t -> off:int -> len:int -> rdwr t
(** [sub_copy t ~off ~len] is a new copy of [sub t ~off ~len],
that does not share the underlying buffer of [t].
The returned value has read-write capabilities because it doesn't
affect [t].
@raise Invalid_argument if the offset exceeds [t] length. *)
val shift : 'a t -> int -> 'a t
(** [shift t len] returns a proxy which shares the underlying buffer of [t]. The
returned value starts [len] bytes later than the given [t]. The returned
value has the same capabilities as [t].
@raise Invalid_argument if the offset exceeds [t] length. *)
val shiftv: 'a t list -> int -> 'a t list
(** [shiftv ts n] is [ts] without the first [n] bytes.
It has the property that [equal (concat (shiftv ts n)) (shift (concat ts) n)].
This operation is fairly fast, as it will share the tail of the list.
The first item in the returned list is never an empty cstruct,
so you'll get [[]] if and only if [lenv ts = n]. *)
val split : ?start:int -> 'a t -> int -> 'a t * 'a t
(** [split ~start t len] returns two proxies extracted from [t]. The first
starts at offset [start] (default [0]), and is of length [len]. The second
is the remainder of [t]. The underlying buffer is shared, the capabilities
are preserved.
@raise Invalid_argument if [start] exceeds the length of [t],
or if there is a bounds violation of [t] via [len + start]. *)
val copy : 'a t -> int -> int -> string
[@@ocaml.alert deprecated "this is just like [to_string] without defaults, were you looking for [sub_copy]?"]
(** [copy cstr off len] is the same as [Cstruct.to_string cstr ~off ~len]. *)
(** {2 Construction from existing t} *)
val append : 'a rd t -> 'b rd t -> rdwr t
(** [append a b] allocates a buffer [r] of size [length a + length b]. Then the
content of [a] is copied at the start of the buffer [r], and [b] is copied
behind [a]'s end in [r]. [a] and [b] need at least read capability {!rd},
the returned value has both read and write capabilities. *)
val concat : 'a rd t list -> rdwr t
(** [concat vss] allocates a buffer [r] of size [lenv vss]. Each [v] of [vss]
is copied into the buffer [r]. Each [v] of [vss] need at least read
capability {!rd}, the returned value has both read and write capabilities.
*)
val fillv : src:'a rd t list -> dst:'b wr t -> int * 'a rd t list
(** [fillv ~src ~dst] copies from [src] to [dst] until [src] is exhausted or
[dst] is full. It returns the number of bytes copied and the remaining data
from [src], if any. This is useful if you want to {i bufferize} data into
fixed-sized chunks. Each {!t} of [src] need at least read capability {!rd}.
[dst] needs at least write capability {!wr}. *)
val rev : 'a rd t -> rdwr t
(** [rev t] allocates a buffer [r] of size [length t], and fills it with the
bytes of [t] in reverse order. The given [t] needs at least read capability
{!rd}, the returned value has both read and write capabilities. *)
(** {2 Mutation of the underlying buffer} *)
val memset : 'a wr t -> int -> unit
(** [memset t x] sets all bytes of [t] to [x land 0xFF]. [t] needs at least
write capability {!wr}. *)
val blit : 'a rd t -> src_off:int -> 'b wr t -> dst_off:int -> len:int -> unit
(** [blit src ~src_off dst ~dst_off ~len] copies [len] bytes from [src] starting
at index [src_off] to [dst] starting at index [dst_off]. It works correctly
even if [src] and [dst] refer to the same underlying buffer, and the [src]
and [dst] intervals overlap. This function uses [memmove] internally.
[src] needs at least read capability {!rd}. [dst] needs at least
write capability {!wr}.
@raise Invalid_argument if [src_off] and [len] do not designate a valid
segment of [src], or if [dst_off] and [len] do not designate a valid segment
of [dst]. *)
val blit_from_string : string -> src_off:int -> 'a wr t -> dst_off:int ->
len:int -> unit
(** [blit_from_string src ~src_off dst ~dst_off ~len] copies [len] byres from
[src] starting at index [src_off] to [dst] starting at index [dst_off]. This
function uses [memcpy] internally.
[dst] needs at least write capability {!wr}.
@raise Invalid_argument if [src_off] and [len] do not designate a valid
sub-string of [src], or if [dst_off] and [len] do not designate a valid
segment of [dst]. *)
val blit_from_bytes : bytes -> src_off:int -> 'a wr t -> dst_off:int -> len:int
-> unit
(** [blit_from_bytes src ~src_off dst ~dst_off ~len] copies [len] bytes from
[src] starting at index [src_off] to [dst] starting at index [dst_off]. This
uses [memcpy] internally.
[dst] needs at least write capability {!wr}.
@raise Invalid_argument if [src_off] and [len] do not designate a valid
sub-sequence of [src], or if [dst_off] and [len] do no designate a valid
segment of [dst]. *)
(** {2 Converters: string, bytes, bigarray} *)
val of_string : ?off:int -> ?len:int -> string -> rdwr t
(** [of_string ~off ~len s] allocates a buffer and copies the contents of [s]
into it starting at offset [off] (default [0]) and of length [len] (default
[String.length s - off]). The returned value has both read and write
capabilities.
@raise Invalid_argument if [off] and [len] does not designate a valid
segment of [s]. *)
val to_string : ?off:int -> ?len:int -> 'a rd t -> string
(** [to_string ~off ~len t] is the string representation of the segment of [t]
starting at [off] (default [0]) of size [len] (default [length t - off]).
[t] needs at least read capability {!rd}.
@raise Invalid_argument if [off] and [len] does not designate a valid
segment of [t]. *)
val to_hex_string : ?off:int -> ?len:int -> _ rd t -> string
(** [to_hex_string ~off ~len t] is a fresh OCaml [string] containing
the hex representation of [sub t off len]. See {!Cstruct.to_hex_string}.
@raise Invalid_argument if [off] or [len] is negative, or
if [Cstruct.length t - off < len].
@since 6.2 *)
val of_hex : ?off:int -> ?len:int -> string -> rdwr t
(** [of_hex ~off ~len s] allocates a buffer and copies the content of [s]
starting at offset [off] (default [0]) of length [len] (default
[String.length s - off]), decoding the hex-encoded characters.
Whitespaces in the string are ignored, every pair of hex-encoded characters
in [s] are converted to one byte in the returned {!t}, which is exactly
half the size of the non-whitespace characters of [s] from [off] of length
[len].
@raise Invalid_argument is the input string contains invalid characters or
an off number of non-whitespace characters. *)
val copyv : 'a rd t list -> string
(** [copy vs] is the string representation of the concatenation of all {!t} in
[vs]. Each {!t} need at least read capability {!rd}.
@raise Invalid_argument if the length of the result would exceed
{!Sys.max_string_length}. *)
val of_bytes : ?off:int -> ?len:int -> bytes -> rdwr t
(** [of_bytes ~off ~len b] allocates a buffer and copies the contents of [b]
into it starting at offset [off] (default [0]) and of length [len] (default
[Bytes.length b - off]). The returned value has both read and write
capabilities.
@raise Invalid_argument if [off] and [len] does not designate a valid
segment of [s]. *)
val to_bytes : ?off:int -> ?len:int -> 'a rd t -> bytes
(** [to_bytes ~off ~len t] is the bytes representation of the segment of [t]
starting at [off] (default [0]) of size [len] (default [length t - off]).
[t] needs at least read capability {!rd}.
@raise Invalid_argument if [off] and [len] do not designate a valid
segment of [t]. *)
val blit_to_bytes : 'a rd t -> src_off:int -> bytes -> dst_off:int -> len:int
-> unit
(** [blit_to_bytes src ~src_off dst ~dst_off ~len] copies length [len] bytes
from [src], starting at index [src_off], to sequences [dst], starting at
index [dst_off]. [blit_to_bytes] uses [memcpy] internally.
[src] needs at least read capability {!rd}.
@raise Invalid_argument if [src_off] and [len] do not designate a valid
segment of [src], or if [dst_off] and [len] do not designate a valid
sub-seuqnce of [dst]. *)
val of_bigarray: ?off:int -> ?len:int -> buffer -> rdwr t
(** [of_bigarray ~off ~len b] is a proxy that contains [b] with offset [off]
(default [0]) of length [len] (default [Bigarray.Array1.dim b - off]). The
returned value has both read and write capabilties.
@raise Invalid_argument if [off] and [len] do not designate a valid
segment of [b]. *)
val unsafe_to_bigarray : 'a t -> buffer
(** [unsafe_to_bigarray t] converts [t] into a {!buffer} Bigarray, using the
Bigarray slicing to allocate a fresh {i proxy} Bigarray that preserves
sharing of the underlying buffer.
In other words:
{[let t = Cstruct_cap.create 10 in
let b = Cstruct_cap.unsafe_to_bigarray t in
Bigarray.Array1.set b 0 '\x42' ;
assert (Cstruct_cap.get_char t 0 = '\x42')]} *)
(** {2 Higher order functions} *)
type 'a iter = unit -> 'a option
(** Type of iterator. *)
val iter : ('a rd t -> int option) -> ('a rd t -> 'v) -> 'a rd t -> 'v iter
(** [iter lenf of_cstruct t] is an iterator over [t] that returns elements of
size [lenf t] and type [of_cstruct t]. [t] needs at least read capability
{!rd} and [iter] keeps capabilities of [t] on [of_cstruct]. *)
val fold : ('acc -> 'x -> 'acc) -> 'x iter -> 'acc -> 'acc
(** [fold f iter acc] is [(f iterN accN ... (f iter acc)...)]. *)
(** {2 Accessors and mutators} *)
val get_char : 'a rd t -> int -> char
(** [get_char t off] returns the character contained in [t] at offset [off].
[t] needs at least read capability {!rd}.
@raise Invalid_argument if the offset exceeds [t] length. *)
val set_char : 'a wr t -> int -> char -> unit
(** [set_char t off c] sets the character contained in [t] at offset [off]
to character [c]. [t] needs at least write capability {!wr}.
@raise Invalid_argument if the offset exceeds [t] length. *)
val get_uint8 : 'a rd t -> int -> uint8
(** [get_uint8 t off] returns the byte contained in [t] at offset [off].
[t] needs at least read capability {!rd}.
@raise Invalid_argument if the offset exceeds [t] length. *)
val set_uint8 : 'a wr t -> int -> uint8 -> unit
(** [set_uint8 t off x] sets the byte contained in [t] at offset [off]
to byte [x]. [t] needs at least write capability {!wr}.
@raise Invalid_argument if the offset exceeds [t] length. *)
module BE : sig
(** {3 Big-endian Byte Order}
The following operations assume a big-endian byte ordering of the
cstruct. If the machine-native byte ordering differs, then the get
operations will reorder the bytes so that they are in machine-native byte
order before returning the result, and the set operations will reorder the
bytes so that they are written out in the appropriate order.
Network byte order is big-endian, so you may need these operations when
dealing with raw frames, for example, in a userland networking stack. *)
val get_uint16 : 'a rd t -> int -> uint16
(** [get_uint16 t off] returns the two bytes in [t] starting at offset [off],
interpreted as an {!uint16}. [t] needs at least read capability {!rd}.
@raise Invalid_argument if offset [off] exceeds [length t - 2]. *)
val get_uint32 : 'a rd t -> int -> uint32
(** [get_uint32 t off] returns the four bytes in [t] starting at offset [off].
[t] needs at least read capability {!rd}.
@raise Invalid_argument if offset [off] exceeds [length t - 4]. *)
val get_uint64 : 'a rd t -> int -> uint64
(** [get_uint64 t off] returns the eight bytes in [t] starting at offset
[off]. [t] needs at least read capability {!rd}.
@raise Invalid_argument if offset [off] exceeds [length t - 8]. *)
val set_uint16 : 'a wr t -> int -> uint16 -> unit
(** [set_uint16 t off v] sets the two bytes in [t] starting at offset [off] to
the value [v]. [t] needs at least write capability {!wr}.
@raise Invalid_argument if offset [off] exceeds [length t - 2]. *)
val set_uint32 : 'a wr t -> int -> uint32 -> unit
(** [set_uint32 t off v] sets the four bytes in [t] starting at offset [off]
to the value [v]. [t] needs at least write capability {!wr}.
@raise Invalid_argument if offset [off] exceeds [length t - 4]. *)
val set_uint64 : 'a wr t -> int -> uint64 -> unit
(** [set_uint64 t off v] sets the eight bytes in [t] starting at offset [off]
to the value [v]. [t] needs at least write capability {!wr}.
@raise Invalid_argument if offset [off] exceeds [length t - 8]. *)
end
module LE : sig
(** {3 Little-endian Byte Order}
The following operations assume a little-endian byte ordering of the
cstruct. If the machine-native byte ordering differs, then the get
operations will reorder the bytes so that they are in machine-native byte
order before returning the result, and the set operations will reorder the
bytes so that they are written out in the appropriate order.
Most modern processor architectures are little-endian, so more likely than
not, these operations will not do any byte reordering. *)
val get_uint16 : 'a rd t -> int -> uint16
(** [get_uint16 t off] returns the two bytes in [t] starting at offset [off],
interpreted as an {!uint16}. [t] needs at least read capability {!rd}.
@raise Invalid_argument if offset [off] exceeds [length t - 2]. *)
val get_uint32 : 'a rd t -> int -> uint32
(** [get_uint32 t off] returns the four bytes in [t] starting at offset [off].
[t] needs at least read capability {!rd}.
@raise Invalid_argument if offset [off] exceeds [length t - 4]. *)
val get_uint64 : 'a rd t -> int -> uint64
(** [get_uint64 t off] returns the eight bytes in [t] starting at offset
[off]. [t] needs at least read capability {!rd}.
@raise Invalid_argument if offset [off] exceeds [length t - 8]. *)
val set_uint16 : 'a wr t -> int -> uint16 -> unit
(** [set_uint16 t off v] sets the two bytes in [t] starting at offset [off] to
the value [v]. [t] needs at least write capability {!wr}.
@raise Invalid_argument if offset [off] exceeds [length t - 2]. *)
val set_uint32 : 'a wr t -> int -> uint32 -> unit
(** [set_uint32 t off v] sets the four bytes in [t] starting at offset [off]
to the value [v]. [t] needs at least write capability {!wr}.
@raise Invalid_argument if offset [off] exceeds [length t - 4]. *)
val set_uint64 : 'a wr t -> int -> uint64 -> unit
(** [set_uint64 t off v] sets the eight bytes in [t] starting at offset [off]
to the value [v]. [t] needs at least write capability {!wr}.
@raise Invalid_argument if offset [off] exceeds [length t - 8]. *)
end
(** {2 Helpers to parse with capabilities.}
As [Cstruct], capabilities interface provides helpers functions to help
the user to parse contents. *)
val head : ?rev:bool -> 'a rd t -> char option
(** [head cs] is [Some (get cs h)] with [h = 0] if [rev = false] (default) or [h
= length cs - 1] if [rev = true]. [None] is returned if [cs] is empty. *)
val tail : ?rev:bool -> 'a rd t -> 'a rd t
(** [tail cs] is [cs] without its first ([rev] is [false], default) or last
([rev] is [true]) byte or [cs] is empty. *)
val is_empty : 'a rd t -> bool
(** [is_empty cs] is [length cs = 0]. *)
val is_prefix : affix:'a rd t -> 'a rd t -> bool
(** [is_prefix ~affix cs] is [true] iff [affix.[zidx] = cs.[zidx]] for all
indices [zidx] of [affix]. *)
val is_suffix : affix:'a rd t -> 'a rd t -> bool
(** [is_suffix ~affix cs] is [true] iff [affix.[n - zidx] = cs.[m - zidx]] for
all indices [zidx] of [affix] with [n = length affix - 1] and [m = length cs
- 1]. *)
val is_infix : affix:'a rd t -> 'a rd t -> bool
(** [is_infix ~affix cs] is [true] iff there exists an index [z] in [cs] such
that for all indices [zidx] of [affix] we have [affix.[zidx] = cs.[z +
zidx]]. *)
val for_all : (char -> bool) -> 'a rd t -> bool
(** [for_all p cs] is [true] iff for all indices [zidx] of [cs], [p cs.[zidx] =
true]. *)
val exists : (char -> bool) -> 'a rd t -> bool
(** [exists p cs] is [true] iff there exists an index [zidx] of [cs] with [p
cs.[zidx] = true]. *)
val start : 'a rd t -> 'a rd t
(** [start cs] is the empty sub-part at the start position of [cs]. *)
val stop : 'a rd t -> 'a rd t
(** [stop cs] is the empty sub-part at the stop position of [cs]. *)
val trim : ?drop:(char -> bool) -> 'a rd t -> 'a rd t
(** [trim ~drop cs] is [cs] with prefix and suffix bytes satisfying [drop] in
[cs] removed. [drop] defaults to [function ' ' | '\r' .. '\t' -> true | _ ->
false]. *)
val span : ?rev:bool -> ?min:int -> ?max:int -> ?sat:(char -> bool) -> 'a rd t -> 'a rd t * 'a rd t
(** [span ~rev ~min ~max ~sat cs] is [(l, r)] where:
{ul
{- if [rev] is [false] (default), [l] is at least [min] and at most
[max] consecutive [sat] satisfying initial bytes of [cs] or {!is_empty}
if there are no such bytes. [r] are the remaining bytes of [cs].}
{- if [rev] is [true], [r] is at least [min] and at most [max]
consecutive [sat] satisfying final bytes of [cs] or {!is_empty}
if there are no such bytes. [l] are the remaining bytes of [cs].}}
If [max] is unspecified the span is unlimited. If [min] is unspecified
it defaults to [0]. If [min > max] the condition can't be satisfied and
the left or right span, depending on [rev], is always empty. [sat]
defaults to [(fun _ -> true)].
The invariant [l ^ r = s] holds.
For instance, the {i ABNF} expression:
{v
time := 1*10DIGIT
v}
can be translated to:
{[
let (time, _) = span ~min:1 ~max:10 is_digit cs in
]}
@raise Invalid_argument if [max] or [min] is negative. *)
val take : ?rev:bool -> ?min:int -> ?max:int -> ?sat:(char -> bool) -> 'a rd t -> 'a rd t
(** [take ~rev ~min ~max ~sat cs] is the matching span of {!span} without the remaining one.
In other words:
{[(if rev then snd else fst) @@ span ~rev ~min ~max ~sat cs]} *)
val drop : ?rev:bool -> ?min:int -> ?max:int -> ?sat:(char -> bool) -> 'a rd t -> 'a rd t
(** [drop ~rev ~min ~max ~sat cs] is the remaining span of {!span} without the matching one.
In other words:
{[(if rev then fst else snd) @@ span ~rev ~min ~max ~sat cs]} *)
val cut : ?rev:bool -> sep:'a rd t -> 'a rd t -> ('a rd t * 'a rd t) option
(** [cut ~sep cs] is either the pair [Some (l, r)] of the two
(possibly empty) sub-buffers of [cs] that are delimited by the first
match of the non empty separator string [sep] or [None] if [sep] can't
be matched in [cs]. Matching starts from the beginning of [cs] ([rev] is
[false], default) or the end ([rev] is [true]).
The invariant [l ^ sep ^ r = s] holds.
For instance, the {i ABNF} expression:
{v
field_name := *PRINT
field_value := *ASCII
field := field_name ":" field_value
v}
can be translated to:
{[
match cut ~sep:":" value with
| Some (field_name, field_value) -> ...
| None -> invalid_arg "invalid field"
]}
@raise Invalid_argument if [sep] is the empty buffer. *)
val cuts : ?rev:bool -> ?empty:bool -> sep:'a rd t -> 'a rd t -> 'a rd t list
(** [cuts ~sep cs] is the list of all sub-buffers of [cs] that are
delimited by matches of the non empty separator [sep]. Empty sub-buffers are
omitted in the list if [empty] is [false] (default to [true]).
Matching separators in [cs] starts from the beginning of [cs]
([rev] is [false], default) or the end ([rev] is [true]). Once
one is found, the separator is skipped and matching starts again,
that is separator matches can't overlap. If there is no separator
match in [cs], the list [[cs]] is returned.
The following invariants hold:
{ul
{- [concat ~sep (cuts ~empty:true ~sep cs) = cs]}
{- [cuts ~empty:true ~sep cs <> []]}}
For instance, the {i ABNF} expression:
{v
arg := *(ASCII / ",") ; any characters exclude ","
args := arg *("," arg)
v}
can be translated to:
{[
let args = cuts ~sep:"," buffer in
]}
@raise Invalid_argument if [sep] is the empty buffer. *)
val fields : ?empty:bool -> ?is_sep:(char -> bool) -> 'a rd t -> 'a rd t list
(** [fields ~empty ~is_sep cs] is the list of (possibly empty)
sub-buffers that are delimited by bytes for which [is_sep] is
[true]. Empty sub-buffers are omitted in the list if [empty] is
[false] (defaults to [true]). [is_sep c] if it's not define by the
user is [true] iff [c] is an US-ASCII white space character,
that is one of space [' '] ([0x20]), tab ['\t'] ([0x09]), newline
['\n'] ([0x0a]), vertical tab ([0x0b]), form feed ([0x0c]), carriage
return ['\r'] ([0x0d]). *)
val find : ?rev:bool -> (char -> bool) -> 'a rd t -> 'a rd t option
(** [find ~rev sat cs] is the sub-buffer of [cs] (if any) that spans
the first byte that satisfies [sat] in [cs] after position [start cs]
([rev] is [false], default) or before [stop cs] ([rev] is [true]).
[None] is returned if there is no matching byte in [s]. *)
val find_sub : ?rev:bool -> sub:'a rd t -> 'a rd t -> 'a rd t option
(** [find_sub ~rev ~sub cs] is the sub-buffer of [cs] (if any) that spans
the first match of [sub] in [cs] after position [start cs]
([rev] is [false], default) or before [stop cs] ([rev] is [true]).
Only bytes are compared and [sub] can be on a different base buffer.
[None] is returned if there is no match of [sub] in [s]. *)
val filter : (char -> bool) -> 'a rd t -> 'a rd t
(** [filter sat cs] is the buffer made of the bytes of [cs] that satisfy [sat],
in the same order. *)
val filter_map : (char -> char option) -> 'a rd t -> rdwr t
(** [filter_map f cs] is the buffer made of the bytes of [cs] as mapped by
[f], in the same order. *)
val map : (char -> char) -> 'a rd t -> rdwr t
(** [map f cs] is [cs'] with [cs'.[i] = f cs.[i]] for all indices [i]
of [cs]. [f] is invoked in increasing index order. *)
val mapi : (int -> char -> char) -> 'a rd t -> rdwr t
(** [map f cs] is [cs'] with [cs'.[i] = f i cs.[i]] for all indices [i]
of [cs]. [f] is invoked in increasing index order. *)

38
unikernel/duniverse/ocaml-cstruct/lib/cstruct_sexp.ml Normal file
View file

@ -0,0 +1,38 @@
(*
* Copyright (c) 2012-2019 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Sexplib
type buffer = Cstruct.buffer
type t = Cstruct.t
let buffer_of_sexp b = Conv.bigstring_of_sexp b
let sexp_of_buffer b = Conv.sexp_of_bigstring b
let t_of_sexp = function
| Sexp.Atom str ->
let n = String.length str in
let t = Cstruct.create_unsafe n in
Cstruct.blit_from_string str 0 t 0 n ;
t
| sexp -> Conv.of_sexp_error "Cstruct.t_of_sexp: atom needed" sexp
let sexp_of_t t =
let n = Cstruct.length t in
let str = Bytes.create n in
Cstruct.blit_to_bytes t 0 str 0 n ;
(* The following call is safe, since str is not visible elsewhere. *)
Sexp.Atom (Bytes.unsafe_to_string str)

37
unikernel/duniverse/ocaml-cstruct/lib/cstruct_sexp.mli Normal file
View file

@ -0,0 +1,37 @@
(*
* Copyright (c) 2012-2019 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** Sexpression serialisers for {!Cstruct.t} values *)
type buffer = Cstruct.buffer
(** [buffer] is an alias for the corresponding {!type:Cstruct.buffer} type *)
val sexp_of_buffer : Cstruct.buffer -> Sexplib.Sexp.t
(** [sexp_of_buffer b] returns the s-expression representation of the raw memory buffer [b] *)
val buffer_of_sexp : Sexplib.Sexp.t -> Cstruct.buffer
(** [buffer_of_sexp s] returns a fresh memory buffer from the s-expression [s].
[s] should have been constructed using {!sexp_of_buffer}. *)
type t = Cstruct.t
(** [t] is an alias for the corresponding {!Cstruct.t} type *)
val sexp_of_t : t -> Sexplib.Sexp.t
(** [sexp_of_t t] returns the s-expression representation of the Cstruct [t] *)
val t_of_sexp : Sexplib.Sexp.t -> t
(** [t_of_sexp s] returns a fresh {!Cstruct.t} that represents the
s-expression previously serialised by {!sexp_of_t}. *)

81
unikernel/duniverse/ocaml-cstruct/lib/cstruct_stubs.c Normal file
View file

@ -0,0 +1,81 @@
/*
* Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
* Copyright (c) 2012 Pierre Chambart
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*/
#include <string.h>
#include <stdint.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/bigarray.h>
#ifndef Bytes_val
#define Bytes_val String_val
#endif
CAMLprim value
caml_blit_bigstring_to_string(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len)
{
memcpy(Bytes_val(val_buf2) + Long_val(val_ofs2),
(char*)Caml_ba_data_val(val_buf1) + Long_val(val_ofs1),
Long_val(val_len));
return Val_unit;
}
CAMLprim value
caml_blit_string_to_bigstring(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len)
{
memcpy((char*)Caml_ba_data_val(val_buf2) + Long_val(val_ofs2),
String_val(val_buf1) + Long_val(val_ofs1),
Long_val(val_len));
return Val_unit;
}
CAMLprim value
caml_blit_bigstring_to_bigstring(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len)
{
memmove((char*)Caml_ba_data_val(val_buf2) + Long_val(val_ofs2),
(char*)Caml_ba_data_val(val_buf1) + Long_val(val_ofs1),
Long_val(val_len));
return Val_unit;
}
CAMLprim value
caml_compare_bigstring(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len)
{
int res = memcmp((char*)Caml_ba_data_val(val_buf1) + Long_val(val_ofs1),
(char*)Caml_ba_data_val(val_buf2) + Long_val(val_ofs2),
Long_val(val_len));
return Val_int(res);
}
CAMLprim value
caml_fill_bigstring(value val_buf, value val_ofs, value val_len, value val_byte)
{
memset((char*)Caml_ba_data_val(val_buf) + Long_val(val_ofs),
Int_val(val_byte),
Long_val(val_len));
return Val_unit;
}
CAMLprim value
caml_check_alignment_bigstring(value val_buf, value val_ofs, value val_alignment)
{
uint64_t address = (uint64_t) ((char *)Caml_ba_data_val(val_buf) + Long_val(val_ofs));
uintnat alignment = Unsigned_long_val(val_alignment);
return Val_bool(address % alignment == 0);
}

16
unikernel/duniverse/ocaml-cstruct/lib/dune Normal file
View file

@ -0,0 +1,16 @@
(library
(name cstruct)
(public_name cstruct)
(foreign_stubs
(language c)
(names cstruct_stubs))
(wrapped false)
(js_of_ocaml
(javascript_files cstruct.js))
(modules cstruct cstruct_cap))
(library
(name cstruct_sexp)
(public_name cstruct-sexp)
(modules cstruct_sexp)
(libraries cstruct sexplib))

522
unikernel/duniverse/ocaml-cstruct/lib_test/bounds.ml Normal file
View file

@ -0,0 +1,522 @@
(*
* Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
* Copyright (c) 2013 Citrix Systems Inc
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
let to_string { Cstruct.buffer; off; len } =
Printf.sprintf "buffer length = %d; off=%d; len=%d" (Bigarray.Array1.dim buffer) off len
(* Check we can create and use an empty cstruct *)
let test_empty_cstruct () =
let x = Cstruct.create 0 in
Alcotest.(check int) "empty len" 0 (Cstruct.length x);
let y = Cstruct.to_string x in
Alcotest.(check string) "empty" "" y
(* Check that we can't create a cstruct with a negative length *)
let test_anti_cstruct () =
try
let x = Cstruct.create (-1) in
failwith (Printf.sprintf "test_anti_cstruct: %s" (to_string x))
with Invalid_argument _ ->
()
(* Check we can shift in the +ve direction *)
let test_positive_shift () =
let x = Cstruct.create 1 in
let y = Cstruct.shift x 1 in
Alcotest.(check int) "positive shift" 0 (Cstruct.length y)
(* Check that negative shifts are forbidden. *)
let test_negative_shift () =
let x = Cstruct.create 2 in
let y = Cstruct.sub x 1 1 in
try
let z = Cstruct.shift x (-1) in
failwith (Printf.sprintf "test_negative_shift/outer: %s" (to_string z))
with Invalid_argument _ ->
try
let z = Cstruct.shift y (-1) in
failwith (Printf.sprintf "test_negative_shift/inner: %s" (to_string z))
with Invalid_argument _ ->
()
(* Check that an attempt to shift beyond the end of the buffer fails *)
let test_bad_positive_shift () =
let x = Cstruct.create 10 in
try
let y = Cstruct.shift x 11 in
failwith (Printf.sprintf "test_bad_positive_shift: %s" (to_string y))
with Invalid_argument _ -> ()
(* Check that 'sub' works *)
let test_sub () =
let x = Cstruct.create 100 in
let y = Cstruct.sub x 10 80 in
Alcotest.(check int) "sub 1" 10 y.Cstruct.off;
Alcotest.(check int) "sub 2" 80 y.Cstruct.len;
let z = Cstruct.sub y 10 60 in
Alcotest.(check int) "sub 3" 20 z.Cstruct.off;
Alcotest.(check int) "sub 4" 60 z.Cstruct.len
let test_sub_copy () =
let x = Cstruct.create 100 in
let y = Cstruct.sub_copy x 10 80 in
Alcotest.(check int) "sub_copy 1" 0 y.Cstruct.off;
Alcotest.(check int) "sub_copy 2" 80 y.Cstruct.len;
let z = Cstruct.sub_copy y 10 60 in
Alcotest.(check int) "sub_copy 3" 0 z.Cstruct.off;
Alcotest.(check int) "sub_copy 4" 60 z.Cstruct.len;
Cstruct.set_uint8 x 50 42;
Alcotest.(check int) "x changed" 42 (Cstruct.get_uint8 x 50);
Alcotest.(check int) "y unchanged" 0 (Cstruct.get_uint8 y 50);
()
let test_negative_sub () =
let x = Cstruct.create 2 in
let y = Cstruct.sub x 1 1 in
try
let z = Cstruct.sub x (-1) 0 in
failwith (Printf.sprintf "test_negative_sub/outer: %s" (to_string z))
with Invalid_argument _ ->
try
let z = Cstruct.sub y (-1) 0 in
failwith (Printf.sprintf "test_negative_sub/inner: %s" (to_string z))
with Invalid_argument _ ->
()
(* Check that 'sub' can't set 'len' too big *)
let test_sub_len_too_big () =
let x = Cstruct.create 0 in
try
let y = Cstruct.sub x 0 1 in
failwith (Printf.sprintf "test_sub_len_too_big: %s" (to_string y))
with Invalid_argument _ -> ()
let test_sub_len_too_small () =
let x = Cstruct.create 0 in
try
let y = Cstruct.sub x 0 (-1) in
failwith (Printf.sprintf "test_sub_len_too_small: %s" (to_string y))
with Invalid_argument _ -> ()
let test_sub_offset_too_big () =
let x = Cstruct.create 10 in
begin
try
let y = Cstruct.sub x 11 0 in
failwith (Printf.sprintf "test_sub_offset_too_big: %s" (to_string y))
with Invalid_argument _ -> ()
end;
let y = Cstruct.sub x 1 9 in
begin
try
let z = Cstruct.sub y 10 0 in
failwith (Printf.sprintf "test_sub_offset_too_big: %s" (to_string z))
with Invalid_argument _ -> ()
end
let test_of_bigarray_negative_params () =
let ba = Bigarray.(Array1.create char c_layout 1) in
try
let x = Cstruct.of_bigarray ~off:(-1) ba in
failwith (Printf.sprintf "test_of_bigarray_negative_params: negative ~off: %s" (to_string x))
with Invalid_argument _ ->
try
let x = Cstruct.of_bigarray ~len:(-1) ba in
failwith (Printf.sprintf "test_of_bigarray_negative_params: negative ~len: %s" (to_string x))
with Invalid_argument _ ->
()
let test_of_bigarray_large_offset () =
let ba = Bigarray.(Array1.create char c_layout 1) in
let _ = Cstruct.of_bigarray ~off:1 ~len:0 ba
and _ = Cstruct.of_bigarray ~off:1 ba in
try
let x = Cstruct.of_bigarray ~off:2 ~len:0 ba in
failwith (Printf.sprintf "test_of_bigarray_large_offset: %s" (to_string x))
with Invalid_argument _ ->
try
let x = Cstruct.of_bigarray ~off:2 ba in
failwith (Printf.sprintf "test_of_bigarray_large_offset: large ~off: %s" (to_string x))
with Invalid_argument _ ->
()
let test_of_bigarray_large_length () =
let ba = Bigarray.(Array1.create char c_layout 1) in
try
let x = Cstruct.of_bigarray ~off:0 ~len:2 ba in
failwith (Printf.sprintf "test_of_bigarray_large_length: %s" (to_string x))
with Invalid_argument _ ->
try
let x = Cstruct.of_bigarray ~off:1 ~len:1 ba in
failwith (Printf.sprintf "test_of_bigarray_large_length: %s" (to_string x))
with Invalid_argument _ ->
try
let x = Cstruct.of_bigarray ~off:2 ~len:0 ba in
failwith (Printf.sprintf "test_of_bigarray_large_length: %s" (to_string x))
with Invalid_argument _ ->
try
let x = Cstruct.of_bigarray ~off:2 ba in
failwith (Printf.sprintf "test_of_bigarray_large_length: %s" (to_string x))
with Invalid_argument _ ->
()
let test_blit_offset_too_big () =
let x = Cstruct.create 1 in
let y = Cstruct.create 1 in
try
Cstruct.blit x 2 y 1 1;
failwith "test_blit_offset_too_big"
with Invalid_argument _ -> ()
let test_blit_offset_too_small () =
let x = Cstruct.create 1 in
let y = Cstruct.create 1 in
try
Cstruct.blit x (-1) y 1 1;
failwith "test_blit_offset_too_small"
with Invalid_argument _ -> ()
let test_blit_dst_offset_too_big () =
let x = Cstruct.create 1 in
let y = Cstruct.create 1 in
try
Cstruct.blit x 1 y 2 1;
failwith "test_blit_dst_offset_too_big"
with Invalid_argument _ -> ()
let test_blit_dst_offset_too_small () =
let x = Cstruct.create 1 in
let y = Cstruct.create 1 in
try
Cstruct.blit x 1 y (-1) 1;
failwith "test_blit_dst_offset_too_small"
with Invalid_argument _ -> ()
let test_blit_dst_offset_negative () =
let x = Cstruct.create 1 in
let y = Cstruct.create 1 in
try
Cstruct.blit x 0 y (-1) 1;
failwith "test_blit_dst_offset_negative"
with Invalid_argument _ -> ()
let test_blit_len_too_big () =
let x = Cstruct.create 1 in
let y = Cstruct.create 2 in
try
Cstruct.blit x 0 y 0 2;
failwith "test_blit_len_too_big"
with Invalid_argument _ -> ()
let test_blit_len_too_big2 () =
let x = Cstruct.create 2 in
let y = Cstruct.create 1 in
try
Cstruct.blit x 0 y 0 2;
failwith "test_blit_len_too_big2"
with Invalid_argument _ -> ()
let test_blit_len_too_small () =
let x = Cstruct.create 1 in
let y = Cstruct.create 1 in
try
Cstruct.blit x 0 y 0 (-1);
failwith "test_blit_len_too_small"
with Invalid_argument _ -> ()
let test_view_bounds_too_small () =
let src = Cstruct.create 4 in
let dst = Cstruct.create 4 in
let dst_small = Cstruct.sub dst 0 2 in
try
Cstruct.blit src 0 dst_small 0 3;
failwith "test_view_bounds_too_small"
with
Invalid_argument _ -> ()
let test_view_bounds_too_small_get_u8 () =
let x = Cstruct.create 2 in
let x' = Cstruct.sub x 0 1 in
try
let _ = Cstruct.get_uint8 x' 1 in
failwith "test_view_bounds_too_small_get_u8"
with
Invalid_argument _ -> ()
let test_view_bounds_too_small_get_char () =
let x = Cstruct.create 2 in
let x' = Cstruct.sub x 0 1 in
try
let _ = Cstruct.get_char x' 1 in
failwith "test_view_bounds_too_small_get_char"
with
Invalid_argument _ -> ()
let test_view_bounds_too_small_get_be16 () =
let x = Cstruct.create 4 in
let x' = Cstruct.sub x 0 1 in
try
let _ = Cstruct.BE.get_uint16 x' 0 in
failwith "test_view_bounds_too_small_get_be16"
with
Invalid_argument _ -> ()
let test_view_bounds_too_small_get_be32 () =
let x = Cstruct.create 8 in
let x' = Cstruct.sub x 2 5 in
try
let _ = Cstruct.BE.get_uint32 x' 2 in
failwith "test_view_bounds_too_small_get_be32"
with
Invalid_argument _ -> ()
let test_view_bounds_too_small_get_be64 () =
let x = Cstruct.create 9 in
let x' = Cstruct.sub x 1 5 in
try
let _ = Cstruct.BE.get_uint64 x' 0 in
failwith "test_view_bounds_too_small_get_be64"
with
Invalid_argument _ -> ()
let test_view_bounds_too_small_get_le16 () =
let x = Cstruct.create 4 in
let x' = Cstruct.sub x 0 1 in
try
let _ = Cstruct.LE.get_uint16 x' 0 in
failwith "test_view_bounds_too_small_get_le16"
with
Invalid_argument _ -> ()
let test_view_bounds_too_small_get_le32 () =
let x = Cstruct.create 8 in
let x' = Cstruct.sub x 2 5 in
try
let _ = Cstruct.LE.get_uint32 x' 2 in
failwith "test_view_bounds_too_small_get_le32"
with
Invalid_argument _ -> ()
let test_view_bounds_too_small_get_le64 () =
let x = Cstruct.create 9 in
let x' = Cstruct.sub x 1 5 in
try
let _ = Cstruct.LE.get_uint64 x' 0 in
failwith "test_view_bounds_too_small_get_le64"
with
Invalid_argument _ -> ()
let test_view_bounds_too_small_get_he16 () =
let x = Cstruct.create 4 in
let x' = Cstruct.sub x 0 1 in
try
let _ = Cstruct.HE.get_uint16 x' 0 in
failwith "test_view_bounds_too_small_get_he16"
with
Invalid_argument _ -> ()
let test_view_bounds_too_small_get_he32 () =
let x = Cstruct.create 8 in
let x' = Cstruct.sub x 2 5 in
try
let _ = Cstruct.HE.get_uint32 x' 2 in
failwith "test_view_bounds_too_small_get_he32"
with
Invalid_argument _ -> ()
let test_view_bounds_too_small_get_he64 () =
let x = Cstruct.create 9 in
let x' = Cstruct.sub x 1 5 in
try
let _ = Cstruct.HE.get_uint64 x' 0 in
failwith "test_view_bounds_too_small_get_he64"
with
Invalid_argument _ -> ()
let test_lenv_overflow () =
if Sys.word_size = 32 then (
(* free-up some space *)
Gc.major ();
let b = Cstruct.create max_int and c = Cstruct.create 3 in
try
let _ = Cstruct.lenv [b; b; c] in
failwith "test_lenv_overflow"
with
Invalid_argument _ -> ())
let test_copyv_overflow () =
if Sys.word_size = 32 then (
(* free-up some space *)
Gc.major ();
let b = Cstruct.create max_int and c = Cstruct.create 3 in
try
let _ = Cstruct.copyv [b; b; c] in
failwith "test_copyv_overflow"
with
Invalid_argument _ -> ())
(* Steamroll over a buffer and a contained subview, checking that only the
* contents of the subview is visible. *)
let test_subview_containment_get_char,
test_subview_containment_get_8,
test_subview_containment_get_be16,
test_subview_containment_get_be32,
test_subview_containment_get_be64,
test_subview_containment_get_le16,
test_subview_containment_get_le32,
test_subview_containment_get_le64,
test_subview_containment_get_he16,
test_subview_containment_get_he32,
test_subview_containment_get_he64
=
let open Cstruct in
let test get zero () =
let x = create 24 in
let x' = sub x 8 8 in
for i = 0 to length x - 1 do set_uint8 x i 0xff done ;
for i = 0 to length x' - 1 do set_uint8 x' i 0x00 done ;
for i = -8 to 8 do
try
let v = get x' i in
if v <> zero then
failwith "test_subview_containment_get"
with Invalid_argument _ -> ()
done
in
test get_char '\000',
test get_uint8 0,
test BE.get_uint16 0,
test BE.get_uint32 0l,
test BE.get_uint64 0L,
test LE.get_uint16 0,
test LE.get_uint32 0l,
test LE.get_uint64 0L,
test HE.get_uint16 0,
test HE.get_uint32 0l,
test HE.get_uint64 0L
(* Steamroll over a buffer and a contained subview, checking that only the
* contents of the subview is writable. *)
let test_subview_containment_set_char,
test_subview_containment_set_8,
test_subview_containment_set_be16,
test_subview_containment_set_be32,
test_subview_containment_set_be64,
test_subview_containment_set_le16,
test_subview_containment_set_le32,
test_subview_containment_set_le64,
test_subview_containment_set_he16,
test_subview_containment_set_he32,
test_subview_containment_set_he64
=
let open Cstruct in
let test set ff () =
let x = create 24 in
let x' = sub x 8 8 in
for i = 0 to length x - 1 do set_uint8 x i 0x00 done ;
for i = -8 to 8 do
try set x' i ff with Invalid_argument _ -> ()
done;
let acc = ref 0 in
for i = 0 to length x - 1 do
acc := !acc + get_uint8 x i
done ;
if !acc <> (length x' * 0xff) then
failwith "test_subview_containment_set"
in
test set_char '\255',
test set_uint8 0xff,
test BE.set_uint16 0xffff,
test BE.set_uint32 0xffffffffl,
test BE.set_uint64 0xffffffffffffffffL,
test LE.set_uint16 0xffff,
test LE.set_uint32 0xffffffffl,
test LE.set_uint64 0xffffffffffffffffL,
test HE.set_uint16 0xffff,
test HE.set_uint32 0xffffffffl,
test HE.set_uint64 0xffffffffffffffffL
let regression_244 () =
let whole = Cstruct.create 44943 in
let empty = Cstruct.sub whole 0 0 in
try
let _big = Cstruct.sub empty 0 204 in
Alcotest.fail "could get a bigger buffer via sub"
with Invalid_argument _ -> ()
let suite = [
"test empty cstruct", `Quick, test_empty_cstruct;
"test anti cstruct", `Quick, test_anti_cstruct;
"test positive shift", `Quick, test_positive_shift;
"test negative shift", `Quick, test_negative_shift;
"test bad positive shift", `Quick, test_bad_positive_shift;
"test sub", `Quick, test_sub;
"test sub_copy", `Quick, test_sub_copy;
"test negative sub", `Quick, test_negative_sub;
"test sub len too big", `Quick, test_sub_len_too_big;
"test sub len too small", `Quick, test_sub_len_too_small;
"test sub offset too big", `Quick, test_sub_offset_too_big;
"test of_bigarray negative params", `Quick, test_of_bigarray_negative_params;
"test of_bigarray large offset", `Quick, test_of_bigarray_large_offset;
"test of_bigarray large length", `Quick, test_of_bigarray_large_length;
"test blit offset too big", `Quick, test_blit_offset_too_big;
"test blit offset too small", `Quick, test_blit_offset_too_small;
"test blit dst offset too big", `Quick, test_blit_dst_offset_too_big;
"test blit dst offset too small", `Quick, test_blit_dst_offset_too_small;
"test blit dst offset negative", `Quick, test_blit_dst_offset_negative;
"test blit len too big", `Quick, test_blit_len_too_big;
"test blit len too big2", `Quick, test_blit_len_too_big2;
"test blit len too small", `Quick, test_blit_len_too_small;
"test view bounds too small", `Quick, test_view_bounds_too_small;
"test_view_bounds_too_small_get_u8" , `Quick, test_view_bounds_too_small_get_u8;
"test_view_bounds_too_small_get_char" , `Quick, test_view_bounds_too_small_get_char;
"test_view_bounds_too_small_get_be16" , `Quick, test_view_bounds_too_small_get_be16;
"test_view_bounds_too_small_get_be32" , `Quick, test_view_bounds_too_small_get_be32;
"test_view_bounds_too_small_get_be64" , `Quick, test_view_bounds_too_small_get_be64;
"test_view_bounds_too_small_get_le16" , `Quick, test_view_bounds_too_small_get_le16;
"test_view_bounds_too_small_get_le32" , `Quick, test_view_bounds_too_small_get_le32;
"test_view_bounds_too_small_get_le64" , `Quick, test_view_bounds_too_small_get_le64;
"test_view_bounds_too_small_get_he16" , `Quick, test_view_bounds_too_small_get_he16;
"test_view_bounds_too_small_get_he32" , `Quick, test_view_bounds_too_small_get_he32;
"test_view_bounds_too_small_get_he64" , `Quick, test_view_bounds_too_small_get_he64;
"test_lenv_overflow", `Quick, test_lenv_overflow;
"test_copyv_overflow", `Quick, test_copyv_overflow;
"test_subview_containment_get_char", `Quick, test_subview_containment_get_char;
"test_subview_containment_get_8" , `Quick, test_subview_containment_get_8;
"test_subview_containment_get_be16", `Quick, test_subview_containment_get_be16;
"test_subview_containment_get_be32", `Quick, test_subview_containment_get_be32;
"test_subview_containment_get_be64", `Quick, test_subview_containment_get_be64;
"test_subview_containment_get_le16", `Quick, test_subview_containment_get_le16;
"test_subview_containment_get_le32", `Quick, test_subview_containment_get_le32;
"test_subview_containment_get_le64", `Quick, test_subview_containment_get_le64;
"test_subview_containment_get_le16", `Quick, test_subview_containment_get_he16;
"test_subview_containment_get_le32", `Quick, test_subview_containment_get_he32;
"test_subview_containment_get_le64", `Quick, test_subview_containment_get_he64;
"test_subview_containment_set_char", `Quick, test_subview_containment_set_char;
"test_subview_containment_set_8" , `Quick, test_subview_containment_set_8;
"test_subview_containment_set_be16", `Quick, test_subview_containment_set_be16;
"test_subview_containment_set_be32", `Quick, test_subview_containment_set_be32;
"test_subview_containment_set_be64", `Quick, test_subview_containment_set_be64;
"test_subview_containment_set_le16", `Quick, test_subview_containment_set_le16;
"test_subview_containment_set_le32", `Quick, test_subview_containment_set_le32;
"test_subview_containment_set_le64", `Quick, test_subview_containment_set_le64;
"test_subview_containment_set_le16", `Quick, test_subview_containment_set_he16;
"test_subview_containment_set_le32", `Quick, test_subview_containment_set_he32;
"test_subview_containment_set_le64", `Quick, test_subview_containment_set_he64;
"regression 244", `Quick, regression_244;
]

1
unikernel/duniverse/ocaml-cstruct/lib_test/bounds.mli Normal file
View file

@ -0,0 +1 @@
val suite: unit Alcotest.test_case list

21
unikernel/duniverse/ocaml-cstruct/lib_test/dune Normal file
View file

@ -0,0 +1,21 @@
(executable
(libraries cstruct alcotest cstruct-sexp)
(modules bounds tests)
(name tests))
(executable
(libraries cstruct alcotest)
(modules parse)
(name parse))
(rule
(alias runtest)
(package cstruct-sexp)
(action
(run ./tests.exe -e)))
(rule
(alias runtest)
(package cstruct)
(action
(run ./parse.exe -e)))

657
unikernel/duniverse/ocaml-cstruct/lib_test/parse.ml Normal file
View file

@ -0,0 +1,657 @@
(* (c) 2016 Daniel C. Bünzli
(c) 2020 Romain Calascibetta *)
open Cstruct
let cstruct =
let pp ppf x = Format.fprintf ppf "%S" (Cstruct.to_string x) in
let equal a b = String.equal (Cstruct.to_string a) (Cstruct.to_string b) in
Alcotest.testable pp equal
module Alcotest = struct
include Alcotest
let string = Alcotest.testable (Fmt.fmt "%S") String.equal
end
let misc =
Alcotest.test_case "misc" `Quick @@ fun () ->
Alcotest.(check cstruct) "empty" empty (Cstruct.create 0) ;
Alcotest.(check cstruct) "abc" (string "abc") (Cstruct.of_string "abc") ;
Alcotest.(check cstruct) "abc" (string ~off:0 ~len:1 "abc") (Cstruct.of_string "a") ;
Alcotest.(check cstruct) "abc" (string ~off:1 ~len:1 "abc") (Cstruct.of_string "b") ;
Alcotest.(check cstruct) "abc" (string ~off:1 ~len:2 "abc") (Cstruct.of_string "bc") ;
Alcotest.(check cstruct) "abc" (string ~off:2 ~len:1 "abc") (Cstruct.of_string "c") ;
Alcotest.(check cstruct) "abc" (string ~off:3 ~len:0 "abc") (Cstruct.create 0) ;
let sub = string ~off:2 ~len:1 "abc" in
Alcotest.(check int) "start_pos" (start_pos sub) 2 ;
Alcotest.(check int) "stop_pos" (stop_pos sub) 3 ;
Alcotest.(check int) "length" (length sub) 1 ;
let index_out_of_bounds = Invalid_argument "index out of bounds" in
Alcotest.check_raises "get" index_out_of_bounds @@ fun () -> ignore @@ get sub 3 ;
Alcotest.check_raises "get" index_out_of_bounds @@ fun () -> ignore @@ get sub 2 ;
Alcotest.check_raises "get" index_out_of_bounds @@ fun () -> ignore @@ get sub 1 ;
Alcotest.(check char) "get" (get sub 0) 'c' ;
Alcotest.(check int) "get_byte" (get_byte sub 0) 0x63 ;
;;
let head =
Alcotest.test_case "head" `Quick @@ fun () ->
let { Cstruct.buffer= v; _ } = Cstruct.of_string "abc" in
let empty = buffer ~off:2 ~len:0 v in
let bc = buffer ~off:1 ~len:2 v in
Alcotest.(check (option char)) "empty" (head empty) None ;
Alcotest.(check (option char)) "empty" (head ~rev:true empty) None ;
Alcotest.(check (option char)) "bc" (head bc) (Some 'b') ;
Alcotest.(check (option char)) "bc" (head ~rev:true bc) (Some 'c') ;
;;
let start =
Alcotest.test_case "start" `Quick @@ fun () ->
let empty_pos cs pos =
Alcotest.(check int) "length" (length cs) 0 ;
Alcotest.(check int) "start_pos" (start_pos cs) pos in
let { Cstruct.buffer= abc; _ } = Cstruct.of_string "abc" in
empty_pos (start @@ string "") 0 ;
empty_pos (start @@ buffer ~off:0 ~len:0 abc) 0 ;
empty_pos (start @@ buffer ~off:0 ~len:1 abc) 0 ;
empty_pos (start @@ buffer ~off:0 ~len:2 abc) 0 ;
empty_pos (start @@ buffer ~off:0 ~len:3 abc) 0 ;
empty_pos (start @@ buffer ~off:1 ~len:0 abc) 1 ;
empty_pos (start @@ buffer ~off:1 ~len:1 abc) 1 ;
empty_pos (start @@ buffer ~off:1 ~len:2 abc) 1 ;
empty_pos (start @@ buffer ~off:2 ~len:0 abc) 2 ;
empty_pos (start @@ buffer ~off:2 ~len:1 abc) 2 ;
empty_pos (start @@ buffer ~off:3 ~len:0 abc) 3 ;
;;
let stop =
Alcotest.test_case "stop" `Quick @@ fun () ->
let empty_pos cs pos =
Alcotest.(check int) "length" (length cs) 0 ;
Alcotest.(check int) "start_pos" (start_pos cs) pos in
let { Cstruct.buffer= abc; _ } = Cstruct.of_string "abc" in
empty_pos (stop @@ string "") 0 ;
empty_pos (stop @@ buffer ~off:0 ~len:0 abc) 0 ;
empty_pos (stop @@ buffer ~off:0 ~len:1 abc) 1 ;
empty_pos (stop @@ buffer ~off:0 ~len:2 abc) 2 ;
empty_pos (stop @@ buffer ~off:0 ~len:3 abc) 3 ;
empty_pos (stop @@ buffer ~off:1 ~len:0 abc) 1 ;
empty_pos (stop @@ buffer ~off:1 ~len:1 abc) 2 ;
empty_pos (stop @@ buffer ~off:1 ~len:2 abc) 3 ;
empty_pos (stop @@ buffer ~off:2 ~len:0 abc) 2 ;
empty_pos (stop @@ buffer ~off:2 ~len:1 abc) 3 ;
empty_pos (stop @@ buffer ~off:3 ~len:0 abc) 3 ;
;;
let tail =
Alcotest.test_case "tail" `Quick @@ fun () ->
let empty_pos cs pos =
Alcotest.(check int) "length" (length cs) 0 ;
Alcotest.(check int) "start_pos" (start_pos cs) pos in
let { Cstruct.buffer= abc; _ } = Cstruct.of_string "abc" in
empty_pos (tail @@ string "") 0 ;
empty_pos (tail @@ buffer ~off:0 ~len:0 abc) 0 ;
empty_pos (tail @@ buffer ~off:0 ~len:1 abc) 1 ;
Alcotest.(check cstruct) "b" (tail @@ buffer ~off:0 ~len:2 abc) (string "b") ;
Alcotest.(check cstruct) "bc" (tail @@ buffer ~off:0 ~len:3 abc) (string "bc") ;
empty_pos (tail @@ buffer ~off:1 ~len:0 abc) 1 ;
empty_pos (tail @@ buffer ~off:1 ~len:1 abc) 2 ;
Alcotest.(check cstruct) "c" (tail @@ buffer ~off:1 ~len:2 abc) (string "c") ;
empty_pos (tail @@ buffer ~off:2 ~len:0 abc) 2 ;
empty_pos (tail @@ buffer ~off:2 ~len:1 abc) 3 ;
empty_pos (tail @@ buffer ~off:3 ~len:0 abc) 3 ;
;;
let is_empty =
Alcotest.test_case "is_empty" `Quick @@ fun () ->
Alcotest.(check bool) "empty" (is_empty (string "")) true ;
let { Cstruct.buffer= abcd; _ } = Cstruct.of_string "abcd" in
let { Cstruct.buffer= huyi; _ } = Cstruct.of_string "huyi" in
Alcotest.(check bool) "empty" (is_empty (buffer ~off:4 ~len:0 abcd)) true ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:0 ~len:0 huyi)) true ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:0 ~len:1 huyi)) false ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:0 ~len:2 huyi)) false ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:0 ~len:3 huyi)) false ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:0 ~len:4 huyi)) false ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:1 ~len:0 abcd)) true ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:1 ~len:1 huyi)) false ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:1 ~len:2 huyi)) false ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:1 ~len:3 huyi)) false ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:2 ~len:0 abcd)) true ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:2 ~len:1 huyi)) false ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:2 ~len:2 huyi)) false ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:3 ~len:0 abcd)) true ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:3 ~len:1 huyi)) false ;
Alcotest.(check bool) "empty" (is_empty (buffer ~off:4 ~len:0 huyi)) true ;
;;
let is_prefix =
Alcotest.test_case "is_prefix" `Quick @@ fun () ->
let { Cstruct.buffer= ugoadfj; _ } = Cstruct.of_string "ugoadf" in
let { Cstruct.buffer= dfkdjf; _ } = Cstruct.of_string "dfkdjf" in
let { Cstruct.buffer= abhablablu; _ } = Cstruct.of_string "abhablablu" in
let { Cstruct.buffer= hadfdffdf; _ } = Cstruct.of_string "hadfdffdf" in
let { Cstruct.buffer= hadhabfdffdf; _ } = Cstruct.of_string "hadhabfdffdf" in
let { Cstruct.buffer= iabla; _ } = Cstruct.of_string "iabla" in
let empty0 = buffer ~off:3 ~len:0 ugoadfj in
let empty1 = buffer ~off:4 ~len:0 dfkdjf in
let habla = buffer ~off:2 ~len:5 abhablablu in
let h = buffer ~off:0 ~len:1 hadfdffdf in
let ha = buffer ~off:0 ~len:2 hadfdffdf in
let hab = buffer ~off:3 ~len:3 hadhabfdffdf in
let abla = buffer ~off:1 ~len:4 iabla in
Alcotest.(check cstruct) "empty" empty0 (Cstruct.of_string "") ;
Alcotest.(check cstruct) "empty" empty1 (Cstruct.of_string "") ;
Alcotest.(check cstruct) "habla" habla (Cstruct.of_string "habla") ;
Alcotest.(check cstruct) "h" h (Cstruct.of_string "h") ;
Alcotest.(check cstruct) "ha" ha (Cstruct.of_string "ha") ;
Alcotest.(check cstruct) "hab" hab (Cstruct.of_string "hab") ;
Alcotest.(check cstruct) "abla" abla (Cstruct.of_string "abla") ;
Alcotest.(check bool) "is_prefix empty0 empty0" (is_prefix ~affix:empty0 empty1) true ;
Alcotest.(check bool) "is_prefix empty0 habla" (is_prefix ~affix:empty0 habla) true ;
Alcotest.(check bool) "is_prefix ha empty1" (is_prefix ~affix:ha empty1) false ;
Alcotest.(check bool) "is_prefix ha h" (is_prefix ~affix:ha h) false ;
Alcotest.(check bool) "is_prefix ha ha" (is_prefix ~affix:ha ha) true ;
Alcotest.(check bool) "is_prefix ha hab" (is_prefix ~affix:ha hab) true ;
Alcotest.(check bool) "is_prefix ha habla" (is_prefix ~affix:ha habla) true ;
Alcotest.(check bool) "is_prefix ha abla" (is_prefix ~affix:ha abla) false ;
;;
let is_infix =
Alcotest.test_case "is_infix" `Quick @@ fun () ->
let { Cstruct.buffer= ugoadfj; _ } = Cstruct.of_string "ugoadfj" in
let { Cstruct.buffer= dfkdjf; _ } = Cstruct.of_string "dfkdjf" in
let { Cstruct.buffer= aasdflablu; _ } = Cstruct.of_string "aasdflablu" in
let { Cstruct.buffer= cda; _ } = Cstruct.of_string "cda" in
let { Cstruct.buffer= h; _ } = Cstruct.of_string "h" in
let { Cstruct.buffer= uhadfdffdf; _ } = Cstruct.of_string "uhadfdffdf" in
let { Cstruct.buffer= ah; _ } = Cstruct.of_string "ah" in
let { Cstruct.buffer= aaaha; _ } = Cstruct.of_string "aaaha" in
let { Cstruct.buffer= ahaha; _ } = Cstruct.of_string "ahaha" in
let { Cstruct.buffer= hahbdfdf; _ } = Cstruct.of_string "hahbdfdf" in
let { Cstruct.buffer= blhahbdfdf; _ } = Cstruct.of_string "blhahbdfdf" in
let { Cstruct.buffer= fblhahbdfdfl; _ } = Cstruct.of_string "fblhahbdfdfl" in
let empty0 = buffer ~off:1 ~len:0 ugoadfj in
let empty1 = buffer ~off:2 ~len:0 dfkdjf in
let asdf = buffer ~off:1 ~len:4 aasdflablu in
let a = buffer ~off:2 ~len:1 cda in
let h = buffer ~off:0 ~len:1 h in
let ha = buffer ~off:1 ~len:2 uhadfdffdf in
let ah = buffer ~off:0 ~len:2 ah in
let aha = buffer ~off:2 ~len:3 aaaha in
let haha = buffer ~off:1 ~len:4 ahaha in
let hahb = buffer ~off:0 ~len:4 hahbdfdf in
let blhahb = buffer ~off:0 ~len:6 blhahbdfdf in
let blha = buffer ~off:1 ~len:4 fblhahbdfdfl in
let blh = buffer ~off:1 ~len:3 fblhahbdfdfl in
Alcotest.(check cstruct) "asdf" asdf (Cstruct.of_string "asdf") ;
Alcotest.(check cstruct) "ha" ha (Cstruct.of_string "ha") ;
Alcotest.(check cstruct) "h" h (Cstruct.of_string "h") ;
Alcotest.(check cstruct) "a" a (Cstruct.of_string "a") ;
Alcotest.(check cstruct) "aha" aha (Cstruct.of_string "aha") ;
Alcotest.(check cstruct) "haha" haha (Cstruct.of_string "haha") ;
Alcotest.(check cstruct) "hahb" hahb (Cstruct.of_string "hahb") ;
Alcotest.(check cstruct) "blhahb" blhahb (Cstruct.of_string "blhahb") ;
Alcotest.(check cstruct) "blha" blha (Cstruct.of_string "blha") ;
Alcotest.(check cstruct) "blh" blh (Cstruct.of_string "blh") ;
Alcotest.(check bool) "is_infix empty0 empty1" (is_infix ~affix:empty0 empty1) true ;
Alcotest.(check bool) "is_infix empty0 asdf" (is_infix ~affix:empty0 asdf) true ;
Alcotest.(check bool) "is_infix empty0 ha" (is_infix ~affix:empty0 ha) true ;
Alcotest.(check bool) "is_infix ha empty1" (is_infix ~affix:ha empty1) false ;
Alcotest.(check bool) "is_infix ha a" (is_infix ~affix:ha a) false ;
Alcotest.(check bool) "is_infix ha h" (is_infix ~affix:ha h) false ;
Alcotest.(check bool) "is_infix ha ah" (is_infix ~affix:ha ah) false ;
Alcotest.(check bool) "is_infix ha ha" (is_infix ~affix:ha ha) true ;
Alcotest.(check bool) "is_infix ha aha" (is_infix ~affix:ha aha) true ;
Alcotest.(check bool) "is_infix ha haha" (is_infix ~affix:ha haha) true ;
Alcotest.(check bool) "is_infix ha hahb" (is_infix ~affix:ha hahb) true ;
Alcotest.(check bool) "is_infix ha blhahb" (is_infix ~affix:ha blhahb) true ;
Alcotest.(check bool) "is_infix ha blha" (is_infix ~affix:ha blha) true ;
Alcotest.(check bool) "is_infix ha blh" (is_infix ~affix:ha blh) false ;
;;
let is_suffix =
Alcotest.test_case "is_suffix" `Quick @@ fun () ->
let { Cstruct.buffer= ugoadfj; _ } = Cstruct.of_string "ugoadfj" in
let { Cstruct.buffer= dfkdjf; _ } = Cstruct.of_string "dfkdjf" in
let { Cstruct.buffer= aasdflablu; _ } = Cstruct.of_string "aasdflablu" in
let { Cstruct.buffer= cda; _ } = Cstruct.of_string "cda" in
let { Cstruct.buffer= h; _ } = Cstruct.of_string "h" in
let { Cstruct.buffer= uhadfdffdf; _ } = Cstruct.of_string "uhadfdffdf" in
let { Cstruct.buffer= ah; _ } = Cstruct.of_string "ah" in
let { Cstruct.buffer= aaaha; _ } = Cstruct.of_string "aaaha" in
let { Cstruct.buffer= ahaha; _ } = Cstruct.of_string "ahaha" in
let { Cstruct.buffer= hahbdfdf; _ } = Cstruct.of_string "hahbdfdf" in
let empty0 = buffer ~off:1 ~len:0 ugoadfj in
let empty1 = buffer ~off:2 ~len:0 dfkdjf in
let asdf = buffer ~off:1 ~len:4 aasdflablu in
let a = buffer ~off:2 ~len:1 cda in
let h = buffer ~off:0 ~len:1 h in
let ha = buffer ~off:1 ~len:2 uhadfdffdf in
let ah = buffer ~off:0 ~len:2 ah in
let aha = buffer ~off:2 ~len:3 aaaha in
let haha = buffer ~off:1 ~len:4 ahaha in
let hahb = buffer ~off:0 ~len:4 hahbdfdf in
Alcotest.(check cstruct) "asdf" asdf (Cstruct.of_string "asdf") ;
Alcotest.(check cstruct) "ha" ha (Cstruct.of_string "ha") ;
Alcotest.(check cstruct) "h" h (Cstruct.of_string "h") ;
Alcotest.(check cstruct) "a" a (Cstruct.of_string "a") ;
Alcotest.(check cstruct) "aha" aha (Cstruct.of_string "aha") ;
Alcotest.(check cstruct) "haha" haha (Cstruct.of_string "haha") ;
Alcotest.(check cstruct) "hahb" hahb (Cstruct.of_string "hahb") ;
Alcotest.(check bool) "is_suffix empty0 empty1" (is_suffix ~affix:empty0 empty1) true ;
Alcotest.(check bool) "is_suffix empty0 asdf" (is_suffix ~affix:empty0 asdf) true ;
Alcotest.(check bool) "is_suffix ha empty1" (is_suffix ~affix:ha empty1) false ;
Alcotest.(check bool) "is_suffix ha a" (is_suffix ~affix:ha a) false ;
Alcotest.(check bool) "is_suffix ha h" (is_suffix ~affix:ha h) false ;
Alcotest.(check bool) "is_suffix ha ah" (is_suffix ~affix:ha ah) false ;
Alcotest.(check bool) "is_suffix ha ha" (is_suffix ~affix:ha ha) true ;
Alcotest.(check bool) "is_suffix ha aha" (is_suffix ~affix:ha aha) true ;
Alcotest.(check bool) "is_suffix ha haha" (is_suffix ~affix:ha haha) true ;
Alcotest.(check bool) "is_suffix ha hahb" (is_suffix ~affix:ha hahb) false ;
;;
let () = Printexc.record_backtrace true
let for_all =
Alcotest.test_case "for_all" `Quick @@ fun () ->
let { Cstruct.buffer= asldfksaf; _ } = Cstruct.of_string "asldfksaf" in
let { Cstruct.buffer= sf123df; _ } = Cstruct.of_string "sf123df" in
let { Cstruct.buffer= _412; _ } = Cstruct.of_string "412" in
let { Cstruct.buffer= aaa142; _ } = Cstruct.of_string "aaa142" in
let { Cstruct.buffer= aad124; _ } = Cstruct.of_string "aad124" in
let empty = buffer ~off:3 ~len:0 asldfksaf in
let s123 = buffer ~off:2 ~len:3 sf123df in
let s412 = buffer _412 in
let s142 = buffer ~off:3 aaa142 in
let s124 = buffer ~off:3 aad124 in
Alcotest.(check cstruct) "empty" empty (Cstruct.of_string "") ;
Alcotest.(check cstruct) "123" s123 (Cstruct.of_string "123") ;
Alcotest.(check cstruct) "412" s412 (Cstruct.of_string "412") ;
Alcotest.(check cstruct) "142" s142 (Cstruct.of_string "142") ;
Alcotest.(check cstruct) "124" s124 (Cstruct.of_string "124") ;
Alcotest.(check bool) "for_all" (for_all (fun _ -> false) empty) true ;
Alcotest.(check bool) "for_all" (for_all (fun _ -> true) empty) true ;
Alcotest.(check bool) "for_all" (for_all (fun c -> Char.code c < 0x34) s123) true ;
Alcotest.(check bool) "for_all" (for_all (fun c -> Char.code c < 0x34) s412) false ;
Alcotest.(check bool) "for_all" (for_all (fun c -> Char.code c < 0x34) s142) false ;
Alcotest.(check bool) "for_all" (for_all (fun c -> Char.code c < 0x34) s124) false ;
;;
let exists =
Alcotest.test_case "exists" `Quick @@ fun () ->
let { Cstruct.buffer= asldfksaf; _ } = Cstruct.of_string "asldfksaf" in
let { Cstruct.buffer= a541; _ } = Cstruct.of_string "a541" in
let { Cstruct.buffer= a154; _ } = Cstruct.of_string "a154" in
let { Cstruct.buffer= _654adf; _ } = Cstruct.of_string "654adf" in
let empty = buffer ~off:3 ~len:0 asldfksaf in
let s541 = buffer ~off:1 ~len:3 a541 in
let s154 = buffer ~off:1 a154 in
let s654 = buffer ~len:3 _654adf in
Alcotest.(check cstruct) "empty" empty (Cstruct.of_string "") ;
Alcotest.(check cstruct) "541" s541 (Cstruct.of_string "541") ;
Alcotest.(check cstruct) "154" s154 (Cstruct.of_string "154") ;
Alcotest.(check cstruct) "654" s654 (Cstruct.of_string "654") ;
Alcotest.(check bool) "exists" (exists (fun _ -> false) empty) false ;
Alcotest.(check bool) "exists" (exists (fun _ -> true) empty) false ;
Alcotest.(check bool) "exists" (exists (fun c -> Char.code c < 0x34) s541) true ;
Alcotest.(check bool) "exists" (exists (fun c -> Char.code c < 0x34) s154) true ;
Alcotest.(check bool) "exists" (exists (fun c -> Char.code c < 0x34) s654) false ;
;;
let trim =
Alcotest.test_case "trim" `Quick @@ fun () ->
let drop_a c = c = 'a' in
let { Cstruct.buffer= base; _ } = Cstruct.of_string "00aaaabcdaaaa00" in
let aaaabcdaaaa = buffer ~off:2 ~len:11 base in
let aaaabcd = buffer ~off:2 ~len:7 base in
let bcdaaaa = buffer ~off:6 ~len:7 base in
let aaaa = buffer ~off:2 ~len:4 base in
Alcotest.(check cstruct) "trim" (trim (string "\t abcd \t")) (Cstruct.of_string "abcd") ;
Alcotest.(check cstruct) "trim" (trim aaaabcdaaaa) (Cstruct.of_string "aaaabcdaaaa") ;
Alcotest.(check cstruct) "trim" (trim ~drop:drop_a aaaabcdaaaa) (Cstruct.of_string "bcd") ;
Alcotest.(check cstruct) "trim" (trim ~drop:drop_a aaaabcd) (Cstruct.of_string "bcd") ;
Alcotest.(check cstruct) "trim" (trim ~drop:drop_a bcdaaaa) (Cstruct.of_string "bcd") ;
let empty_pos cs pos =
Alcotest.(check int) "length" (length cs) 0 ;
Alcotest.(check int) "start_pos" (start_pos cs) pos in
empty_pos (trim ~drop:drop_a aaaa) 4 ;
empty_pos (trim (string " ")) 2 ;
;;
let span =
Alcotest.test_case "span" `Quick @@ fun () ->
(* XXX(dinosaure): clash of names between [start] and [Cstruct.start]. *)
let open Cstruct in
let test ?(rev= false) ?min ?max ?sat cs (cl, cr as expect) =
let res = span ~rev ?min ?max ?sat cs in
let t = take ~rev ?min ?max ?sat cs in
let d = drop ~rev ?min ?max ?sat cs in
Alcotest.(check (pair cstruct cstruct)) "span" res expect ;
Alcotest.(check cstruct) "take" t (if rev then cr else cl) ;
Alcotest.(check cstruct) "drop" d (if rev then cl else cr) in
let invalid ?rev ?min ?max ?sat cs =
Alcotest.check_raises "invalid" (Invalid_argument "span")
(fun () -> try ignore @@ span ?rev ?min ?max ?sat cs
with Invalid_argument _ -> invalid_arg "span") in
let is_white = function ' ' | '\t' .. '\r' -> true | _ -> false in
let is_letter = function 'A' .. 'Z' | 'a' .. 'z' -> true | _ -> false in
let { Cstruct.buffer= base; _ } = Cstruct.of_string "0ab cd0" in
let empty = buffer ~off:3 ~len:0 base in
let ab_cd = buffer ~off:1 ~len:5 base in
let ab = buffer ~off:1 ~len:2 base in
let _cd = buffer ~off:3 ~len:3 base in
let cd = buffer ~off:4 ~len:2 base in
let ab_ = buffer ~off:1 ~len:3 base in
let a = buffer ~off:1 ~len:1 base in
let b_cd = buffer ~off:2 ~len:4 base in
let b = buffer ~off:2 ~len:1 base in
let d = buffer ~off:5 ~len:1 base in
let ab_c = buffer ~off:1 ~len:4 base in
test ~rev:false ~min:1 ~max:0 ab_cd (start ab_cd, ab_cd) ;
test ~rev:true ~min:1 ~max:0 ab_cd (ab_cd, stop ab_cd) ;
test ~sat:is_white ab_cd (start ab_cd, ab_cd) ;
test ~sat:is_letter ab_cd (ab, _cd) ;
test ~max:1 ~sat:is_letter ab_cd (a, b_cd) ;
test ~max:0 ~sat:is_letter ab_cd (start ab_cd, ab_cd) ;
test ~rev:true ~sat:is_white ab_cd (ab_cd, stop ab_cd) ;
test ~rev:true ~sat:is_letter ab_cd (ab_, cd) ;
test ~rev:true ~max:1 ~sat:is_letter ab_cd (ab_c, d) ;
test ~rev:true ~max:0 ~sat:is_letter ab_cd (ab_cd, stop ab_cd) ;
test ~sat:is_letter ab (ab, stop ab) ;
test ~max:1 ~sat:is_letter ab (a, b) ;
test ~sat:is_letter b (b, empty) ;
test ~rev:true ~max:1 ~sat:is_letter ab (a, b) ;
test ~max:1 ~sat:is_white ab (start ab, ab) ;
test ~rev:true ~sat:is_white empty (empty, empty) ;
test ~sat:is_white empty (empty, empty) ;
(* TODO: invalid *)
invalid ~rev:false ~min:(-1) empty ;
invalid ~rev:true ~min:(-1) empty ;
invalid ~rev:false ~max:(-1) empty ;
invalid ~rev:true ~max:(-1) empty ;
test ~rev:false empty (empty, empty) ;
test ~rev:true empty (empty, empty) ;
test ~rev:false ~min:0 ~max:0 empty (empty, empty) ;
test ~rev:true ~min:0 ~max:0 empty (empty, empty) ;
test ~rev:false ~min:1 ~max:0 empty (empty, empty) ;
test ~rev:true ~min:1 ~max:0 empty (empty, empty) ;
test ~rev:false ~max:0 ab_cd (start ab_cd, ab_cd) ;
test ~rev:true ~max:0 ab_cd (ab_cd, stop ab_cd) ;
test ~rev:false ~max:2 ab_cd (ab, _cd) ;
test ~rev:true ~max:2 ab_cd (ab_, cd) ;
test ~rev:false ~min:6 ab_cd (start ab_cd, ab_cd) ;
test ~rev:true ~min:6 ab_cd (ab_cd, stop ab_cd) ;
test ~rev:false ab_cd (ab_cd, stop ab_cd) ;
test ~rev:true ab_cd (start ab_cd, ab_cd) ;
test ~rev:false ~max:30 ab_cd (ab_cd, stop ab_cd) ;
test ~rev:true ~max:30 ab_cd (start ab_cd, ab_cd) ;
test ~rev:false ~sat:is_white ab_cd (start ab_cd, ab_cd) ;
test ~rev:true ~sat:is_white ab_cd (ab_cd, stop ab_cd) ;
test ~rev:false ~sat:is_letter ab_cd (ab, _cd) ;
test ~rev:true ~sat:is_letter ab_cd (ab_, cd) ;
test ~rev:false ~sat:is_letter ~max:0 ab_cd (start ab_cd, ab_cd) ;
test ~rev:true ~sat:is_letter ~max:0 ab_cd (ab_cd, stop ab_cd) ;
test ~rev:false ~sat:is_letter ~max:1 ab_cd (a, b_cd) ;
test ~rev:true ~sat:is_letter ~max:1 ab_cd (ab_c, d) ;
test ~rev:false ~sat:is_letter ~min:2 ~max:1 ab_cd (start ab_cd, ab_cd) ;
test ~rev:true ~sat:is_letter ~min:2 ~max:1 ab_cd (ab_cd, stop ab_cd) ;
test ~rev:false ~sat:is_letter ~min:3 ab_cd (start ab_cd, ab_cd) ;
test ~rev:true ~sat:is_letter ~min:3 ab_cd (ab_cd, stop ab_cd) ;
;;
let cut =
Alcotest.test_case "cut" `Quick @@ fun () ->
let s str = string ~off:1 ~len:(String.length str) (Fmt.str "\x00%s\x00" str) in
let cut ?rev ~sep str = cut ?rev ~sep:(s sep) (s str) in
let invalid_cut_argument = Invalid_argument "cut: empty separator" in
Alcotest.check_raises "invalid" invalid_cut_argument
(fun () -> ignore (cut ~sep:"" "")) ;
Alcotest.check_raises "invalid" invalid_cut_argument
(fun () -> ignore (cut ~sep:"" "123")) ;
let opc = Alcotest.(option (pair cstruct cstruct)) in
Alcotest.(check opc) "0" (cut ~sep:"," "") None ;
Alcotest.(check opc) "1" (cut ~sep:"," ",") (Some (string "", string "")) ;
Alcotest.(check opc) "2" (cut ~sep:"," ",,") (Some (string "", string ",")) ;
Alcotest.(check opc) "3" (cut ~sep:"," ",,,") (Some (string "", string ",,")) ;
Alcotest.(check opc) "4" (cut ~sep:"," "123") None ;
Alcotest.(check opc) "5" (cut ~sep:"," ",123") (Some (string "", string "123")) ;
Alcotest.(check opc) "6" (cut ~sep:"," "123,") (Some (string "123", string "")) ;
Alcotest.(check opc) "7" (cut ~sep:"," "1,2,3") (Some (string "1", string "2,3")) ;
Alcotest.(check opc) "8" (cut ~sep:"," " 1,2,3") (Some (string " 1", string "2,3")) ;
Alcotest.(check opc) "9" (cut ~sep:"<>" "") None ;
Alcotest.(check opc) "10" (cut ~sep:"<>" "<>") (Some (string "", string "")) ;
Alcotest.(check opc) "11" (cut ~sep:"<>" "<><>") (Some (string "", string "<>")) ;
Alcotest.(check opc) "12" (cut ~sep:"<>" "<><><>") (Some (string "", string "<><>")) ;
Alcotest.(check opc) "13" (cut ~rev:true ~sep:"<>" "1") None ;
Alcotest.(check opc) "14" (cut ~sep:"<>" "123") None ;
Alcotest.(check opc) "15" (cut ~sep:"<>" "<>123") (Some (string "", string "123")) ;
Alcotest.(check opc) "16" (cut ~sep:"<>" "123<>") (Some (string "123", string "")) ;
Alcotest.(check opc) "17" (cut ~sep:"<>" "1<>2<>3") (Some (string "1", string "2<>3")) ;
Alcotest.(check opc) "18" (cut ~sep:"<>" ">>><>>>><>>>><>>>>") (Some (string ">>>", string ">>><>>>><>>>>")) ;
Alcotest.(check opc) "19" (cut ~sep:"<->" "<->>->") (Some (string "", string ">->")) ;
Alcotest.(check opc) "20" (cut ~rev:true ~sep:"<->" "<-") None ;
Alcotest.(check opc) "21" (cut ~sep:"aa" "aa") (Some (string "", string "")) ;
Alcotest.(check opc) "22" (cut ~sep:"aa" "aaa") (Some (string "", string "a")) ;
Alcotest.(check opc) "23" (cut ~sep:"aa" "aaaa") (Some (string "", string "aa")) ;
Alcotest.(check opc) "24" (cut ~sep:"aa" "aaaaa") (Some (string "", string "aaa")) ;
Alcotest.(check opc) "25" (cut ~sep:"aa" "aaaaaa") (Some (string "", string "aaaa")) ;
Alcotest.(check opc) "26" (cut ~sep:"ab" "faaaa") None ;
let rev = true in
Alcotest.check_raises "invalid" invalid_cut_argument
(fun () -> ignore (cut ~rev ~sep:"" "")) ;
Alcotest.check_raises "invalid" invalid_cut_argument
(fun () -> ignore (cut ~rev ~sep:"" "123")) ;
Alcotest.(check opc) "27" (cut ~rev ~sep:"," "") None ;
Alcotest.(check opc) "28" (cut ~rev ~sep:"," ",") (Some (string "", string "")) ;
Alcotest.(check opc) "29" (cut ~rev ~sep:"," ",,") (Some (string ",", string "")) ;
Alcotest.(check opc) "30" (cut ~rev ~sep:"," ",,,") (Some (string ",,", string "")) ;
Alcotest.(check opc) "31" (cut ~rev ~sep:"," "123") None ;
Alcotest.(check opc) "32" (cut ~rev ~sep:"," ",123") (Some (string "", string "123")) ;
Alcotest.(check opc) "33" (cut ~rev ~sep:"," "123,") (Some (string "123", string "")) ;
Alcotest.(check opc) "34" (cut ~rev ~sep:"," "1,2,3") (Some (string "1,2", string "3")) ;
Alcotest.(check opc) "35" (cut ~rev ~sep:"," "1,2,3 ") (Some (string "1,2", string "3 ")) ;
Alcotest.(check opc) "36" (cut ~rev ~sep:"<>" "") None ;
Alcotest.(check opc) "37" (cut ~rev ~sep:"<>" "<>") (Some (string "", string "")) ;
Alcotest.(check opc) "38" (cut ~rev ~sep:"<>" "<><>") (Some (string "<>", string "")) ;
Alcotest.(check opc) "39" (cut ~rev ~sep:"<>" "<><><>") (Some (string "<><>", string "")) ;
Alcotest.(check opc) "40" (cut ~rev ~sep:"<>" "1") None ;
Alcotest.(check opc) "41" (cut ~rev ~sep:"<>" "123") None ;
Alcotest.(check opc) "42" (cut ~rev ~sep:"<>" "<>123") (Some (string "", string "123")) ;
Alcotest.(check opc) "43" (cut ~rev ~sep:"<>" "123<>") (Some (string "123", string "")) ;
Alcotest.(check opc) "44" (cut ~rev ~sep:"<>" "1<>2<>3") (Some (string "1<>2", string "3")) ;
Alcotest.(check opc) "45" (cut ~rev ~sep:"<>" "1<>2<>3 ") (Some (string "1<>2", string "3 ")) ;
Alcotest.(check opc) "46" (cut ~rev ~sep:"<>" ">>><>>>><>>>><>>>>") (Some (string ">>><>>>><>>>>", string ">>>")) ;
Alcotest.(check opc) "47" (cut ~rev ~sep:"<->" "<->>->") (Some (string "", string ">->")) ;
Alcotest.(check opc) "48" (cut ~rev ~sep:"<->" "<-") None ;
Alcotest.(check opc) "49" (cut ~rev ~sep:"aa" "aa") (Some (string "", string "")) ;
Alcotest.(check opc) "50" (cut ~rev ~sep:"aa" "aaa") (Some (string "a", string "")) ;
Alcotest.(check opc) "51" (cut ~rev ~sep:"aa" "aaaa") (Some (string "aa", string "")) ;
Alcotest.(check opc) "52" (cut ~rev ~sep:"aa" "aaaaa") (Some (string "aaa", string "")) ;
Alcotest.(check opc) "53" (cut ~rev ~sep:"aa" "aaaaaa") (Some (string "aaaa", string "")) ;
Alcotest.(check opc) "54" (cut ~rev ~sep:"ab" "afaaaa") None ;
(* TODO: incomplete, see [astring]. *)
;;
let cuts =
Alcotest.test_case "cuts" `Quick @@ fun () ->
let ls = Alcotest.(list string) in
let invalid_cuts_argument = Invalid_argument "cuts: empty separator" in
let s str = string ~off:1 ~len:(String.length str) (Fmt.str "\x00%s\x00" str) in
let cuts ?empty ?rev ~sep str =
let res = cuts ?empty ?rev ~sep:(s sep) (s str) in
List.map Cstruct.to_string res in
Alcotest.check_raises "invalid" invalid_cuts_argument
(fun () -> ignore (cuts ~sep:"" "")) ;
Alcotest.check_raises "invalid" invalid_cuts_argument
(fun () -> ignore (cuts ~sep:"" "")) ;
Alcotest.(check ls) "0" (cuts ~empty:true ~sep:"," "") [""] ;
Alcotest.(check ls) "1" (cuts ~empty:false ~sep:"," "") [] ;
Alcotest.(check ls) "2" (cuts ~empty:true ~sep:"," "") [""];
Alcotest.(check ls) "3" (cuts ~empty:false ~sep:"," "") [];
Alcotest.(check ls) "4" (cuts ~empty:true ~sep:"," ",") [""; ""];
Alcotest.(check ls) "5" (cuts ~empty:false ~sep:"," ",") [];
Alcotest.(check ls) "6" (cuts ~empty:true ~sep:"," ",,") [""; ""; ""];
Alcotest.(check ls) "7" (cuts ~empty:false ~sep:"," ",,") [];
Alcotest.(check ls) "8" (cuts ~empty:true ~sep:"," ",,,") [""; ""; ""; ""];
Alcotest.(check ls) "9" (cuts ~empty:false ~sep:"," ",,,") [];
Alcotest.(check ls) "10" (cuts ~empty:true ~sep:"," "123") ["123"];
Alcotest.(check ls) "11" (cuts ~empty:false ~sep:"," "123") ["123"];
Alcotest.(check ls) "12" (cuts ~empty:true ~sep:"," ",123") [""; "123"];
Alcotest.(check ls) "13" (cuts ~empty:false ~sep:"," ",123") ["123"];
Alcotest.(check ls) "14" (cuts ~empty:true ~sep:"," "123,") ["123"; ""];
Alcotest.(check ls) "15" (cuts ~empty:false ~sep:"," "123,") ["123";];
Alcotest.(check ls) "16" (cuts ~empty:true ~sep:"," "1,2,3") ["1"; "2"; "3"];
Alcotest.(check ls) "17" (cuts ~empty:false ~sep:"," "1,2,3") ["1"; "2"; "3"];
Alcotest.(check ls) "18" (cuts ~empty:true ~sep:"," "1, 2, 3") ["1"; " 2"; " 3"];
Alcotest.(check ls) "19" (cuts ~empty:false ~sep:"," "1, 2, 3") ["1"; " 2"; " 3"];
Alcotest.(check ls) "20" (cuts ~empty:true ~sep:"," ",1,2,,3,") [""; "1"; "2"; ""; "3"; ""];
Alcotest.(check ls) "21" (cuts ~empty:false ~sep:"," ",1,2,,3,") ["1"; "2"; "3";];
Alcotest.(check ls) "22" (cuts ~empty:true ~sep:"," ", 1, 2,, 3,")
[""; " 1"; " 2"; ""; " 3"; ""];
Alcotest.(check ls) "23" (cuts ~empty:false ~sep:"," ", 1, 2,, 3,") [" 1"; " 2";" 3";];
Alcotest.(check ls) "24" (cuts ~empty:true ~sep:"<>" "") [""];
Alcotest.(check ls) "25" (cuts ~empty:false ~sep:"<>" "") [];
Alcotest.(check ls) "26" (cuts ~empty:true ~sep:"<>" "<>") [""; ""];
Alcotest.(check ls) "27" (cuts ~empty:false ~sep:"<>" "<>") [];
Alcotest.(check ls) "28" (cuts ~empty:true ~sep:"<>" "<><>") [""; ""; ""];
Alcotest.(check ls) "29" (cuts ~empty:false ~sep:"<>" "<><>") [];
Alcotest.(check ls) "30" (cuts ~empty:true ~sep:"<>" "<><><>") [""; ""; ""; ""];
Alcotest.(check ls) "31" (cuts ~empty:false ~sep:"<>" "<><><>") [];
Alcotest.(check ls) "32" (cuts ~empty:true ~sep:"<>" "123") [ "123" ];
Alcotest.(check ls) "33" (cuts ~empty:false ~sep:"<>" "123") [ "123" ];
Alcotest.(check ls) "34" (cuts ~empty:true ~sep:"<>" "<>123") [""; "123"];
Alcotest.(check ls) "35" (cuts ~empty:false ~sep:"<>" "<>123") ["123"];
Alcotest.(check ls) "36" (cuts ~empty:true ~sep:"<>" "123<>") ["123"; ""];
Alcotest.(check ls) "37" (cuts ~empty:false ~sep:"<>" "123<>") ["123"];
Alcotest.(check ls) "38" (cuts ~empty:true ~sep:"<>" "1<>2<>3") ["1"; "2"; "3"];
Alcotest.(check ls) "39" (cuts ~empty:false ~sep:"<>" "1<>2<>3") ["1"; "2"; "3"];
Alcotest.(check ls) "40" (cuts ~empty:true ~sep:"<>" "1<> 2<> 3") ["1"; " 2"; " 3"];
Alcotest.(check ls) "41" (cuts ~empty:false ~sep:"<>" "1<> 2<> 3") ["1"; " 2"; " 3"];
Alcotest.(check ls) "42" (cuts ~empty:true ~sep:"<>" "<>1<>2<><>3<>")
[""; "1"; "2"; ""; "3"; ""];
Alcotest.(check ls) "43" (cuts ~empty:false ~sep:"<>" "<>1<>2<><>3<>") ["1"; "2";"3";];
Alcotest.(check ls) "44" (cuts ~empty:true ~sep:"<>" "<> 1<> 2<><> 3<>")
[""; " 1"; " 2"; ""; " 3";""];
Alcotest.(check ls) "45" (cuts ~empty:false ~sep:"<>" "<> 1<> 2<><> 3<>")[" 1"; " 2"; " 3"];
Alcotest.(check ls) "46" (cuts ~empty:true ~sep:"<>" ">>><>>>><>>>><>>>>")
[">>>"; ">>>"; ">>>"; ">>>" ];
Alcotest.(check ls) "47" (cuts ~empty:false ~sep:"<>" ">>><>>>><>>>><>>>>")
[">>>"; ">>>"; ">>>"; ">>>" ];
Alcotest.(check ls) "48" (cuts ~empty:true ~sep:"<->" "<->>->") [""; ">->"];
Alcotest.(check ls) "49" (cuts ~empty:false ~sep:"<->" "<->>->") [">->"];
Alcotest.(check ls) "50" (cuts ~empty:true ~sep:"aa" "aa") [""; ""];
Alcotest.(check ls) "51" (cuts ~empty:false ~sep:"aa" "aa") [];
Alcotest.(check ls) "52" (cuts ~empty:true ~sep:"aa" "aaa") [""; "a"];
Alcotest.(check ls) "53" (cuts ~empty:false ~sep:"aa" "aaa") ["a"];
Alcotest.(check ls) "54" (cuts ~empty:true ~sep:"aa" "aaaa") [""; ""; ""];
Alcotest.(check ls) "55" (cuts ~empty:false ~sep:"aa" "aaaa") [];
Alcotest.(check ls) "56" (cuts ~empty:true ~sep:"aa" "aaaaa") [""; ""; "a"];
Alcotest.(check ls) "57" (cuts ~empty:false ~sep:"aa" "aaaaa") ["a"];
Alcotest.(check ls) "58" (cuts ~empty:true ~sep:"aa" "aaaaaa") [""; ""; ""; ""];
Alcotest.(check ls) "59" (cuts ~empty:false ~sep:"aa" "aaaaaa") [];
;;
let fields =
Alcotest.test_case "fields" `Quick @@ fun () ->
let ls = Alcotest.(list string) in
let s str = string ~off:1 ~len:(String.length str) (Fmt.str "\x00%s\x00" str) in
let fields ?empty ?is_sep str =
let res = fields ?empty ?is_sep (s str) in
List.map Cstruct.to_string res in
let is_a chr = chr = 'a' in
Alcotest.(check ls) "0" (fields ~empty:true "a") ["a"];
Alcotest.(check ls) "1" (fields ~empty:false "a") ["a"];
Alcotest.(check ls) "2" (fields ~empty:true "abc") ["abc"];
Alcotest.(check ls) "3" (fields ~empty:false "abc") ["abc"];
Alcotest.(check ls) "4" (fields ~empty:true ~is_sep:is_a "bcdf") ["bcdf"];
Alcotest.(check ls) "5" (fields ~empty:false ~is_sep:is_a "bcdf") ["bcdf"];
Alcotest.(check ls) "6" (fields ~empty:true "") [""];
Alcotest.(check ls) "7" (fields ~empty:false "") [];
Alcotest.(check ls) "8" (fields ~empty:true "\n\r") ["";"";""];
Alcotest.(check ls) "9" (fields ~empty:false "\n\r") [];
Alcotest.(check ls) "10" (fields ~empty:true " \n\rabc") ["";"";"";"abc"];
Alcotest.(check ls) "11" (fields ~empty:false " \n\rabc") ["abc"];
Alcotest.(check ls) "12" (fields ~empty:true " \n\racd de") ["";"";"";"acd";"de"];
Alcotest.(check ls) "13" (fields ~empty:false " \n\racd de") ["acd";"de"];
Alcotest.(check ls) "14" (fields ~empty:true " \n\racd de ") ["";"";"";"acd";"de";""];
Alcotest.(check ls) "15" (fields ~empty:false " \n\racd de ") ["acd";"de"];
Alcotest.(check ls) "16" (fields ~empty:true "\n\racd\nde \r") ["";"";"acd";"de";"";""];
Alcotest.(check ls) "17" (fields ~empty:false "\n\racd\nde \r") ["acd";"de"];
Alcotest.(check ls) "18" (fields ~empty:true ~is_sep:is_a "") [""];
Alcotest.(check ls) "19" (fields ~empty:false ~is_sep:is_a "") [];
Alcotest.(check ls) "20" (fields ~empty:true ~is_sep:is_a "abaac aaa")
["";"b";"";"c ";"";"";""];
Alcotest.(check ls) "21" (fields ~empty:false ~is_sep:is_a "abaac aaa") ["b"; "c "];
Alcotest.(check ls) "22" (fields ~empty:true ~is_sep:is_a "aaaa") ["";"";"";"";""];
Alcotest.(check ls) "23" (fields ~empty:false ~is_sep:is_a "aaaa") [];
Alcotest.(check ls) "24" (fields ~empty:true ~is_sep:is_a "aaaa ") ["";"";"";"";" "];
Alcotest.(check ls) "25" (fields ~empty:false ~is_sep:is_a "aaaa ") [" "];
Alcotest.(check ls) "26" (fields ~empty:true ~is_sep:is_a "aaaab") ["";"";"";"";"b"];
Alcotest.(check ls) "27" (fields ~empty:false ~is_sep:is_a "aaaab") ["b"];
Alcotest.(check ls) "28" (fields ~empty:true ~is_sep:is_a "baaaa") ["b";"";"";"";""];
Alcotest.(check ls) "29" (fields ~empty:false ~is_sep:is_a "baaaa") ["b"];
Alcotest.(check ls) "30" (fields ~empty:true ~is_sep:is_a "abaaaa") ["";"b";"";"";"";""];
Alcotest.(check ls) "31" (fields ~empty:false ~is_sep:is_a "abaaaa") ["b"];
Alcotest.(check ls) "32" (fields ~empty:true ~is_sep:is_a "aba") ["";"b";""];
Alcotest.(check ls) "33" (fields ~empty:false ~is_sep:is_a "aba") ["b"];
Alcotest.(check ls) "34" (fields ~empty:false "tokenize me please")
["tokenize"; "me"; "please"];
;;
let find =
Alcotest.test_case "find" `Quick @@ fun () ->
let { Cstruct.buffer= abcbd; _ } = Cstruct.of_string "abcbd" in
let empty = buffer ~off:3 ~len:0 abcbd in
let a = buffer ~off:0 ~len:1 abcbd in
let ab = buffer ~off:0 ~len:2 abcbd in
let c = buffer ~off:2 ~len:1 abcbd in
let b0 = buffer ~off:1 ~len:1 abcbd in
let b1 = buffer ~off:3 ~len:1 abcbd in
let abcbd = buffer abcbd in
Alcotest.(check (option cstruct)) "0" (find (fun c -> c = 'b') empty) None;
Alcotest.(check (option cstruct)) "1" (find ~rev:true (fun c -> c = 'b') empty) None;
Alcotest.(check (option cstruct)) "2" (find (fun c -> c = 'b') a) None;
Alcotest.(check (option cstruct)) "3" (find ~rev:true (fun c -> c = 'b') a) None;
Alcotest.(check (option cstruct)) "4" (find (fun c -> c = 'b') c) None;
Alcotest.(check (option cstruct)) "5" (find ~rev:true (fun c -> c = 'b') c) None;
Alcotest.(check (option cstruct)) "6" (find (fun c -> c = 'b') abcbd) (Some b0);
Alcotest.(check (option cstruct)) "7" (find ~rev:true (fun c -> c = 'b') abcbd) (Some b1);
Alcotest.(check (option cstruct)) "8" (find (fun c -> c = 'b') ab) (Some b0);
Alcotest.(check (option cstruct)) "9" (find ~rev:true (fun c -> c = 'b') ab) (Some b0);
;;
let find_sub =
Alcotest.test_case "find_sub" `Quick @@ fun () ->
let { Cstruct.buffer= abcbd; _ } = Cstruct.of_string "abcbd" in
let empty = buffer ~off:3 ~len:0 abcbd in
let ab = buffer ~off:0 ~len:2 abcbd in
let b0 = buffer ~off:1 ~len:1 abcbd in
let b1 = buffer ~off:3 ~len:1 abcbd in
let abcbd = buffer abcbd in
Alcotest.(check (option cstruct)) "0" (find_sub ~sub:ab empty) None;
Alcotest.(check (option cstruct)) "1" (find_sub ~rev:true ~sub:ab empty) None;
Alcotest.(check (option cstruct)) "2" (find_sub ~sub:(Cstruct.of_string "") empty) (Some empty);
Alcotest.(check (option cstruct)) "3" (find_sub ~rev:true ~sub:(Cstruct.of_string "") empty) (Some empty);
Alcotest.(check (option cstruct)) "4" (find_sub ~sub:ab abcbd) (Some ab);
Alcotest.(check (option cstruct)) "5" (find_sub ~rev:true ~sub:ab abcbd) (Some ab);
Alcotest.(check (option cstruct)) "6" (find_sub ~sub:empty abcbd) (Some (Cstruct.start abcbd));
Alcotest.(check (option cstruct)) "7" (find_sub ~rev:true ~sub:empty abcbd)
(Some (Cstruct.stop abcbd));
Alcotest.(check (option cstruct)) "8" (find_sub ~sub:(Cstruct.of_string "b") abcbd) (Some b0);
Alcotest.(check (option cstruct)) "9" (find_sub ~rev:true ~sub:(Cstruct.of_string "b") abcbd) (Some b1);
Alcotest.(check (option cstruct)) "10" (find_sub ~sub:b1 ab) (Some b0);
Alcotest.(check (option cstruct)) "11" (find_sub ~rev:true ~sub:b1 ab) (Some b0);
;;
let () = Alcotest.run "cstruct.parse"
[ "parse", [ misc; head; start; stop; tail
; is_empty; is_prefix; is_infix; is_suffix
; for_all; exists
; trim
; span
; cut; cuts
; fields
; find; find_sub ] ]

266
unikernel/duniverse/ocaml-cstruct/lib_test/tests.ml Normal file
View file

@ -0,0 +1,266 @@
let _ = Random.self_init ()
let random_cs ?(len = Random.int 128) () =
let cs = Cstruct.create len in
for i = 0 to len - 1 do Cstruct.set_uint8 cs i (Random.int 256) done;
cs
let to_string_as_sexp cs =
Sexplib.Sexp.to_string_mach (Cstruct_sexp.sexp_of_t cs)
let of_string_as_sexp str =
Cstruct_sexp.t_of_sexp (Sexplib.Sexp.of_string str)
let assert_cs_equal ?(msg="cstruct") cs1 cs2 =
let cstruct =
Alcotest.testable (Fmt.of_to_string Cstruct.to_string) Cstruct.equal
in
Alcotest.check cstruct msg cs1 cs2
let assert_string_equal ?(msg="string") s1 s2 =
Alcotest.(check string) msg s1 s2
let sexp_repr =
let open Cstruct in
let cs1 = of_string "abcdefgh" in
let cs2 = shift cs1 2
and cs3 = sub cs1 2 4 in
let cs4 = of_string "a b\nc" in
let cs5 = sub cs4 2 1 in
[ (cs1, "abcdefgh")
; (cs2, "cdefgh")
; (cs3, "cdef")
; (cs4, "\"a b\\nc\"")
; (cs5, "b")
]
let sexp_writer () =
sexp_repr |> List.iter @@ fun (cs, str) ->
assert_string_equal str (to_string_as_sexp cs)
let sexp_reader () =
sexp_repr |> List.iter @@ fun (cs, str) ->
assert_cs_equal cs (of_string_as_sexp str)
let sexp_invertibility ~n () =
for _i = 1 to n do
let cs1 = random_cs () in
let s1 = to_string_as_sexp cs1 in
let cs2 = of_string_as_sexp s1 in
let s2 = to_string_as_sexp cs2 in
assert_cs_equal ~msg:"recovered cstruct" cs1 cs2 ;
assert_string_equal ~msg:"recovered string" s1 s2
done
let concat_ex =
let open Cstruct in
List.map (fun (ss, s) -> (List.map of_string ss, of_string s))
[ ([], "")
; (["abcd"], "abcd")
; ([""], "")
; ([""; ""], "")
; ([""; "ab"; ""; "cd"], "abcd")
; (["ab"; "cd"; "ef"], "abcdef")
]
let concat_samples () =
concat_ex |> List.iter @@ fun (css, cs) ->
assert_cs_equal cs (Cstruct.concat css)
let concat_random ~n () =
let rec explode cs =
let n = Cstruct.length cs in
if n = 0 then [] else
let k = Random.int (n + 1) in
Cstruct.sub cs 0 k :: explode (Cstruct.shift cs k) in
for _i = 1 to n do
let cs = random_cs () in
let css = explode cs in
assert_cs_equal cs (Cstruct.concat css)
done
let append_is_concat ~n () =
for _i = 1 to n do
let (cs1, cs2) = (random_cs (), random_cs ()) in
assert_cs_equal (Cstruct.concat [cs1; cs2]) (Cstruct.append cs1 cs2)
done
let fillv () =
let test src buf_size =
let dst = Cstruct.create buf_size in
let src_len = Cstruct.lenv src in
let len, remaining = Cstruct.fillv ~src ~dst in
assert (len = min src_len buf_size);
let whole = Cstruct.concat (Cstruct.sub dst 0 len :: remaining) in
assert (Cstruct.equal whole (Cstruct.concat src)) in
test [] 0;
test [] 16;
test [Cstruct.of_string "abc"] 0;
test [Cstruct.of_string "abc"] 2;
test [Cstruct.of_string "abc"] 16;
test [Cstruct.of_string "abc"; Cstruct.of_string ""; Cstruct.of_string "def"] 0;
test [Cstruct.of_string "abc"; Cstruct.of_string ""; Cstruct.of_string "def"] 3;
test [Cstruct.of_string "abc"; Cstruct.of_string ""; Cstruct.of_string "def"] 5;
test [Cstruct.of_string "abc"; Cstruct.of_string ""; Cstruct.of_string "def"] 6;
test [Cstruct.of_string "abc"; Cstruct.of_string ""; Cstruct.of_string "def"] 7
let check_alignment alignment () =
(* Make the buffer big enough to find 4 aligned offsets within it *)
let expected = 4 in
let buf = Cstruct.create (expected * alignment) in
(* How many aligned offsets are there in this buffer? *)
let actual = ref 0 in
for i = 0 to Cstruct.length buf - 1 do
if Cstruct.(check_alignment (shift buf i) alignment) then incr actual
done;
Alcotest.(check int) "alignement" expected !actual
let check_alignment_zero () =
let buf = Cstruct.create 512 in
try
let _ = Cstruct.check_alignment buf 0 in
Alcotest.fail "alignement zero should raise"
with
Invalid_argument _ -> ()
let check_alignment_large () =
let check () =
Cstruct.check_alignment (Cstruct.create 1) (Int64.to_int 4294967296L)
in
if Sys.word_size > 32 then
let msg =
Fmt.str "alignement large: int-size:%d len=%d"
Sys.word_size (Int64.to_int 4294967296L)
in
Alcotest.(check bool) msg (check ()) false
else
try let _ = check () in Alcotest.fail "alignement should raise"
with Invalid_argument _ -> ()
let rev_empty () =
assert_cs_equal Cstruct.empty (Cstruct.rev Cstruct.empty)
let rev_len_1 () =
let cs = Cstruct.of_string "a" in
assert_cs_equal cs (Cstruct.rev cs)
let rev_len_5 () =
let cs = Cstruct.of_string "abcde" in
let expected = Cstruct.of_string "edcba" in
assert_cs_equal expected (Cstruct.rev cs)
let test_hexdump ?(format=("%a" : _ format4)) cs expected =
let got = Format.asprintf format Cstruct.hexdump_pp cs in
Alcotest.(check string) "hexdump output" expected got
let hexdump_empty () =
test_hexdump
Cstruct.empty
""
let hexdump_small () =
test_hexdump
(Cstruct.of_hex "00010203")
"00 01 02 03"
let hex_multiline =
Cstruct.of_hex "000102030405060708090a0b0c0d0e0f101112"
let hex_to_string_empty () =
let c = Cstruct.of_string "" in
let s = Cstruct.to_hex_string c in
assert_string_equal ~msg:"encoded" s ""
let hex_to_string_small () =
let c = Cstruct.of_string "hello world \x00 !" in
let s = Cstruct.to_hex_string c in
assert_string_equal ~msg:"encoded" "68656c6c6f20776f726c6420002021" s;
let c' = Cstruct.of_hex s in
assert_cs_equal ~msg:"decoded again" c c'
let hex_to_string_small_slice () =
let c = Cstruct.of_string "This_1s Not @ Dr1LL" in
let s = Cstruct.to_hex_string ~off:2 ~len:11 c in
assert_string_equal ~msg:"encoded" "69735f3173204e6f742040" s;
let c' = Cstruct.of_hex s in
assert_cs_equal ~msg:"decoded again" (Cstruct.sub c 2 11) c';
assert_string_equal ~msg:"decoded as str" "is_1s Not @" (Cstruct.to_string c')
let hex_to_string_small_slice_of_slice () =
let c = Cstruct.of_string "This_1s Not @ Dr1LL" in
let c_slice = Cstruct.sub c 2 11 in
let s = Cstruct.to_hex_string ~off:3 ~len:6 c_slice in
assert_string_equal ~msg:"encoded" "3173204e6f74" s;
let c' = Cstruct.of_hex s in
assert_cs_equal ~msg:"decoded again" (Cstruct.sub c_slice 3 6) c';
assert_string_equal ~msg:"decoded as str" "1s Not" (Cstruct.to_string c')
let hexdump_multiline () =
test_hexdump
hex_multiline
( "00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f\n"
^ "10 11 12")
let hexdump_aligned () =
test_hexdump
(Cstruct.of_hex "000102030405060708090a0b0c0d0e0f")
"00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f\n"
let hexdump_aligned_to_half () =
test_hexdump
(Cstruct.of_hex "0001020304050607")
"00 01 02 03 04 05 06 07"
let hexdump_in_box () =
test_hexdump
~format:"This is a box : %a"
hex_multiline
( "This is a box : 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f\n"
^ " 10 11 12"
)
let suite = [
"fillv", [
"fillv", `Quick, fillv
];
"sexp", [
"sexp_of_t" , `Quick, sexp_writer;
"t_of_sexp" , `Quick, sexp_reader;
"sexp invertibility", `Quick, sexp_invertibility ~n:5000;
];
"concat", [
"concat samples", `Quick, concat_samples;
"concat random" , `Quick, concat_random ~n:5000;
];
"append", [
"append is concat", `Quick, append_is_concat ~n:5000
];
"alignment", [
"aligned to 4096" , `Quick, check_alignment 4096;
"aligned to 512" , `Quick, check_alignment 512;
"aligned to 0" , `Quick, check_alignment_zero;
"aligned to large", `Quick, check_alignment_large;
];
"rev", [
"empty", `Quick, rev_empty;
"len = 1", `Quick, rev_len_1;
"len = 5", `Quick, rev_len_5;
];
"hexdump", [
"empty", `Quick, hexdump_empty;
"small", `Quick, hexdump_small;
"multiline", `Quick, hexdump_multiline;
"aligned", `Quick, hexdump_aligned;
"aligned to half", `Quick, hexdump_aligned_to_half;
"in box", `Quick, hexdump_in_box;
];
"hex_to_string", [
"empty", `Quick, hex_to_string_empty;
"small", `Quick, hex_to_string_small;
"small_slice", `Quick, hex_to_string_small_slice;
"small_slice_of_slice", `Quick, hex_to_string_small_slice_of_slice;
]
]
let () = Alcotest.run "cstruct" (("bounds", Bounds.suite) :: suite)

1
unikernel/duniverse/ocaml-cstruct/lib_test/tests.mli Normal file
View file

@ -0,0 +1 @@
(* empty *)

5
unikernel/duniverse/ocaml-cstruct/lwt/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name cstruct_lwt)
(wrapped false)
(public_name cstruct-lwt)
(libraries cstruct lwt.unix))

39
unikernel/duniverse/ocaml-cstruct/lwt/lwt_cstruct.ml Normal file
View file

@ -0,0 +1,39 @@
(*
* Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
let read fd t =
Lwt_bytes.read fd t.Cstruct.buffer t.Cstruct.off t.Cstruct.len
let write fd t =
Lwt_bytes.write fd t.Cstruct.buffer t.Cstruct.off t.Cstruct.len
let complete op t =
let open Lwt in
let rec loop t =
op t >>= fun n ->
let t = Cstruct.shift t n in
if Cstruct.length t = 0
then return ()
else if n = 0
then fail End_of_file
else loop t in
loop t
let sendto fd t flags dst =
Lwt_bytes.sendto fd t.Cstruct.buffer t.Cstruct.off t.Cstruct.len flags dst
let recvfrom fd t flags =
Lwt_bytes.recvfrom fd t.Cstruct.buffer t.Cstruct.off t.Cstruct.len flags

44
unikernel/duniverse/ocaml-cstruct/lwt/lwt_cstruct.mli Normal file
View file

@ -0,0 +1,44 @@
(*
* Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
* Copyright (c) 2012-2014 Citrix Systems Inc
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** Blocking Lwt functions to read and write from Cstruct buffers. *)
val read: Lwt_unix.file_descr -> Cstruct.t -> int Lwt.t
(** [read fd t] reads data from the file descriptor [fd] into the
[t] cstruct.
@return the numbers of bytes actually read. *)
val write: Lwt_unix.file_descr -> Cstruct.t -> int Lwt.t
(** [write fd t] writes data from the [t] cstruct to the file
descriptor [fd].
@return the numbers of bytes actually written. *)
val complete: (Cstruct.t -> int Lwt.t) -> Cstruct.t -> unit Lwt.t
(** [complete (read fd) t] fills [t] with data from [fd].
[complete (write fd) t] fully-writes [t] to [fd].
@raise End_of_file if the file descriptor operation fails.
*)
val sendto: Lwt_unix.file_descr -> Cstruct.t -> Unix.msg_flag list -> Unix.sockaddr -> int Lwt.t
(** [sendto fd t flags sa] invokes {!Lwt_unix.sendto} on the [t] cstruct.
@return the number of bytes sent. *)
val recvfrom: Lwt_unix.file_descr -> Cstruct.t -> Unix.msg_flag list -> (int * Unix.sockaddr) Lwt.t
(** [recvfrom fd t flags sa] invokes {!Lwt_unix.recvfrom} on the [t] cstruct.
@return the number of bytes read and the socket address of the remote side. *)

9
unikernel/duniverse/ocaml-cstruct/ppx/dune Normal file
View file

@ -0,0 +1,9 @@
(library
(name ppx_cstruct)
(public_name ppx_cstruct)
(kind ppx_rewriter)
(wrapped false)
(ppx_runtime_libraries cstruct)
(preprocess
(pps ppxlib.metaquot))
(libraries sexplib ppxlib))

662
unikernel/duniverse/ocaml-cstruct/ppx/ppx_cstruct.ml Normal file
View file

@ -0,0 +1,662 @@
(*
* Copyright (c) 2015 Nicolas Ojeda Bar <n.oje.bar@gmail.com>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Printf
open Ppxlib
open Ast_helper
module Ast = struct
include Ast_builder.Default
let econstr ~loc tag xs =
pexp_construct ~loc (Loc.make ~loc (lident tag)) (
match xs with
| [] -> None
| _ -> Some (pexp_tuple ~loc xs)
)
let pconstr ~loc tag xs =
ppat_construct ~loc (Loc.make ~loc (lident tag)) (
match xs with
| [] -> None
| _ -> Some (ppat_tuple ~loc xs)
)
let tconstr ~loc tag xs =
ptyp_constr ~loc (Loc.make ~loc (lident tag)) xs
end
type mode = Big_endian | Little_endian | Host_endian | Bi_endian
type prim =
| Char
| UInt8
| UInt16
| UInt32
| UInt64
type ty =
| Prim of prim
| Buffer of prim * int
type raw_field = {
name: string;
ty: ty;
definition_loc: Location.t;
}
type named_field = {
name: string;
ty: ty;
definition_loc: Location.t;
off: int;
}
type field =
| Named_field of named_field
| Ignored_field
let field_is_ignored name =
String.get name 0 = '_'
type t = {
name: string;
fields: field list;
len: int;
endian: mode;
}
let ty_of_string =
function
|"char_t" |"char" -> Some Char
|"uint8_t" |"uint8" |"int8" |"int8_t" -> Some UInt8
|"uint16_t"|"uint16"|"int16"|"int16_t" -> Some UInt16
|"uint32_t"|"uint32"|"int32"|"int32_t" -> Some UInt32
|"uint64_t"|"uint64"|"int64"|"int64_t" -> Some UInt64
|_ -> None
let width_of_prim = function
| Char -> 1
| UInt8 -> 1
| UInt16 -> 2
| UInt32 -> 4
| UInt64 -> 8
let width_of_ty = function
| Prim p -> width_of_prim p
| Buffer (p, len) -> width_of_prim p * len
let width_of_field f =
width_of_ty f.ty
let field_to_string f =
let rec string = function
|Prim Char -> "char_t"
|Prim UInt8 -> "uint8_t"
|Prim UInt16 -> "uint16_t"
|Prim UInt32 -> "uint32_t"
|Prim UInt64 -> "uint64_t"
|Buffer (prim, len) -> sprintf "%s[%d]" (string (Prim prim)) len
in
sprintf "%s %s" (string f.ty) f.name
let loc_err loc fmt = Location.raise_errorf ~loc ("ppx_cstruct: " ^^ fmt)
let parse_field loc name field_type sz =
match ty_of_string field_type with
|None -> loc_err loc "Unknown type %s" field_type
|Some ty -> begin
let ty = match ty,sz with
|_,None -> Prim ty
|prim,Some sz -> Buffer (prim, sz)
in
{ name; ty; definition_loc = loc }
end
let check_for_duplicates fields =
let module StringSet = Set.Make(String) in
let _ : StringSet.t =
List.fold_left (fun seen f ->
match f with
| Ignored_field -> seen
| Named_field {name; definition_loc; _} ->
if StringSet.mem name seen then
loc_err definition_loc "field %s is present several times in this type" name
else
StringSet.add name seen
)
StringSet.empty
fields
in
()
let create_struct loc endian name fields =
let endian = match endian with
|"little_endian" -> Little_endian
|"big_endian" -> Big_endian
|"host_endian" -> Host_endian
|"bi_endian" -> Bi_endian
|_ -> loc_err loc "unknown endian %s, should be little_endian, big_endian, host_endian or bi_endian" endian
in
let len, fields =
List.fold_left (fun (off,acc) ({name; ty; definition_loc}:raw_field) ->
let field =
if field_is_ignored name then
Ignored_field
else
Named_field { name; ty; off; definition_loc }
in
let off = width_of_ty ty + off in
let acc = acc @ [field] in
(off, acc)
) (0,[]) fields
in
check_for_duplicates fields;
{ fields; name = name.txt; len; endian }
let ($.) l x = Longident.Ldot (l, x)
let cstruct_id = Longident.Lident "Cstruct"
let mode_mod s = function
|Big_endian -> cstruct_id$."BE"$.s
|Little_endian -> cstruct_id$."LE"$.s
|Host_endian -> cstruct_id$."HE"$.s
|Bi_endian -> cstruct_id$."BL"$.s
let mode_mod loc x s =
Exp.ident ~loc {loc ; txt = mode_mod s x}
type op =
| Op_get of named_field
| Op_set of named_field
| Op_copy of named_field
| Op_blit of named_field
| Op_sizeof
| Op_hexdump
| Op_hexdump_to_buffer
let op_name s op =
let parts =
match op with
| Op_get f -> ["get"; s.name; f.name]
| Op_set f -> ["set"; s.name; f.name]
| Op_copy f -> ["copy"; s.name; f.name]
| Op_blit f -> ["blit"; s.name; f.name]
| Op_sizeof -> ["sizeof"; s.name]
| Op_hexdump -> ["hexdump"; s.name]
| Op_hexdump_to_buffer -> ["hexdump"; s.name; "to_buffer"]
in
String.concat "_" parts
let op_pvar ~loc s op = Ast.pvar ~loc (op_name s op)
let op_evar ~loc s op = Ast.evar ~loc (op_name s op)
let get_expr loc s f =
let m = mode_mod loc s.endian in
let num x = Ast.eint ~loc x in
match f.ty with
|Buffer (_, _) ->
let len = width_of_field f in
[%expr
fun src -> Cstruct.sub src [%e num f.off] [%e num len]
]
|Prim prim ->
[%expr
fun v ->
[%e match prim with
|Char -> [%expr Cstruct.get_char v [%e num f.off]]
|UInt8 -> [%expr Cstruct.get_uint8 v [%e num f.off]]
|UInt16 -> [%expr [%e m "get_uint16"] v [%e num f.off]]
|UInt32 -> [%expr [%e m "get_uint32"] v [%e num f.off]]
|UInt64 -> [%expr [%e m "get_uint64"] v [%e num f.off]]]]
let type_of_int_field ~loc = function
|Char -> [%type: char]
|UInt8 -> [%type: Cstruct.uint8]
|UInt16 -> [%type: Cstruct.uint16]
|UInt32 -> [%type: Cstruct.uint32]
|UInt64 -> [%type: Cstruct.uint64]
let set_expr loc s f =
let m = mode_mod loc s.endian in
let num x = Ast.eint ~loc x in
match f.ty with
|Buffer (_,_) ->
let len = width_of_field f in
[%expr
fun src srcoff dst ->
Cstruct.blit_from_string src srcoff dst [%e num f.off] [%e num len]]
|Prim prim ->
[%expr fun v x ->
[%e match prim with
|Char -> [%expr Cstruct.set_char v [%e num f.off] x]
|UInt8 -> [%expr Cstruct.set_uint8 v [%e num f.off] x]
|UInt16 -> [%expr [%e m "set_uint16"] v [%e num f.off] x]
|UInt32 -> [%expr [%e m "set_uint32"] v [%e num f.off] x]
|UInt64 -> [%expr [%e m "set_uint64"] v [%e num f.off] x]]]
let type_of_set ~loc f =
match f.ty with
|Buffer (_,_) ->
[%type: string -> int -> Cstruct.t -> unit]
|Prim prim ->
let retf = type_of_int_field ~loc prim in
[%type: Cstruct.t -> [%t retf] -> unit]
let hexdump_expr ~loc s =
[%expr fun v ->
let buf = Buffer.create 128 in
Buffer.add_string buf [%e Ast.estring ~loc (s.name ^ " = {\n")];
[%e op_evar ~loc s Op_hexdump_to_buffer] buf v;
print_endline (Buffer.contents buf);
print_endline "}"
]
let hexdump_to_buffer_expr ~loc s =
let prim_format_string = function
| Char -> [%expr "%c\n"]
| UInt8 | UInt16 -> [%expr "0x%x\n"]
| UInt32 -> [%expr "0x%lx\n"]
| UInt64 -> [%expr "0x%Lx\n"]
in
let hexdump_field = function
| Ignored_field ->
[%expr ()]
| Named_field f ->
let get_f = op_evar ~loc s (Op_get f) in
let expr =
match f.ty with
|Prim p ->
[%expr Printf.bprintf buf [%e prim_format_string p] ([%e get_f] v)]
|Buffer (_,_) ->
[%expr Printf.bprintf buf "<buffer %s>" [%e Ast.estring ~loc (field_to_string f)];
Cstruct.hexdump_to_buffer buf ([%e get_f] v)]
in
[%expr
Printf.bprintf buf " %s = " [%e Ast.estring ~loc f.name];
[%e expr]]
in
[%expr fun buf v -> [%e Ast.esequence ~loc (List.map hexdump_field s.fields)]]
let op_expr loc s = function
| Op_sizeof -> Ast.eint ~loc s.len
| Op_hexdump -> hexdump_expr ~loc s
| Op_hexdump_to_buffer -> hexdump_to_buffer_expr ~loc s
| Op_get f -> get_expr loc s f
| Op_set f -> set_expr loc s f
| Op_copy f ->
let len = width_of_field f in
[%expr fun src -> Cstruct.to_string src ~off:[%e Ast.eint ~loc f.off] ~len:[%e Ast.eint ~loc len] ]
| Op_blit f ->
let len = width_of_field f in
[%expr fun src srcoff dst ->
Cstruct.blit src srcoff dst [%e Ast.eint ~loc f.off] [%e Ast.eint ~loc len]]
let field_ops_for =
function
| Ignored_field ->
[]
| Named_field f ->
let if_buffer x =
match f.ty with
|Buffer (_,_) -> [x]
|Prim _ -> []
in
List.concat
[ [Op_get f]
; if_buffer (Op_copy f)
; [Op_set f]
; if_buffer (Op_blit f)
]
let ops_for s =
( [Op_sizeof]
@ List.concat (List.map field_ops_for s.fields)
@ [Op_hexdump_to_buffer;
Op_hexdump;
])
(** Generate functions of the form {get/set}_<struct>_<field> *)
let output_struct_one_endian loc s =
List.map
(fun op ->
[%stri let[@ocaml.warning "-32"] [%p op_pvar ~loc s op] =
[%e op_expr loc s op]])
(ops_for s)
let output_struct _loc s =
match s.endian with
| Bi_endian ->
(* In case of Bi-endian, create two modules - one for BE and one for LE *)
let expr_be = Mod.structure (output_struct_one_endian _loc {s with endian = Big_endian})
and expr_le = Mod.structure (output_struct_one_endian _loc {s with endian = Little_endian})
in [{pstr_desc = Pstr_module
{pmb_name = {txt = Some "BE"; loc = _loc}; pmb_expr = expr_be;
pmb_attributes = []; pmb_loc = _loc;}; pstr_loc = _loc;};
{pstr_desc = Pstr_module
{pmb_name = {txt = Some "LE"; loc = _loc}; pmb_expr = expr_le;
pmb_attributes = []; pmb_loc = _loc;}; pstr_loc = _loc;}
]
| _ -> output_struct_one_endian _loc s
let type_of_get ~loc f =
match f.ty with
|Buffer (_,_) ->
[%type: Cstruct.t -> Cstruct.t]
|Prim prim ->
let retf = type_of_int_field ~loc prim in
[%type: Cstruct.t -> [%t retf]]
let op_typ ~loc = function
| Op_sizeof -> [%type: int]
| Op_hexdump_to_buffer -> [%type: Buffer.t -> Cstruct.t -> unit]
| Op_hexdump -> [%type: Cstruct.t -> unit]
| Op_get f -> type_of_get ~loc f
| Op_set f -> type_of_set ~loc f
| Op_copy _ -> [%type: Cstruct.t -> string]
| Op_blit _ -> [%type: Cstruct.t -> int -> Cstruct.t -> unit]
(** Generate signatures of the form {get/set}_<struct>_<field> *)
let output_struct_sig loc s =
List.map
(fun op ->
Sig.value
(Val.mk
(Loc.make (op_name s op) ~loc)
(op_typ ~loc op)))
(ops_for s)
type enum_op =
| Enum_to_sexp
| Enum_of_sexp
| Enum_get
| Enum_set
| Enum_print
| Enum_parse
| Enum_compare
type cenum =
{ name : string Loc.t;
fields : (string Loc.t * int64) list;
prim : prim;
sexp : bool;
}
let enum_op_name cenum =
let s = cenum.name.txt in
function
| Enum_to_sexp -> sprintf "sexp_of_%s" s
| Enum_of_sexp -> sprintf "%s_of_sexp" s
| Enum_get -> sprintf "int_to_%s" s
| Enum_set -> sprintf "%s_to_int" s
| Enum_print -> sprintf "%s_to_string" s
| Enum_parse -> sprintf "string_to_%s" s
| Enum_compare -> sprintf "compare_%s" s
let enum_pattern ~loc {prim; _} =
let pat_integer f suffix i =
Pat.constant (Pconst_integer(f i, suffix))
in
match prim with
| Char ->
(fun i -> Ast.pchar ~loc (Char.chr (Int64.to_int i)))
| (UInt8 | UInt16) -> pat_integer Int64.to_string None
| UInt32 -> pat_integer (fun i -> Int32.to_string (Int64.to_int32 i)) (Some 'l')
| UInt64 -> pat_integer Int64.to_string (Some 'L')
let enum_integer ~loc {prim; _} =
let expr_integer f suffix i =
Exp.constant (Pconst_integer(f i, suffix))
in
match prim with
| Char -> (fun i -> Ast.echar ~loc (Char.chr (Int64.to_int i)))
| (UInt8 | UInt16) -> expr_integer Int64.to_string None
| UInt32 -> expr_integer (fun i -> Int32.to_string (Int64.to_int32 i)) (Some 'l')
| UInt64 -> expr_integer Int64.to_string (Some 'L')
let declare_enum_expr ~loc ({fields; _} as cenum) = function
| Enum_to_sexp ->
[%expr fun x -> Sexplib.Sexp.Atom ([%e Ast.evar ~loc (enum_op_name cenum Enum_print)] x) ]
| Enum_of_sexp ->
[%expr
fun x ->
match x with
| Sexplib.Sexp.List _ ->
raise (Sexplib.Pre_sexp.Of_sexp_error (Failure "expected Atom, got List", x))
| Sexplib.Sexp.Atom v ->
match [%e Ast.evar ~loc (enum_op_name cenum Enum_parse)] v with
| None ->
raise (Sexplib.Pre_sexp.Of_sexp_error (Failure "unable to parse enum string", x))
| Some r -> r
]
| Enum_get ->
let getters = (List.map (fun ({txt = f; _},i) ->
Exp.case (enum_pattern ~loc cenum i) [%expr Some [%e Ast.econstr ~loc f []]]
) fields) @ [Exp.case [%pat? _] [%expr None]]
in
Exp.function_ getters
| Enum_set ->
let setters = List.map (fun ({txt = f; _},i) ->
Exp.case (Ast.pconstr ~loc f []) (enum_integer ~loc cenum i)
) fields in
Exp.function_ setters
| Enum_print ->
let printers = List.map (fun ({txt = f; _},_) ->
Exp.case (Ast.pconstr ~loc f []) (Ast.estring ~loc f)
) fields in
Exp.function_ printers
| Enum_parse ->
let parsers = List.map (fun ({txt = f; _},_) ->
Exp.case (Ast.pstring ~loc f) [%expr Some [%e Ast.econstr ~loc f []]]
) fields in
Exp.function_ (parsers @ [Exp.case [%pat? _] [%expr None]])
| Enum_compare -> [%expr fun x y ->
let to_int = [%e Ast.evar ~loc (enum_op_name cenum Enum_set)] in
Stdlib.compare (to_int x) (to_int y)
]
let enum_ops_for {sexp; _} =
Enum_get ::
Enum_set ::
Enum_compare ::
Enum_print ::
Enum_parse ::
if sexp then
[ Enum_to_sexp
; Enum_of_sexp
]
else
[]
let enum_type_decl {name; fields; _} =
let decls = List.map (fun (f,_) -> Type.constructor f) fields in
Type.mk ~kind:(Ptype_variant decls) name
let output_enum ~loc cenum =
Str.type_ Recursive [enum_type_decl cenum] ::
List.map
(fun op ->
[%stri
let[@ocaml.warning "-32"] [%p Ast.pvar ~loc (enum_op_name cenum op)] =
[%e declare_enum_expr ~loc cenum op]
])
(enum_ops_for cenum)
let enum_op_type ~loc {name; prim; _} =
let cty = Ast.tconstr ~loc name.txt [] in
let oty = match prim with
| Char -> [%type: char]
| (UInt8|UInt16) -> [%type: int]
| UInt32 -> [%type: int32]
| UInt64 -> [%type: int64]
in
function
| Enum_get -> [%type: [%t oty] -> [%t cty] option]
| Enum_set -> [%type: [%t cty] -> [%t oty]]
| Enum_print -> [%type: [%t cty] -> string]
| Enum_parse -> [%type: string -> [%t cty] option]
| Enum_to_sexp -> [%type: [%t cty] -> Sexplib.Sexp.t]
| Enum_of_sexp -> [%type: Sexplib.Sexp.t -> [%t cty]]
| Enum_compare -> [%type: [%t cty] -> [%t cty] -> int]
let output_enum_sig loc (cenum:cenum) =
Sig.type_ Recursive [enum_type_decl cenum] ::
List.map
(fun op ->
let name = enum_op_name cenum op in
let typ = enum_op_type ~loc cenum op in
Sig.value (Val.mk (Loc.make name ~loc) typ))
(enum_ops_for cenum)
let constr_enum = function
| {pcd_name = f; pcd_args = Pcstr_tuple []; pcd_attributes = attrs; _} ->
let id = match attrs with
| [{attr_name = {txt = "id";_};
attr_payload =
PStr [{ pstr_desc =
Pstr_eval ({pexp_desc = Pexp_constant cst; pexp_loc = loc; _}, _); _}]
;_ }] ->
let cst = match cst with
| Pconst_integer(i, _) -> Int64.of_string i
| _ ->
loc_err loc "invalid id"
in
Some cst
| _ ->
None
in
(f, id)
| {pcd_loc = loc; _} ->
loc_err loc "invalid cenum variant"
let get_len = function
| [{attr_name = {txt = "len"; loc};
attr_payload = PStr
[{pstr_desc =
Pstr_eval ({pexp_desc = Pexp_constant (Pconst_integer (sz, None)); _}, _);
_}]
; _}]
->
let n = int_of_string sz in
if n > 0 then
Some n
else
loc_err loc "[@len] argument should be > 0"
| [{attr_name = {txt = "len"; loc}; _} ] ->
loc_err loc "[@len] argument should be an integer"
| _ ->
None
let constr_field {pld_name = fname; pld_type = fty; pld_loc = loc; pld_attributes = att; _} =
let sz = match get_len fty.ptyp_attributes, get_len att with
| Some sz, None
| None, Some sz -> Some sz
| Some _, Some _ -> loc_err loc "multiple field length attribute"
| None, None -> None
in
let fty = match fty.ptyp_desc with
| Ptyp_constr ({txt = Lident fty; _}, []) -> fty
| _ ->
loc_err fty.ptyp_loc "type identifier expected"
in
parse_field loc fname.txt fty sz
let cstruct decl =
let {ptype_name = name; ptype_kind = kind;
ptype_attributes = attrs; ptype_loc = loc; _} = decl in
let fields = match kind with
| Ptype_record fields -> List.map constr_field fields
| _ -> loc_err loc "record type declaration expected"
in
let endian = match attrs with
| [{attr_name = {txt = endian; _}; attr_payload = PStr []; _}] -> endian
| [_] -> loc_err loc "no attribute payload expected"
| _ -> loc_err loc "too many attributes"
in
create_struct loc endian name fields
let cenum decl =
let {ptype_name = name; ptype_kind = kind;
ptype_attributes = attrs; ptype_loc = loc; _} = decl in
let fields = match kind with
| Ptype_variant fields -> fields
| _ ->
loc_err loc "expected variant type"
in
let width, sexp =
match attrs with
| ({attr_name = {txt = width; _};attr_payload= PStr [];_})
:: ({attr_name = {txt = "sexp"; _};attr_payload = PStr []; _}) :: [] ->
width, true
| ({attr_name = {txt = width; _};attr_payload= PStr [];_}) :: [] ->
width, false
| _ ->
loc_err loc "invalid cenum attributes"
in
let n = ref Int64.minus_one in
let incr_n () = n := Int64.succ !n in
let fields = List.map constr_enum fields in
let fields =
List.map (function
| (f, None) -> incr_n (); (f, !n)
| (f, Some i) -> n := i; (f, i)
) fields in
let prim = match ty_of_string width with
| None -> loc_err loc "enum: unknown width specifier %s" width
| Some p -> p
in
{ name;
fields;
prim;
sexp;
}
let signature_item' mapper = function
| {psig_desc =
Psig_extension (({txt = "cstruct"; _}, PStr [{pstr_desc = Pstr_type(_, [decl]); _}]), _);
psig_loc = loc} ->
output_struct_sig loc (cstruct decl)
| {psig_desc =
Psig_extension (({txt = "cenum"; _}, PStr [{pstr_desc = Pstr_type(_, [decl]); _}]), _);
psig_loc = loc} ->
output_enum_sig loc (cenum decl)
| other -> [mapper other]
let structure_item' mapper = function
| {pstr_desc =
Pstr_extension (({txt = "cstruct"; _}, PStr [{pstr_desc = Pstr_type(_, [decl]); _}]), _);
pstr_loc = loc} ->
output_struct loc (cstruct decl)
| {pstr_desc =
Pstr_extension (({txt = "cenum"; _}, PStr [{pstr_desc = Pstr_type(_, [decl]); _}]), _);
pstr_loc = loc ;
_ } ->
output_enum ~loc (cenum decl)
| other -> [mapper other]
class mapper = object
inherit Ast_traverse.map as super
method! signature s =
List.concat (List.map (signature_item' super#signature_item) s)
method! structure s =
List.concat (List.map (structure_item' super#structure_item) s)
end
let () =
let mapper = new mapper in
Driver.register_transformation "ppx_cstruct" ~impl:mapper#structure ~intf:mapper#signature

0
unikernel/duniverse/ocaml-cstruct/ppx/ppx_cstruct.mli Normal file
View file

37
unikernel/duniverse/ocaml-cstruct/ppx_cstruct.opam Normal file
View file

@ -0,0 +1,37 @@
version: "6.2.0"
opam-version: "2.0"
maintainer: "anil@recoil.org"
authors: ["Anil Madhavapeddy" "Richard Mortier" "Thomas Gazagnaire"
"Pierre Chambart" "David Kaloper" "Jeremy Yallop" "David Scott"
"Mindy Preston" "Thomas Leonard" "Etienne Millon" ]
homepage: "https://github.com/mirage/ocaml-cstruct"
license: "ISC"
dev-repo: "git+https://github.com/mirage/ocaml-cstruct.git"
bug-reports: "https://github.com/mirage/ocaml-cstruct/issues"
doc: "https://mirage.github.io/ocaml-cstruct/"
tags: [ "org:mirage" "org:ocamllabs" ]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
depends: [
"ocaml" {>= "4.08.0"}
"dune" {>= "2.0.0"}
"cstruct" {=version}
"ounit" {with-test}
"ppxlib" {>= "0.16.0"}
"ppx_sexp_conv" {with-test}
"sexplib" {>="v0.9.0"}
"cstruct-sexp" {with-test}
"cppo" {with-test}
"cstruct-unix" {with-test & =version}
"ocaml-migrate-parsetree" {>= "2.1.0" & with-test}
"lwt_ppx" {>= "2.0.2" & with-test}
]
synopsis: "Access C-like structures directly from OCaml"
description: """
Cstruct is a library and syntax extension to make it easier to access C-like
structures directly from OCaml. It supports both reading and writing to these
structures, and they are accessed via the `Bigarray` module."""

15
unikernel/duniverse/ocaml-cstruct/ppx_test/basic.expected Normal file
View file

@ -0,0 +1,15 @@
deadbeef deadbeef
foo = {
a = 0x7
b = 0x2c
c = 0xbeef
d = <buffer uint8_t[8] d>
61 62 63 64 65 66 67 68
}
"\007\000,\000\000\190\239abcdefgh"
with_ignored_field = {
a = 0x1
c = 0x3
}

191
unikernel/duniverse/ocaml-cstruct/ppx_test/basic.ml Normal file
View file

@ -0,0 +1,191 @@
(*
* Copyright (c) 2016 Hannes Mehnert <hannes@mehnert.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
[%%cstruct
type foo = {
a : uint8_t;
b : uint16_t;
c : uint32_t;
d : uint8_t [@len 8]
} [@@big_endian]
]
[%%cstruct
type bar = {
a : uint8_t;
b : uint16_t;
c : uint32_t;
d : uint8_t [@len 8]
} [@@big_endian]
]
[%%cstruct
type lbar = {
a : uint8_t;
b : uint16_t;
c : uint32_t;
d : uint8_t [@len 8]
} [@@little_endian]
]
(* see #72
[%%cstruct
type hbar = {
a : uint8_t;
b : uint16_t;
c : uint32_t;
d : uint8_t [@len 8]
} [@@host_endian]
]
*)
[%%cstruct
type bibar = {
a : uint8_t;
b : uint16_t;
c : uint32_t;
d : uint8_t [@len 8]
} [@@bi_endian]
]
(** This should not emit any warnings *)
[%%cstruct
type unused = {
a : uint8_t;
b : uint16_t;
c : uint32_t;
d : uint8_t;
e : uint8_t; [@len 16]
} [@@big_endian]
]
let set_with_ignored_field__b = true
let _ : bool = set_with_ignored_field__b
[%%cstruct
type with_ignored_field = {
a : uint8_t;
_b : uint8_t;
c : uint8_t;
} [@@little_endian]
]
let _ : bool = set_with_ignored_field__b
(** This should not emit any warnings either *)
[%%cenum
type unused_cenum =
| DROPPED [@id 0xfffe]
| ERROR [@id 0xffff]
| OKAY [@id 0]
| NULL [@id 1]
[@@int16_t] [@@sexp]
]
(** Duplicate _ fields are OK *)
[%%cstruct
type with_several_ignored =
{ x : int8_t
; _y : int8_t
; z : int8_t
; _y : int8_t
} [@@little_endian]
]
let tests () =
(* Test basic set/get functions *)
let be = Cstruct.of_bigarray (Bigarray.(Array1.create char c_layout sizeof_foo)) in
for i = 0 to 255 do
set_bar_a be i;
assert(get_bar_a be = i)
done;
let le = Cstruct.of_bigarray (Bigarray.(Array1.create char c_layout sizeof_bar)) in
for i = 0 to 255 do
set_foo_a le i;
assert(get_foo_a le = i)
done;
let bibe = Cstruct.of_bigarray (Bigarray.(Array1.create char c_layout BE.sizeof_bibar)) in
for i = 0 to 255 do
BE.set_bibar_a bibe i;
assert(BE.get_bibar_a bibe = i)
done;
let bile = Cstruct.of_bigarray (Bigarray.(Array1.create char c_layout LE.sizeof_bibar)) in
for i = 0 to 255 do
LE.set_bibar_a bile i;
assert(LE.get_bibar_a bile = i)
done;
let be = Cstruct.of_bigarray (Bigarray.(Array1.create char c_layout sizeof_foo)) in
for i = 0 to 65535 do
set_bar_b be i;
assert(get_bar_b be = i)
done;
let le = Cstruct.of_bigarray(Bigarray.(Array1.create char c_layout sizeof_bar)) in
for i = 0 to 65535 do
set_foo_b le i;
assert(get_foo_b le = i)
done;
let bibe = Cstruct.of_bigarray (Bigarray.(Array1.create char c_layout BE.sizeof_bibar)) in
for i = 0 to 65535 do
BE.set_bibar_a bibe i;
assert(BE.get_bibar_a bibe = i mod 256)
done;
let bile = Cstruct.of_bigarray (Bigarray.(Array1.create char c_layout LE.sizeof_bibar)) in
for i = 0 to 65535 do
LE.set_bibar_a bile i;
assert(LE.get_bibar_a bile = i mod 256)
done;
let be = Cstruct.of_bigarray (Bigarray.(Array1.create char c_layout sizeof_foo)) in
let rec fn = function
|i when i < 0l -> ()
|i ->
set_bar_c be i;
assert(get_bar_c be = i);
fn (Int32.sub i 0x10l)
in fn 0xffffffff_l;
let le = Cstruct.of_bigarray (Bigarray.(Array1.create char c_layout sizeof_bar)) in
let rec fn = function
|i when i < 0l -> ()
|i ->
set_foo_c le i;
assert(get_foo_c le = i);
fn (Int32.sub i 0x10l)
in fn 0xffffffff_l;
(* Get/set buffers and blits *)
let s1 = "deadbeef" in
set_foo_d s1 0 be;
assert(copy_foo_d be = s1);
let sb1 = get_foo_d be in
blit_bar_d sb1 0 le;
assert(copy_bar_d le = s1);
Printf.printf "%s %s\n" (copy_foo_d be) (copy_bar_d le);
(* Create sub-view and shift it back *)
let be = Cstruct.of_bigarray (Bigarray.(Array1.create char c_layout sizeof_foo)) in
set_foo_a be 7;
set_foo_b be 44;
set_foo_c be 0xbeef_l;
set_foo_d "abcdefgh" 0 be;
(* get a subview *)
let be2 = Cstruct.shift be 3 in
assert(Cstruct.BE.get_uint32 be2 0 = 0xbeef_l);
assert(Cstruct.BE.get_uint32 be 3 = 0xbeef_l);
assert(get_foo_b be = 44);
assert(get_foo_a be = 7);
hexdump_foo be;
print_endline (Sexplib.Sexp.to_string_hum (Cstruct_sexp.sexp_of_t be));
hexdump_with_ignored_field (Cstruct.of_hex "010203")
let () = tests ()

0
unikernel/duniverse/ocaml-cstruct/ppx_test/basic.mli Normal file
View file

7
unikernel/duniverse/ocaml-cstruct/ppx_test/dune Normal file
View file

@ -0,0 +1,7 @@
(tests
(names pcap basic enum)
(deps http.cap)
(libraries cstruct-unix sexplib cstruct-sexp)
(preprocess
(pps ppx_cstruct))
(package ppx_cstruct))

95
unikernel/duniverse/ocaml-cstruct/ppx_test/enum.ml Normal file
View file

@ -0,0 +1,95 @@
(*
* Copyright (c) 2016 Hannes Mehnert <hannes@mehnert.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
[%%cenum
type foo64 =
| ONE64
| TWO64
| THREE64
[@@uint64_t] [@@sexp]
]
[%%cenum
type bar64 =
| ONE64
| TWO64 [@id 0xfffffffffffffffeL]
| THREE64
[@@uint64_t] [@@sexp]
]
[%%cenum
type foo32 =
| ONE32
| TWO32 [@id 0xfffffffel]
| THREE32
[@@uint32_t]
]
[%%cenum
type bar16 =
| ONE [@id 1]
| TWO
| FOUR [@id 4]
| FIVE
[@@uint16_t]
]
[%%cenum
type foo16 =
| ONE16
| TWO16
| THREE16
[@@uint16_t]
]
[%%cenum
type foo8 =
| ONE8
| TWO8
| THREE8
[@@uint8_t]
]
[%%cenum
type reversed =
| ONE_R [@id 2]
| TWO_R [@id 1]
[@@uint8_t]
]
let tests () =
ignore(int_to_foo64 2L);
ignore(int_to_foo32 1l);
ignore(int_to_foo16 1);
ignore(int_to_foo8 1);
ignore(foo64_to_int ONE64);
ignore(foo32_to_int ONE32);
ignore(foo16_to_int ONE16);
ignore(foo8_to_int ONE8);
assert(bar16_to_int FOUR = 4);
assert(bar16_to_int FIVE = 5);
assert(foo32_to_int TWO32 = 0xfffffffel);
assert(foo32_to_int THREE32 = 0xffffffffl);
assert(int_to_foo32 0xfffffffel = Some (TWO32));
assert(int_to_foo32 0xffffffffl = Some (THREE32));
assert(string_to_foo16 "ONE16" = Some ONE16);
assert(foo8_to_string ONE8 = "ONE8");
assert(compare_foo8 ONE8 TWO8 = -1);
assert(compare_foo8 TWO8 ONE8 = 1);
assert(compare_foo8 TWO8 TWO8 = 0);
assert(compare_reversed ONE_R TWO_R = 1)
let () = tests ()

15
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/README.md Normal file
View file

@ -0,0 +1,15 @@
This tests error cases for `ppx_cstruct`.
It only deals with the errors raised by the ppx itself (such as when the type is
not supported), not errors in the generated code.
To add a test case:
- create a file in this directory named `something.ml` with the error case
- create an empty file named `something.ml.expected`
- don't forget to add these files to git
- run `dune runtest`: it displays a diff on `dune.inc`
- run `dune promote`: it updates `dune.inc` with the generated test case
- run `dune runtest`: it runs the test and displays a diff against the empty
expected output
- run `dune promote`: it updates `something.ml.expected`

4
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cenum_id_payload.ml Normal file
View file

@ -0,0 +1,4 @@
[%%cenum
type t = A [@id ""]
[@@uint8_t]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cenum_id_payload.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: invalid id

4
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cenum_invalid_type.ml Normal file
View file

@ -0,0 +1,4 @@
[%%cenum
type t = A of int
[@@uint8_t]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cenum_invalid_type.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: invalid cenum variant

4
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cenum_no_attribute.ml Normal file
View file

@ -0,0 +1,4 @@
[%%cenum
type t =
| A
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cenum_no_attribute.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: invalid cenum attributes

5
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cenum_not_a_variant.ml Normal file
View file

@ -0,0 +1,5 @@
[%%cenum
type t =
{ x : uint8_t
}
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cenum_not_a_variant.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: expected variant type

5
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cenum_unknown_attribute.ml Normal file
View file

@ -0,0 +1,5 @@
[%%cenum
type t =
| A
[@@uint9_t]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cenum_unknown_attribute.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: enum: unknown width specifier uint9_t

6
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_attribute_payload.ml Normal file
View file

@ -0,0 +1,6 @@
[%%cstruct
type t =
{ a : uint8_t
}
[@@little_endian ""]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_attribute_payload.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: no attribute payload expected

7
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_duplicate_field.ml Normal file
View file

@ -0,0 +1,7 @@
[%%cstruct
type dup = {
x : uint8_t;
y : uint8_t;
x : uint8_t;
} [@@little_endian]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_duplicate_field.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: field x is present several times in this type

6
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_len_int32.ml Normal file
View file

@ -0,0 +1,6 @@
[%%cstruct
type t = {
a: uint8_t [@len 8l]
}
[@@little_endian]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_len_int32.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: [@len] argument should be an integer

6
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_len_not_int.ml Normal file
View file

@ -0,0 +1,6 @@
[%%cstruct
type t = {
a: uint8_t [@len ""]
}
[@@little_endian]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_len_not_int.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: [@len] argument should be an integer

6
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_len_zero.ml Normal file
View file

@ -0,0 +1,6 @@
[%%cstruct
type t = {
a: uint8_t [@len 0]
}
[@@little_endian]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_len_zero.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: [@len] argument should be > 0

6
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_multiple_len.ml Normal file
View file

@ -0,0 +1,6 @@
[%%cstruct
type t = {
a : (uint8_t [@len 2]) [@len 3]
}
[@@little_endian]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_multiple_len.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: multiple field length attribute

3
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_not_a_record.ml Normal file
View file

@ -0,0 +1,3 @@
[%%cstruct
type t = int
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_not_a_record.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: record type declaration expected

6
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_not_an_identifier.ml Normal file
View file

@ -0,0 +1,6 @@
[%%cstruct
type t = {
a : uint8_t list
}
[@@little_endian]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_not_an_identifier.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: type identifier expected

7
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_several_attributes.ml Normal file
View file

@ -0,0 +1,7 @@
[%%cstruct
type t =
{ a : uint8_t
}
[@@little_endian]
[@@other_attr]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_several_attributes.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: too many attributes

6
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_unknown_endian.ml Normal file
View file

@ -0,0 +1,6 @@
[%%cstruct
type t =
{ a : uint8_t
}
[@@unknown_endian]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_unknown_endian.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: unknown endian unknown_endian, should be little_endian, big_endian, host_endian or bi_endian

6
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_unknown_type.ml Normal file
View file

@ -0,0 +1,6 @@
[%%cstruct
type t =
{ a : uint9_t
}
[@@little_endian]
]

1
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/cstruct_unknown_type.ml.expected Normal file
View file

@ -0,0 +1 @@
Error: ppx_cstruct: Unknown type uint9_t

27
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/dune Normal file
View file

@ -0,0 +1,27 @@
(executable
(name pp)
(modules pp)
(preprocess
(action
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file})))
(libraries ppx_cstruct ocaml-migrate-parsetree))
(executable
(name gen_tests)
(modules gen_tests))
(include dune.inc)
(rule
(targets dune.inc.gen)
(deps
(source_tree .))
(action
(with-stdout-to
%{targets}
(run ./gen_tests.exe))))
(rule
(alias runtest)
(action
(diff dune.inc dune.inc.gen)))

224
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/dune.inc Normal file
View file

@ -0,0 +1,224 @@
(rule
(deps pp.exe (:input cenum_id_payload.ml))
(targets cenum_id_payload.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cenum_id_payload.ml.expected cenum_id_payload.ml.errors)))
(rule
(deps pp.exe (:input cenum_invalid_type.ml))
(targets cenum_invalid_type.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cenum_invalid_type.ml.expected cenum_invalid_type.ml.errors)))
(rule
(deps pp.exe (:input cenum_no_attribute.ml))
(targets cenum_no_attribute.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cenum_no_attribute.ml.expected cenum_no_attribute.ml.errors)))
(rule
(deps pp.exe (:input cenum_not_a_variant.ml))
(targets cenum_not_a_variant.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cenum_not_a_variant.ml.expected cenum_not_a_variant.ml.errors)))
(rule
(deps pp.exe (:input cenum_unknown_attribute.ml))
(targets cenum_unknown_attribute.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cenum_unknown_attribute.ml.expected cenum_unknown_attribute.ml.errors)))
(rule
(deps pp.exe (:input cstruct_attribute_payload.ml))
(targets cstruct_attribute_payload.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cstruct_attribute_payload.ml.expected cstruct_attribute_payload.ml.errors)))
(rule
(deps pp.exe (:input cstruct_duplicate_field.ml))
(targets cstruct_duplicate_field.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cstruct_duplicate_field.ml.expected cstruct_duplicate_field.ml.errors)))
(rule
(deps pp.exe (:input cstruct_len_int32.ml))
(targets cstruct_len_int32.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cstruct_len_int32.ml.expected cstruct_len_int32.ml.errors)))
(rule
(deps pp.exe (:input cstruct_len_not_int.ml))
(targets cstruct_len_not_int.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cstruct_len_not_int.ml.expected cstruct_len_not_int.ml.errors)))
(rule
(deps pp.exe (:input cstruct_len_zero.ml))
(targets cstruct_len_zero.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cstruct_len_zero.ml.expected cstruct_len_zero.ml.errors)))
(rule
(deps pp.exe (:input cstruct_multiple_len.ml))
(targets cstruct_multiple_len.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cstruct_multiple_len.ml.expected cstruct_multiple_len.ml.errors)))
(rule
(deps pp.exe (:input cstruct_not_a_record.ml))
(targets cstruct_not_a_record.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cstruct_not_a_record.ml.expected cstruct_not_a_record.ml.errors)))
(rule
(deps pp.exe (:input cstruct_not_an_identifier.ml))
(targets cstruct_not_an_identifier.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cstruct_not_an_identifier.ml.expected cstruct_not_an_identifier.ml.errors)))
(rule
(deps pp.exe (:input cstruct_several_attributes.ml))
(targets cstruct_several_attributes.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cstruct_several_attributes.ml.expected cstruct_several_attributes.ml.errors)))
(rule
(deps pp.exe (:input cstruct_unknown_endian.ml))
(targets cstruct_unknown_endian.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cstruct_unknown_endian.ml.expected cstruct_unknown_endian.ml.errors)))
(rule
(deps pp.exe (:input cstruct_unknown_type.ml))
(targets cstruct_unknown_type.ml.errors)
(action
(progn
(with-stderr-to %{targets}
(run ./pp.exe -no-color --impl %{input}))
(bash "sed -i.bak '1d' %{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff cstruct_unknown_type.ml.expected cstruct_unknown_type.ml.errors)))

31
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/gen_tests.ml Normal file
View file

@ -0,0 +1,31 @@
let output_stanzas name =
Printf.printf
{|
(rule
(deps pp.exe (:input %s))
(targets %s.errors)
(action
(progn
(with-stderr-to %%{targets}
(run ./pp.exe -no-color --impl %%{input}))
(bash "sed -i.bak '1d' %%{targets}"))))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(diff %s.expected %s.errors)))
|}
name name name name
let is_test = function
| "pp.ml" -> false
| "pp.pp.ml" -> false
| "gen_tests.ml" -> false
| e -> Filename.check_suffix e ".ml"
let () =
Sys.readdir "."
|> Array.to_list
|> List.sort String.compare
|> List.filter is_test
|> List.iter output_stanzas

11
unikernel/duniverse/ocaml-cstruct/ppx_test/errors/pp.ml Normal file
View file

@ -0,0 +1,11 @@
(* we can just use exit from 4.07 onwards, but 4.06
* and earlier executed at_exit recursively *)
external sys_exit : int -> 'a = "caml_sys_exit"
let () = at_exit (fun () -> sys_exit 0)
#if OCAML_VERSION >= (4,8,0)
let () = Clflags.(error_style := Some Short)
#endif
let () = Clflags.(color := Some Never)
let () = Ppxlib.Driver.standalone ()

BIN
unikernel/duniverse/ocaml-cstruct/ppx_test/http.cap Normal file
View file

Binary file not shown.

1910
unikernel/duniverse/ocaml-cstruct/ppx_test/pcap.expected Normal file
View file

File diff suppressed because it is too large Load diff

169
unikernel/duniverse/ocaml-cstruct/ppx_test/pcap.ml Normal file
View file

@ -0,0 +1,169 @@
(*
* Copyright (c) 2012-2016 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
[%%cstruct
type pcap_header = {
magic_number: uint32_t; (* magic number *)
version_major: uint16_t; (* major version number *)
version_minor: uint16_t; (* minor version number *)
thiszone: uint32_t; (* GMT to local correction *)
sigfigs: uint32_t; (* accuracy of timestamps *)
snaplen: uint32_t; (* max length of captured packets, in octets *)
network: uint32_t; (* data link type *)
} [@@little_endian]]
[%%cstruct
type pcap_packet = {
ts_sec: uint32_t; (* timestamp seconds *)
ts_usec: uint32_t; (* timestamp microseconds *)
incl_len: uint32_t; (* number of octets of packet saved in file *)
orig_len: uint32_t; (* actual length of packet *)
} [@@little_endian]]
[%%cstruct
type ethernet = {
dst: uint8_t [@len 6];
src: uint8_t [@len 6];
ethertype: uint16_t;
} [@@big_endian]]
[%%cstruct
type ipv4 = {
hlen_version: uint8_t;
tos: uint8_t;
len: uint16_t;
id: uint16_t;
off: uint16_t;
ttl: uint8_t;
proto: uint8_t;
csum: uint16_t;
src: uint8_t [@len 4];
dst: uint8_t [@len 4];
} [@@big_endian]]
[%%cstruct
type tcpv4 = {
src_port: uint16_t;
dst_port: uint16_t;
seqnum: uint32_t;
acknum: uint32_t;
offset_flags: uint16_t;
window: uint16_t;
checksum: uint16_t;
urg: uint16_t;
} [@@big_endian]]
let mac_to_string buf =
let i n = Cstruct.get_uint8 buf n in
Printf.sprintf "%.2x:%.2x:%.2x:%.2x:%.2x:%.2x"
(i 0) (i 1) (i 2) (i 3) (i 4) (i 5)
open Printf
let print_packet p =
let dst_mac = mac_to_string (get_ethernet_dst p) in
let src_mac = mac_to_string (get_ethernet_src p) in
let ethertype = get_ethernet_ethertype p in
printf "ether %s -> %s etype %x\n" src_mac dst_mac ethertype;
match ethertype with
|0x0800 -> begin
let ip = Cstruct.shift p sizeof_ethernet in
let version = get_ipv4_hlen_version ip lsr 4 in
let hlen = (get_ipv4_hlen_version ip land 0xf) * 4 in
let ttl = get_ipv4_ttl ip in
let proto = get_ipv4_proto ip in
printf "ipv%d hlen %d ttl %d proto %d\n" version hlen ttl proto;
match proto with
|6 -> begin (* tcp *)
let tcp = Cstruct.shift ip sizeof_ipv4 in
let off = 0 in
let x = get_tcpv4_offset_flags tcp in
let data_offset = (x lsr 12) * 4 in
let options =
match data_offset - sizeof_tcpv4 with
|0 -> 0
|n -> n (* TODO parse *)
in
let payload = Cstruct.shift tcp data_offset in
let fin = (x land 1) = 1 in
let syn = (x land 2) = 2 in
let flags = "?" in
let src_port = get_tcpv4_src_port tcp in
let dst_port = get_tcpv4_dst_port tcp in
let seqnum = get_tcpv4_seqnum tcp in
let acknum = get_tcpv4_acknum tcp in
let window = get_tcpv4_window tcp in
printf "tcpv4 port %d->%d seq %lu ack %lu win %d off %d flags %s opt %d fin %b syn %b payload_len=%d\n"
src_port dst_port seqnum
acknum window off flags options fin syn (Cstruct.length payload);
()
end
|_ -> printf "unknown ip proto %d\n" proto
end
|x -> printf "unknown body %x\n" x
let print_pcap_packet (hdr,pkt) =
let ts_sec = get_pcap_packet_ts_sec hdr in
let ts_usec = get_pcap_packet_ts_usec hdr in
let incl_len = get_pcap_packet_incl_len hdr in
let orig_len = get_pcap_packet_orig_len hdr in
printf "\n** %lu.%lu bytes %lu (of %lu)\n"
ts_sec ts_usec incl_len orig_len;
print_packet pkt
let print_pcap_header buf =
let magic = get_pcap_header_magic_number buf in
let endian =
match magic with
|0xa1b2c3d4l -> "bigendian"
|0xd4c3b2a1l -> "littlendian"
|_ -> "not a pcap file"
in
let version_major = get_pcap_header_version_major buf in
let version_minor = get_pcap_header_version_minor buf in
let thiszone = get_pcap_header_thiszone buf in
let sigfis = get_pcap_header_sigfigs buf in
let snaplen = get_pcap_header_snaplen buf in
let header_network = get_pcap_header_network buf in
printf "pcap_header (len %d)\n" sizeof_pcap_header;
printf "magic_number %lx (%s)\n%!" magic endian;
printf "version %d %d\n" version_major version_minor;
printf "timezone shift %lu\n" thiszone;
printf "timestamp accuracy %lu\n" sigfis;
printf "snaplen %lu\n" snaplen;
printf "lltype %lx\n" header_network
let parse () =
printf "start parse\n%!";
let fd = Unix.(openfile "http.cap" [O_RDONLY] 0) in
let t = Unix_cstruct.of_fd fd in
printf "total pcap file length %d\n%!" (Cstruct.length t);
let header, body = Cstruct.split t sizeof_pcap_header in
print_pcap_header header;
let packets = Cstruct.iter
(fun buf -> Some (sizeof_pcap_packet + Int32.to_int (get_pcap_packet_incl_len buf)))
(fun buf -> buf, Cstruct.shift buf sizeof_pcap_packet)
body
in
let num_packets = Cstruct.fold
(fun a packet -> print_pcap_packet packet; (a+1))
packets 0
in
printf "num_packets %d\n%!" num_packets
let () = parse ()

5
unikernel/duniverse/ocaml-cstruct/ppx_test/with-lwt/dune Normal file
View file

@ -0,0 +1,5 @@
(executables
(names ppx_cstruct_and_lwt)
(preprocess
(pps lwt_ppx ppx_cstruct))
(libraries cstruct lwt lwt.unix))

15
unikernel/duniverse/ocaml-cstruct/ppx_test/with-lwt/ppx_cstruct_and_lwt.ml Normal file
View file

@ -0,0 +1,15 @@
[%%cstruct type foo = {
magic: uint8_t [@len 16];
}[@@little_endian]]
[%%cenum
type foo64 =
| ONE64
| TWO64
| THREE64
[@@uint64_t]
]
let foo =
let%lwt foo = Lwt.return () in
Lwt.return foo

11
unikernel/duniverse/ocaml-cstruct/ppx_test/with-sexp/dune Normal file
View file

@ -0,0 +1,11 @@
(executable
(name ppx_cstruct_and_sexp)
(preprocess
(pps ppx_cstruct ppx_sexp_conv -- -no-check))
(libraries cstruct sexplib cstruct-sexp))
(rule
(alias runtest)
(package ppx_cstruct)
(action
(run ./ppx_cstruct_and_sexp.exe)))

11
unikernel/duniverse/ocaml-cstruct/ppx_test/with-sexp/ppx_cstruct_and_sexp.ml Normal file
View file

@ -0,0 +1,11 @@
[%%cstruct type foo = {
magic: uint8_t [@len 16];
}[@@little_endian]]
open Sexplib.Std
type t = int [@@deriving sexp]
type bar = {
buf: Cstruct_sexp.t;
string: string;
} [@@deriving sexp]

5
unikernel/duniverse/ocaml-cstruct/unix/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name cstruct_unix)
(wrapped false)
(public_name cstruct-unix)
(libraries cstruct unix))

19
unikernel/duniverse/ocaml-cstruct/unix/unix_cstruct.ml Normal file
View file

@ -0,0 +1,19 @@
(*
* Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
let of_fd fd =
let buffer = Bigarray.(array1_of_genarray (Unix.map_file fd char c_layout false [|-1|])) in
Cstruct.of_bigarray buffer

20
unikernel/duniverse/ocaml-cstruct/unix/unix_cstruct.mli Normal file
View file

@ -0,0 +1,20 @@
(*
* Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** Unix functions that operate on Cstruct buffers. *)
val of_fd : Unix.file_descr -> Cstruct.t
(** [of_fd fd] memory maps the [fd] and returns a cstruct *)