pax_global_header00006660000000000000000000000064124716542720014524gustar00rootroot0000000000000052 comment=66bc5c41731a09ce475a95aef22e9ef5e646ff1a ocaml-ipaddr-2.6.1/000077500000000000000000000000001247165427200140665ustar00rootroot00000000000000ocaml-ipaddr-2.6.1/.gitignore000066400000000000000000000000461247165427200160560ustar00rootroot00000000000000_build configure setup.data setup.log ocaml-ipaddr-2.6.1/.travis.yml000066400000000000000000000004171247165427200162010ustar00rootroot00000000000000language: c install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh script: bash -ex .travis-opam.sh env: - OCAML_VERSION=3.12 PACKAGE=ipaddr - OCAML_VERSION=4.01 PACKAGE=ipaddr - OCAML_VERSION=latest PACKAGE=ipaddr ocaml-ipaddr-2.6.1/CHANGES000066400000000000000000000076671247165427200151010ustar00rootroot000000000000002.6.1 (2015-02-20): * Fix findlib requires in oasis to restore pre-4.02.1 compatibility 2.6.0 (2015-02-19): * Change IPv6 link-local address prefix from fe80::/10 to fe80::/64. (#39) * Remove type bytes = string alias (potentially breaking) * Turn on -safe-string (#41) * {V4,V6}.to_bytes_raw now uses Bytes.t rather than string (potentially breaking) * Add multicast MAC conversions from RFC 1112 and RFC 2464 * Add to_domain_name conversions to DNS label lists (in-addr.arpa and ip6.arpa) * Add V6.interface_routers, V6.site_routers, and V6.Prefix.solicited_node * Add V6.link_address_of_mac to convert a MAC into a link local IP address 2.5.0 (2014-05-27): * Add `with sexp` (de)serializers to all of the Ipaddr and Macaddr types. (#31) 2.4.0 (2014-02-11): * Add `Ipaddr.V6.Prefix.of_netmask` for conversion from an IPv6 address/netmask to prefix (useful for some binary interfaces). See #27. * Add `Ipaddr.V6.Prefix.netmask` to generate a netmask address from a prefix (useful for some binary interfaces). See #27. * Add `Ipaddr.Prefix.network` for generic prefix -> address conversion * Add `Ipaddr.Prefix.netmask` for generic prefix -> netmask conversion 2.3.0 (2014-02-05): * Add `Ipaddr.V4.Prefix.of_netmask` for conversion from an address/netmask to prefix * Add `Ipaddr.V4.Prefix.netmask` to generate a netmask address from a prefix 2.2.0 (2014-01-27): * Add an [Ipaddr_unix] module to convert to-and-from the standard library. * Add a toplevel pretty printer in the `ipaddr.top` package. 2.1.0 (2014-01-20): * Add `of_string_raw` to `Ipaddr.V4.Prefix` and `Ipaddr.V6.Prefix` * Add `of_addr` to `Ipaddr.V4.Prefix` and `Ipaddr.V6.Prefix` * Add type `('v4,'v6) v4v6` to `Ipaddr` to represent version disjuncts * Add `Ipaddr.Prefix` module for generic prefix manipulation 2.0.0 (2014-01-17): * Change `Ipaddr.V4.make` to accept `int` rather than `int32` (breaking) * Add IPv6 support * Add generic IP address support * Add type `scope` for classifying address scopes * Add `Ipaddr.V4.of_string_raw` for parsing inside of larger strings * Add `Ipaddr.V4.to_int16` and `Ipaddr.V4.of_int16` * Add `unspecified`, `nodes`, and `routers` constants to `Ipaddr.V4` * Add `Ipaddr.V4.Prefix.network_address` to put an address into a subnet * Add `of_address_string_exn`, `of_address_string`, `to_address_string`, `to_address_buffer` to `Ipaddr.V4.Prefix` to parse/print combined addr/prefix * Add `multicast_org`, `multicast_admin`, `multicast_link` subnet constants to `Ipaddr.V4.Prefix` * Add `Ipaddr.V4.scope` to classify IPv4 addresses * Add `Ipaddr.V4.is_global` and `Ipaddr.V4.is_multicast` predicates * Add optional `sep:char` argument to `Macaddr.to_string` * Remove internal use of Scanf.scanf 1.0.0 (2013-10-16): * Add Travis-CI testing scripts. * Include debug symbols and annot files by default. 0.2.3 (2013-09-20): * Add `Ipaddr.V4.Prefix.bits` function to produce bits of prefix from prefix. 0.2.2 (2013-08-07): * Add `Macaddr.make_local` function to create local unicast MAC addresses from an octet generation function. * Add `Macaddr.get_oui` accessor to extract the Organizationally Unique Identifier as an integer. * Add `Macaddr.is_local` predicate to test for a locally administered address. * Add `Macaddr.is_unicast` predicate to test for a unicast MAC address. 0.2.1 (2013-08-01): * Add `Ipaddr.V4.any`, `Ipaddr.V4.broadcast`, `Ipaddr.V4.localhost` special constant addresses. * Add `Ipaddr.V4.Prefix.global` (0.0.0.0/0) subnet constant. * Add `Ipaddr.V4.Prefix.network` function to produce subnet address from prefix. 0.2.0 (2013-08-01): * Add `Macaddr` module for handling MAC-48 (Ethernet) addresses. * `Ipaddr.Parse_error` now contains both the error condition and the failing input. * Add ocamldoc-compatible comments on all interfaces. 0.1.1 (2013-07-31): * Add loopback and link local addresses to the private blocks. * Fix build system so Makefile is generated by OASIS. 0.1.0 (2013-07-24): * Initial public release. * Includes IPv4 and IPv4 CIDR prefix support. ocaml-ipaddr-2.6.1/Makefile000066400000000000000000000013561247165427200155330ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) SETUP = ocaml setup.ml build: setup.data $(SETUP) -build $(BUILDFLAGS) doc: setup.data build $(SETUP) -doc $(DOCFLAGS) test: setup.data build $(SETUP) -test $(TESTFLAGS) all: $(SETUP) -all $(ALLFLAGS) install: setup.data $(SETUP) -install $(INSTALLFLAGS) uninstall: setup.data $(SETUP) -uninstall $(UNINSTALLFLAGS) reinstall: setup.data $(SETUP) -reinstall $(REINSTALLFLAGS) clean: $(SETUP) -clean $(CLEANFLAGS) distclean: $(SETUP) -distclean $(DISTCLEANFLAGS) setup.data: $(SETUP) -configure $(CONFIGUREFLAGS) configure: $(SETUP) -configure $(CONFIGUREFLAGS) .PHONY: build doc test all install uninstall reinstall clean distclean configure # OASIS_STOP ocaml-ipaddr-2.6.1/README.md000066400000000000000000000020011247165427200153360ustar00rootroot00000000000000# ocaml-ipaddr A library for manipulation of IP (and MAC) address representations. Features: * Depends only on sexplib (conditionalization under consideration) * oUnit-based tests * IPv4 and IPv6 support * IPv4 and IPv6 CIDR prefix support * IPv4 and IPv6 [CIDR-scoped address](http://tools.ietf.org/html/rfc4291#section-2.3) support * `Ipaddr.V4` and `Ipaddr.V4.Prefix` modules are `Map.OrderedType` * `Ipaddr.V6` and `Ipaddr.V6.Prefix` modules are `Map.OrderedType` * `Ipaddr` and `Ipaddr.Prefix` modules are `Map.OrderedType` * `Ipaddr_unix` in findlib subpackage `ipaddr.unix` provides compatibility with the standard library `Unix` module * `Ipaddr_top` in findlib subpackage `ipaddr.top` provides top-level pretty printers (requires compiler-libs default since OCaml 4.0) * IP address scope classification * IPv4-mapped addresses in IPv6 (::ffff:0:0/96) are an embedding of IPv4 * MAC-48 (Ethernet) address support * `Macaddr` is a `Map.OrderedType` * All types have sexplib serializers/deserializers ocaml-ipaddr-2.6.1/_oasis000066400000000000000000000024241247165427200152700ustar00rootroot00000000000000OASISFormat: 0.3 Name: ipaddr Version: 2.6.0 Synopsis: A library for manipulation of IP (and MAC) address representations Authors: David Sheets, Anil Madhavapeddy, Hugo Heuzard License: ISC Plugins: META (0.3), DevFiles (0.3) BuildTools: ocamlbuild Flag unix Description: build the Unix library Default: true Flag top Description: build the toplevel printers Default: true Library ipaddr Path: lib Findlibname: ipaddr BuildDepends: bytes, sexplib, sexplib.syntax XMETARequires: bytes, sexplib Modules: Ipaddr, Macaddr NativeOpt: -w @f@p@u@s@40 ByteOpt: -w @f@p@u@s@40 Library ipaddr_unix Build$: flag(unix) Path: lib Findlibparent: ipaddr Findlibname: unix Modules: Ipaddr_unix BuildDepends: unix, ipaddr Library ipaddr_top Build$: flag(top) Path: top FindlibName: top FindlibParent: ipaddr Modules: Ipaddr_top # Compiler libs do not exists for OCaml < 4.0.0 and otherwise always # present. Use _tags to set them up. # BuildDepends: compiler-libs.toplevel XMETARequires: ipaddr XMETADescription: Toplevel printers for IP addresses Test ipaddr Run: true Command: make WorkingDirectory: lib_test ocaml-ipaddr-2.6.1/_tags000066400000000000000000000020241247165427200151040ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: ca6d0ca33b49d735e479caedbeb4ec59) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse ".bzr": not_hygienic ".hg": -traverse ".hg": not_hygienic ".git": -traverse ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic # Library ipaddr "lib/ipaddr.cmxs": use_ipaddr : oasis_library_ipaddr_byte : oasis_library_ipaddr_byte : oasis_library_ipaddr_native : oasis_library_ipaddr_native # Library ipaddr_unix "lib/ipaddr_unix.cmxs": use_ipaddr_unix : pkg_bytes : pkg_sexplib : pkg_sexplib.syntax : pkg_unix : use_ipaddr # Library ipaddr_top "top/ipaddr_top.cmxs": use_ipaddr_top # OASIS_STOP true: debug, annot, bin_annot, principal, safe_string : I(+compiler-libs) ocaml-ipaddr-2.6.1/lib/000077500000000000000000000000001247165427200146345ustar00rootroot00000000000000ocaml-ipaddr-2.6.1/lib/META000066400000000000000000000017711247165427200153130ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 41ee21d4146b5d6f59aa1b873b633a48) version = "2.6.0" description = "A library for manipulation of IP (and MAC) address representations" requires = "bytes sexplib" archive(byte) = "ipaddr.cma" archive(byte, plugin) = "ipaddr.cma" archive(native) = "ipaddr.cmxa" archive(native, plugin) = "ipaddr.cmxs" exists_if = "ipaddr.cma" package "unix" ( version = "2.6.0" description = "A library for manipulation of IP (and MAC) address representations" requires = "unix ipaddr" archive(byte) = "ipaddr_unix.cma" archive(byte, plugin) = "ipaddr_unix.cma" archive(native) = "ipaddr_unix.cmxa" archive(native, plugin) = "ipaddr_unix.cmxs" exists_if = "ipaddr_unix.cma" ) package "top" ( version = "2.6.0" description = "Toplevel printers for IP addresses" requires = "ipaddr" archive(byte) = "ipaddr_top.cma" archive(byte, plugin) = "ipaddr_top.cma" archive(native) = "ipaddr_top.cmxa" archive(native, plugin) = "ipaddr_top.cmxs" exists_if = "ipaddr_top.cma" ) # OASIS_STOP ocaml-ipaddr-2.6.1/lib/ipaddr.ml000066400000000000000000000673511247165427200164450ustar00rootroot00000000000000(* * Copyright (c) 2013-2015 David Sheets * * 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.Std exception Parse_error of string * string with sexp type scope = | Point | Interface | Link | Admin | Site | Organization | Global with sexp let (~|) = Int32.of_int let (|~) = Int32.to_int let (&&&) x y = Int32.logand x y let (|||) x y = Int32.logor x y let (<|<) x y = Int32.shift_left x y let (>|>) x y = Int32.shift_right_logical x y let (>!) x y = (x >|> y) &&& 0xFF_l let ( Pervasives.int_of_char c - char_0 | 'a'..'f' -> 10 + Pervasives.int_of_char c - char_a | 'A'..'F' -> 10 + Pervasives.int_of_char c - char_A | _ -> -1 let bad_char i s = let msg = Printf.sprintf "invalid character '%c' at %d" s.[i] i in Parse_error (msg, s) let is_number base n = n >=0 && n < base let parse_int base s i = let len = String.length s in let rec next prev = let j = !i in if j >= len then prev else let c = s.[j] in let k = int_of_char c in if is_number base k then (incr i; next (prev*base + k)) else prev in let i = !i in if i < len then if is_number base (int_of_char s.[i]) then next 0 else raise (bad_char i s) else raise (need_more s) let parse_dec_int s i = parse_int 10 s i let parse_hex_int s i = parse_int 16 s i let expect_char s i c = if !i < String.length s then if s.[!i] <> c then raise (bad_char !i s) else incr i else raise (need_more s) let expect_end s i = if String.length s <= !i then () else raise (bad_char !i s) let hex_char_of_int = function | 0 -> '0' | 1 -> '1' | 2 -> '2' | 3 -> '3' | 4 -> '4' | 5 -> '5' | 6 -> '6' | 7 -> '7' | 8 -> '8' | 9 -> '9' | 10 -> 'a' | 11 -> 'b' | 12 -> 'c' | 13 -> 'd' | 14 -> 'e' | 15 -> 'f' | _ -> raise (Invalid_argument "not a hex int") let hex_string_of_int32 i = String.make 1 (hex_char_of_int (Int32.to_int i)) module V4 = struct type t = int32 let compare a b = (* ignore the sign *) let c = Int32.compare (a >|> 1) (b >|> 1) in if c = 0 then Int32.compare (a &&& 1l) (b &&& 1l) else c let make a b c d = ((~| a a in if valid a then raise (Parse_error ("first octet out of bounds", s)) else if valid b then raise (Parse_error ("second octet out of bounds", s)) else if valid c then raise (Parse_error ("third octet out of bounds", s)) else if valid d then raise (Parse_error ("fourth octet out of bounds", s)) else make a b c d (* string conversion *) let of_string_raw = parse_dotted_quad let of_string_exn s = let o = ref 0 in let x = of_string_raw s o in expect_end s o; x let of_string s = try Some (of_string_exn s) with _ -> None let to_buffer b i = Printf.bprintf b "%ld.%ld.%ld.%ld" (i >! 24) (i >! 16) (i >! 8) (i >! 0) let to_string i = let b = Buffer.create 15 in to_buffer b i; Buffer.contents b let pp_hum ppf i = Format.fprintf ppf "%s" (to_string i) let sexp_of_t i = Sexplib.Sexp.Atom (to_string i) let t_of_sexp i = match i with | Sexplib.Sexp.Atom i -> of_string_exn i | _ -> raise (Failure "Ipaddr.V4.t: Unexpected non-atom in sexp") (* Byte conversion *) let of_bytes_raw bs o = make (Char.code bs.[0 + o]) (Char.code bs.[1 + o]) (Char.code bs.[2 + o]) (Char.code bs.[3 + o]) let of_bytes_exn bs = let len = String.length bs in if len > 4 then raise (too_much bs); if len < 4 then raise (need_more bs); of_bytes_raw bs 0 let of_bytes bs = try Some (of_bytes_exn bs) with _ -> None let to_bytes_raw i b o = Bytes.set b (0 + o) (Char.chr ((|~) (i >! 24))); Bytes.set b (1 + o) (Char.chr ((|~) (i >! 16))); Bytes.set b (2 + o) (Char.chr ((|~) (i >! 8))); Bytes.set b (3 + o) (Char.chr ((|~) (i >! 0))) let to_bytes i = let b = Bytes.create 4 in to_bytes_raw i b 0; Bytes.to_string b (* Int32*) let of_int32 i = i let to_int32 i = i (* Int16 *) let of_int16 (a,b) = (~| a <|< 16) ||| (~| b) let to_int16 a = ((|~) (a >|> 16), (|~) (a &&& 0xFF_FF_l)) (** MAC *) (** {{:http://tools.ietf.org/html/rfc1112#section-6.2}RFC 1112}. *) let multicast_to_mac i = let macb = Bytes.create 6 in Bytes.set macb 0 (Char.chr 0x01); Bytes.set macb 1 (Char.chr 0x00); Bytes.set macb 2 (Char.chr 0x5E); Bytes.set macb 3 (Char.chr ((|~) (i >|> 16 &&& 0x7F_l))); Bytes.set macb 4 (Char.chr ((|~) (i >! 8))); Bytes.set macb 5 (Char.chr ((|~) (i >! 0))); Macaddr.of_bytes_exn (Bytes.to_string macb) (* Host *) let to_domain_name i = [ Int32.to_string (i >! 0); Int32.to_string (i >! 8); Int32.to_string (i >! 16); Int32.to_string (i >! 24); "in-addr"; "arpa"; ""; ] (* constant *) let any = make 0 0 0 0 let unspecified = make 0 0 0 0 let broadcast = make 255 255 255 255 let localhost = make 127 0 0 1 let nodes = make 224 0 0 1 let routers = make 224 0 0 2 module Prefix = struct type addr = t with sexp type t = addr * int with sexp let compare (pre,sz) (pre',sz') = let c = compare pre pre' in if c = 0 then Pervasives.compare sz sz' else c let ip = make let mask sz = if sz <= 0 then 0_l else if sz >= 32 then 0x0_FF_FF_FF_FF_l else 0x0_FF_FF_FF_FF_l <|< (32 - sz) let make sz pre = (pre &&& (mask sz),sz) let network_address (pre,sz) addr = pre ||| (addr &&& Int32.lognot (mask sz)) (* string conversion *) let _of_string_raw s i = let quad = of_string_raw s i in expect_char s i '/'; let p = parse_dec_int s i in if p > 32 || p < 0 then raise (Parse_error ("invalid prefix size", s)); (p,quad) let of_string_raw s i = let (p,quad) = _of_string_raw s i in make p quad let _of_string_exn s = let i = ref 0 in let res = _of_string_raw s i in expect_end s i; res let of_string_exn s = let (p,quad) = _of_string_exn s in make p quad let of_string s = try Some (of_string_exn s) with _ -> None let of_address_string_exn s = let (p,quad) = _of_string_exn s in (make p quad, quad) let of_address_string s = try Some (of_address_string_exn s) with _ -> None let of_netmask nm addr = let rec find_greatest_one bits i = if bits = 0_l then i-1 else find_greatest_one (bits >|> 1) (i+1) in let one = nm &&& (Int32.neg nm) in let sz = 32 - (find_greatest_one one (if one = 0_l then 33 else 0)) in if nm <> (mask sz) then raise (Parse_error ("invalid netmask",to_string nm)) else make sz addr let to_buffer buf (pre,sz) = Printf.bprintf buf "%a/%d" to_buffer pre sz let to_string subnet = let b = Buffer.create 18 in to_buffer b subnet; Buffer.contents b let pp_hum ppf i = Format.fprintf ppf "%s" (to_string i) let to_address_buffer buf ((_,sz) as subnet) addr = to_buffer buf (network_address subnet addr,sz) let to_address_string subnet addr = let b = Buffer.create 18 in to_address_buffer b subnet addr; Buffer.contents b let mem ip (pre,sz) = let host = 32 - sz in (ip >|> host) = (pre >|> host) let of_addr ip = make 32 ip let global = make 0 (ip 0 0 0 0) let relative = make 8 (ip 0 0 0 0) let loopback = make 8 (ip 127 0 0 0) let link = make 16 (ip 169 254 0 0) let multicast = make 4 (ip 224 0 0 0) let multicast_org = make 14 (ip 239 192 0 0) let multicast_admin = make 16 (ip 239 255 0 0) let multicast_link = make 24 (ip 224 0 0 0) (* http://tools.ietf.org/html/rfc2365 *) let private_10 = make 8 (ip 10 0 0 0) let private_172 = make 12 (ip 172 16 0 0) let private_192 = make 16 (ip 192 168 0 0) let private_blocks = [ loopback ; link ; private_10 ; private_172 ; private_192 ] let broadcast (pre,sz) = pre ||| (0x0_FF_FF_FF_FF_l >|> sz) let network (pre,sz) = pre let bits (pre,sz) = sz let netmask subnet = mask (bits subnet) end (* TODO: this could be optimized with something trie-like *) let scope i = let mem = Prefix.mem i in if mem Prefix.loopback then Interface else if mem Prefix.link then Link else if List.exists mem Prefix.private_blocks then Organization else if i = unspecified then Point else if i = broadcast then Admin else if mem Prefix.relative then Admin else if mem Prefix.multicast then (if mem Prefix.multicast_org then Organization else if mem Prefix.multicast_admin then Admin else if mem Prefix.multicast_link then Link else Global) else Global let is_global i = (scope i) = Global let is_multicast i = Prefix.(mem i multicast) let is_private i = (scope i) <> Global end module B128 = struct type t = int32 * int32 * int32 * int32 let of_int64 (a, b) = Int64.( to_int32 (shift_right_logical a 32), to_int32 a, to_int32 (shift_right_logical b 32), to_int32 b) let to_int64 (a,b,c,d) = Int64.( logor (shift_left (of_int32 a) 32) (of_int32 b), logor (shift_left (of_int32 c) 32) (of_int32 d)) let of_int32 x = x let to_int32 x = x let of_int16 (a, b, c, d, e, f, g, h) = V4.of_int16 (a,b), V4.of_int16 (c,d), V4.of_int16 (e,f), V4.of_int16 (g,h) let to_int16 (x,y,z,t) = let a,b = V4.to_int16 x and c,d = V4.to_int16 y and e,f = V4.to_int16 z and g,h = V4.to_int16 t in (a,b,c,d,e,f,g,h) let to_bytes_raw (a,b,c,d) byte o = V4.to_bytes_raw a byte (o+0); V4.to_bytes_raw b byte (o+4); V4.to_bytes_raw c byte (o+8); V4.to_bytes_raw d byte (o+12) let of_bytes_exn bs = (* TODO : from cstruct *) let len = String.length bs in if len > 16 then raise (too_much bs); if len < 16 then raise (need_more bs); let hihi = V4.of_bytes_raw bs 0 in let hilo = V4.of_bytes_raw bs 4 in let lohi = V4.of_bytes_raw bs 8 in let lolo = V4.of_bytes_raw bs 12 in of_int32 (hihi, hilo, lohi, lolo) let compare (a1,b1,c1,d1) (a2,b2,c2,d2) = match V4.compare a1 a2 with | 0 -> begin match V4.compare b1 b2 with | 0 -> begin match V4.compare c1 c2 with | 0 -> V4.compare d1 d2 | n -> n end | n -> n end | n -> n let logand (a1,b1,c1,d1) (a2,b2,c2,d2) = (a1 &&& a2, b1 &&& b2, c1 &&& c2, d1 &&& d2) let logor (a1,b1,c1,d1) (a2,b2,c2,d2) = (a1 ||| a2, b1 ||| b2, c1 ||| c2, d1 ||| d2) let lognot (a,b,c,d) = Int32.(lognot a, lognot b, lognot c, lognot d) end module V6 = struct include B128 (* TODO: Perhaps represent with bytestring? *) let make a b c d e f g h = of_int16 (a,b,c,d,e,f,g,h) (* parsing *) let parse_ipv6 s i = let compressed = ref false in (* :: *) let len = String.length s in if len < !i + 2 then (raise (need_more s)); let use_bracket = s.[!i] = '['; in if use_bracket then incr i; (* check if it starts with :: *) let l = if s.[!i] = ':' then begin incr i; if s.[!i] = ':' then begin compressed := true; incr i; [-1] end else raise (bad_char !i s); end else [] in let rec loop nb acc = if nb >= 8 then acc else if !i >= len then acc else let pos = !i in let x = try parse_hex_int s i with _ -> -1 in if x < 0 then acc else if nb = 7 then x::acc else if !i < len && s.[!i] = ':' then begin incr i; if !i < len then if s.[!i] = ':' then if !compressed then (decr i; x::acc) (* trailing :: *) else begin compressed:=true; incr i; loop (nb + 2) (-1::x::acc) end else begin if is_number 16 (int_of_char s.[!i]) then loop (nb+1) (x::acc) else raise (bad_char !i s) end else raise (need_more s) end else if !i < len && s.[!i] = '.' then begin i:= pos; let v4 = V4.of_string_raw s i in let (hi,lo) = V4.to_int16 v4 in lo :: hi :: acc end else x::acc in let res = loop (List.length l) l in let res_len = List.length res in if res_len > 8 then raise (Parse_error ("too many components",s)) else if res_len = 0 then raise (need_more s) else let a = Array.make 8 0 in let missing = if !compressed then 8 - (res_len - 1) else if res_len <> 8 then if !i < len then raise (bad_char !i s) else raise (need_more s) else 0 in let _ = List.fold_left (fun i x -> if x = -1 then i - missing else begin if x land 0xffff <> x then raise (Parse_error (Printf.sprintf "component %d out of bounds" i, s)); a.(i) <- x; i - 1 end ) 7 res in (if use_bracket then expect_char s i ']'); a (* string conversion *) let of_string_raw s offset = let a = parse_ipv6 s offset in make a.(0) a.(1) a.(2) a.(3) a.(4) a.(5) a.(6) a.(7) let of_string_exn s = let o = ref 0 in let x = of_string_raw s o in expect_end s o; x let of_string s = try Some (of_string_exn s) with _ -> None (* http://tools.ietf.org/html/rfc5952 *) let to_buffer ?(v4=false) buf addr = let (a,b,c,d,e,f,g,h) as comp = to_int16 addr in let v4 = match comp with | (0,0,0,0,0,0xffff,_,_) -> true | _ -> v4 in let rec loop elide zeros acc = function | 0 :: xs -> loop elide (zeros - 1) acc xs | n :: xs when zeros = 0 -> loop elide 0 (n::acc) xs | n :: xs -> loop (min elide zeros) 0 (n::zeros::acc) xs | [] -> let elide = min elide zeros in (if elide < -1 then Some elide else None), (if zeros = 0 then acc else zeros::acc) in let elide,l = loop 0 0 [] [h;g;f;e;d;c;b;a] in assert(match elide with Some x when x < -8 -> false | _ -> true); let rec cons_zeros l x = if x >= 0 then l else cons_zeros (Some 0::l) (x+1) in let _,lrev = List.fold_left (fun (patt, l) x -> if Some x = patt then (None, (None::l)) else if x < 0 then (patt, (cons_zeros l x)) else (patt, ((Some x)::l)) ) (elide, []) l in let rec fill = function | [Some hi;Some lo] when v4 -> let addr = V4.of_int16 (hi, lo) in V4.to_buffer buf addr | None::xs -> Buffer.add_string buf "::"; fill xs | [Some n] -> Printf.bprintf buf "%x" n | (Some n)::None::xs -> Printf.bprintf buf "%x::" n; fill xs | (Some n)::xs -> Printf.bprintf buf "%x:" n; fill xs | [] -> () in fill (List.rev lrev) let to_string ?v4 l = let buf = Buffer.create 39 in to_buffer ?v4 buf l; Buffer.contents buf let pp_hum ppf i = Format.fprintf ppf "%s" (to_string i) let sexp_of_t i = Sexplib.Sexp.Atom (to_string i) let t_of_sexp i = match i with | Sexplib.Sexp.Atom i -> of_string_exn i | _ -> raise (Failure "Ipaddr.V6.t: Unexpected non-atom in sexp") (* byte conversion *) let of_bytes_raw bs o = (* TODO : from cstruct *) let hihi = V4.of_bytes_raw bs (o + 0) in let hilo = V4.of_bytes_raw bs (o + 4) in let lohi = V4.of_bytes_raw bs (o + 8) in let lolo = V4.of_bytes_raw bs (o + 12) in of_int32 (hihi, hilo, lohi, lolo) let of_bytes_exn bs = (* TODO : from cstruct *) let len = String.length bs in if len > 16 then raise (too_much bs); if len < 16 then raise (need_more bs); of_bytes_raw bs 0 let of_bytes bs = try Some (of_bytes_exn bs) with _ -> None let to_bytes i = let bs = Bytes.create 16 in to_bytes_raw i bs 0; Bytes.to_string bs (** MAC *) (** {{:https://tools.ietf.org/html/rfc2464#section-7}RFC 2464}. *) let multicast_to_mac i = let (_,_,_,i) = to_int32 i in let macb = Bytes.create 6 in Bytes.set macb 0 (Char.chr 0x33); Bytes.set macb 1 (Char.chr 0x33); Bytes.set macb 2 (Char.chr ((|~) (i >! 24))); Bytes.set macb 3 (Char.chr ((|~) (i >! 16))); Bytes.set macb 4 (Char.chr ((|~) (i >! 8))); Bytes.set macb 5 (Char.chr ((|~) (i >! 0))); Macaddr.of_bytes_exn (Bytes.to_string macb) (* Host *) let to_domain_name (a,b,c,d) = Printf.([ hex_string_of_int32 ((d >|> 0) &&& 0xF_l); hex_string_of_int32 ((d >|> 4) &&& 0xF_l); hex_string_of_int32 ((d >|> 8) &&& 0xF_l); hex_string_of_int32 ((d >|> 12) &&& 0xF_l); hex_string_of_int32 ((d >|> 16) &&& 0xF_l); hex_string_of_int32 ((d >|> 20) &&& 0xF_l); hex_string_of_int32 ((d >|> 24) &&& 0xF_l); hex_string_of_int32 ((d >|> 28) &&& 0xF_l); hex_string_of_int32 ((c >|> 0) &&& 0xF_l); hex_string_of_int32 ((c >|> 4) &&& 0xF_l); hex_string_of_int32 ((c >|> 8) &&& 0xF_l); hex_string_of_int32 ((c >|> 12) &&& 0xF_l); hex_string_of_int32 ((c >|> 16) &&& 0xF_l); hex_string_of_int32 ((c >|> 20) &&& 0xF_l); hex_string_of_int32 ((c >|> 24) &&& 0xF_l); hex_string_of_int32 ((c >|> 28) &&& 0xF_l); hex_string_of_int32 ((b >|> 0) &&& 0xF_l); hex_string_of_int32 ((b >|> 4) &&& 0xF_l); hex_string_of_int32 ((b >|> 8) &&& 0xF_l); hex_string_of_int32 ((b >|> 12) &&& 0xF_l); hex_string_of_int32 ((b >|> 16) &&& 0xF_l); hex_string_of_int32 ((b >|> 20) &&& 0xF_l); hex_string_of_int32 ((b >|> 24) &&& 0xF_l); hex_string_of_int32 ((b >|> 28) &&& 0xF_l); hex_string_of_int32 ((a >|> 0) &&& 0xF_l); hex_string_of_int32 ((a >|> 4) &&& 0xF_l); hex_string_of_int32 ((a >|> 8) &&& 0xF_l); hex_string_of_int32 ((a >|> 12) &&& 0xF_l); hex_string_of_int32 ((a >|> 16) &&& 0xF_l); hex_string_of_int32 ((a >|> 20) &&& 0xF_l); hex_string_of_int32 ((a >|> 24) &&& 0xF_l); hex_string_of_int32 ((a >|> 28) &&& 0xF_l); "ip6"; "arpa"; ""; ]) (* constant *) let unspecified = make 0 0 0 0 0 0 0 0 let localhost = make 0 0 0 0 0 0 0 1 let interface_nodes = make 0xff01 0 0 0 0 0 0 1 let link_nodes = make 0xff02 0 0 0 0 0 0 1 let interface_routers = make 0xff01 0 0 0 0 0 0 2 let link_routers = make 0xff02 0 0 0 0 0 0 2 let site_routers = make 0xff05 0 0 0 0 0 0 2 module Prefix = struct type addr = t with sexp type t = addr * int with sexp let compare (pre,sz) (pre',sz') = let c = compare pre pre' in if c = 0 then Pervasives.compare sz sz' else c let ip = make let full = let f = 0x0_FFFF_FFFF_l in f,f,f,f let mask sz = V4.Prefix.( mask (sz - 0), mask (sz - 32), mask (sz - 64), mask (sz - 96)) let make sz pre = (logand pre (mask sz),sz) let network_address (pre,sz) addr = logor pre (logand addr (lognot (mask sz))) let _of_string_raw s i = let v6 = of_string_raw s i in expect_char s i '/'; let p = parse_dec_int s i in if p > 128 || p < 0 then raise (Parse_error ("invalid prefix size", s)); (p, v6) let of_string_raw s i = let (p,v6) = _of_string_raw s i in make p v6 let _of_string_exn s = let i = ref 0 in let res = _of_string_raw s i in expect_end s i; res let of_string_exn s = let (p,v6) = _of_string_exn s in make p v6 let of_string s = try Some (of_string_exn s) with _ -> None let of_address_string_exn s = let (p,v6) = _of_string_exn s in (make p v6, v6) let of_address_string s = try Some (of_address_string_exn s) with _ -> None let of_netmask nm addr = make (match nm with | (0_l,0_l,0_l,0_l) -> 0 | (lsw ,0_l ,0_l ,0_l) -> V4.Prefix.(bits (of_netmask lsw V4.any)) | (-1_l,lsw ,0_l ,0_l) -> V4.Prefix.(bits (of_netmask lsw V4.any)) + 32 | (-1_l,-1_l,lsw ,0_l) -> V4.Prefix.(bits (of_netmask lsw V4.any)) + 64 | (-1_l,-1_l,-1_l,lsw) -> V4.Prefix.(bits (of_netmask lsw V4.any)) + 96 | _ -> raise (Parse_error ("invalid netmask", to_string nm)) ) addr let to_buffer buf (pre,sz) = Printf.bprintf buf "%a/%d" (to_buffer ~v4:false) pre sz let to_string subnet = let buf = Buffer.create 43 in to_buffer buf subnet; Buffer.contents buf let pp_hum ppf i = Format.fprintf ppf "%s" (to_string i) let to_address_buffer buf ((_,sz) as subnet) addr = to_buffer buf (network_address subnet addr,sz) let to_address_string subnet addr = let b = Buffer.create 43 in to_address_buffer b subnet addr; Buffer.contents b let mem ip (pre,sz) = let m = mask sz in logand ip m = logand pre m let of_addr ip = make 128 ip let global_unicast_001 = make 3 (ip 0x2000 0 0 0 0 0 0 0) let link = make 64 (ip 0xfe80 0 0 0 0 0 0 0) let unique_local = make 7 (ip 0xfc00 0 0 0 0 0 0 0) let multicast = make 8 (ip 0xff00 0 0 0 0 0 0 0) let ipv4_mapped = make 96 (ip 0 0 0 0 0 0xffff 0 0) let noneui64_interface = make 3 (ip 0x0000 0 0 0 0 0 0 0) let solicited_node = make 104 (ip 0xff02 0 0 0 0 1 0xff00 0) let network (pre,sz) = pre let bits (pre,sz) = sz let netmask subnet = mask (bits subnet) end (* TODO: This could be optimized with something trie-like *) let scope i = let mem = Prefix.mem i in if mem Prefix.global_unicast_001 then Global else if mem Prefix.ipv4_mapped (* rfc says they are technically global but... *) then V4.scope (let (_,_,_,v4) = to_int32 i in V4.of_int32 v4) else if mem Prefix.multicast then let (x,_,_,_,_,_,_,_) = to_int16 i in match x land 0xf with | 0 -> Point | 1 -> Interface | 2 | 3 -> Link | 4 -> Admin | 5 | 6 | 7 -> Site | 8 | 9 | 10 | 11 | 12 | 13 -> Organization | 14 | 15 -> Global | _ -> assert false else if mem Prefix.link then Link else if mem Prefix.unique_local then Global else if i = localhost then Interface else if i = unspecified then Point else Global let link_address_of_mac = let c b i = Char.code (String.get b i) in fun mac -> let bmac = Macaddr.to_bytes mac in let c_0 = c bmac 0 lxor 2 in let addr = make 0 0 0 0 (c_0 lsl 8 + c bmac 1) (c bmac 2 lsl 8 + 0xff ) (0xfe00 + c bmac 3) (c bmac 4 lsl 8 + c bmac 5) in Prefix.(network_address link addr) let is_global i = (scope i) = Global let is_multicast i = Prefix.(mem i multicast) let is_private i = (scope i) <> Global end type ('v4,'v6) v4v6 = V4 of 'v4 | V6 of 'v6 with sexp type t = (V4.t,V6.t) v4v6 with sexp let compare a b = match a,b with | V4 a, V4 b -> V4.compare a b | V6 a, V6 b -> V6.compare a b | V4 _, V6 _ -> -1 | V6 _, V4 _ -> 1 let to_string = function | V4 x -> V4.to_string x | V6 x -> V6.to_string x let to_buffer buf = function | V4 x -> V4.to_buffer buf x | V6 x -> V6.to_buffer buf x let pp_hum ppf i = Format.fprintf ppf "%s" (to_string i) let of_string_raw s offset = let len = String.length s in if len < !offset + 1 then raise (need_more s); match s.[0] with | '[' -> V6 (V6.of_string_raw s offset) | _ -> let pos = !offset in try V4 (V4.of_string_raw s offset) with Parse_error (v4_msg,_) -> offset := pos; try V6 (V6.of_string_raw s offset) with Parse_error(v6_msg,s) -> let msg = Printf.sprintf "not an IPv4 address: %s\nnot an IPv6 address: %s" v4_msg v6_msg in raise (Parse_error (msg,s)) let of_string_exn s = of_string_raw s (ref 0) let of_string s = try Some (of_string_exn s) with _ -> None let v6_of_v4 v4 = V6.(Prefix.(network_address ipv4_mapped (of_int32 (0l,0l,0l,v4)))) let v4_of_v6 v6 = if V6.Prefix.(mem v6 ipv4_mapped) then let (_,_,_,v4) = V6.to_int32 v6 in Some V4.(of_int32 v4) else None let to_v4 = function V4 v4 -> Some v4 | V6 v6 -> v4_of_v6 v6 let to_v6 = function V4 v4 -> v6_of_v4 v4 | V6 v6 -> v6 let scope = function V4 v4 -> V4.scope v4 | V6 v6 -> V6.scope v6 let is_global = function | V4 v4 -> V4.is_global v4 | V6 v6 -> V6.is_global v6 let is_multicast = function | V4 v4 -> V4.is_multicast v4 | V6 v6 -> V6.is_multicast v6 let is_private = function | V4 v4 -> V4.is_private v4 | V6 v6 -> V6.is_private v6 let multicast_to_mac = function | V4 v4 -> V4.multicast_to_mac v4 | V6 v6 -> V6.multicast_to_mac v6 let to_domain_name = function | V4 v4 -> V4.to_domain_name v4 | V6 v6 -> V6.to_domain_name v6 module Prefix = struct module Addr = struct let to_v6 = to_v6 end type addr = t with sexp type t = (V4.Prefix.t,V6.Prefix.t) v4v6 with sexp let compare a b = match a,b with | V4 a , V4 b -> V4.Prefix.compare a b | V6 a , V6 b -> V6.Prefix.compare a b | V4 _ , V6 _ -> -1 | V6 _ , V4 _ -> 1 let of_string_raw s offset = let len = String.length s in if len < !offset + 1 then raise (need_more s); match s.[0] with | '[' -> V6 (V6.Prefix.of_string_raw s offset) | _ -> let pos = !offset in try V4 (V4.Prefix.of_string_raw s offset) with Parse_error (v4_msg,_) -> offset := pos; try V6 (V6.Prefix.of_string_raw s offset) with Parse_error(v6_msg,s) -> let msg = Printf.sprintf "not an IPv4 prefix: %s\nnot an IPv6 prefix: %s" v4_msg v6_msg in raise (Parse_error (msg,s)) let of_string_exn s = of_string_raw s (ref 0) let of_string s = try Some (of_string_exn s) with _ -> None let v6_of_v4 v4 = V6.Prefix.make (96 + V4.Prefix.bits v4) (v6_of_v4 (V4.Prefix.network v4)) let v4_of_v6 v6 = match v4_of_v6 (V6.Prefix.network v6) with | Some v4 -> Some (V4.Prefix.make (V6.Prefix.bits v6 - 96) v4) | None -> None let to_v4 = function V4 v4 -> Some v4 | V6 v6 -> v4_of_v6 v6 let to_v6 = function V4 v4 -> v6_of_v4 v4 | V6 v6 -> v6 let mem ip prefix = V6.Prefix.mem (Addr.to_v6 ip) (to_v6 prefix) let of_addr = function | V4 p -> V4 (V4.Prefix.of_addr p) | V6 p -> V6 (V6.Prefix.of_addr p) let to_string = function | V4 p -> V4.Prefix.to_string p | V6 p -> V6.Prefix.to_string p let to_buffer buf = function | V4 p -> V4.Prefix.to_buffer buf p | V6 p -> V6.Prefix.to_buffer buf p let network = function | V4 p -> V4 (V4.Prefix.network p) | V6 p -> V6 (V6.Prefix.network p) let netmask = function | V4 p -> V4 (V4.Prefix.netmask p) | V6 p -> V6 (V6.Prefix.netmask p) let pp_hum ppf i = Format.fprintf ppf "%s" (to_string i) end ocaml-ipaddr-2.6.1/lib/ipaddr.mldylib000066400000000000000000000001431247165427200174530ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: d87e9ce6150361cb3829c7282ce6c915) Ipaddr Macaddr # OASIS_STOP ocaml-ipaddr-2.6.1/lib/ipaddr.mli000066400000000000000000000527331247165427200166140ustar00rootroot00000000000000(* * Copyright (c) 2013-2015 David Sheets * * 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. * *) (** A library for manipulation of IP address representations. *) (** Raised when parsing of IP address syntax fails. *) exception Parse_error of string * string with sexp (** Type of ordered address scope classifications *) type scope = | Point | Interface | Link | Admin | Site | Organization | Global with sexp (** A collection of functions for IPv4 addresses. *) module V4 : sig (** Type of the internet protocol v4 address of a host *) type t with sexp val compare : t -> t -> int (** Converts the low bytes of four int values into an abstract {! V4.t }. *) val make : int -> int -> int -> int -> t (** {3 Text string conversion} *) (** [of_string_exn ipv4_string] is the address represented by [ipv4_string]. Raises [Parse_error] if [ipv4_string] is not a valid representation of an IPv4 address. *) val of_string_exn : string -> t (** Same as [of_string_exn] but returns an option type instead of raising an exception. *) val of_string : string -> t option (** Same as [of_string_exn] but takes as an extra argument the offset into the string for reading. *) val of_string_raw : string -> int ref -> t (** [to_string ipv4] is the dotted decimal string representation of [ipv4], i.e. XXX.XX.X.XXX. *) val to_string : t -> string (** [to_buffer buf ipv4] writes the string representation of [ipv4] into the buffer [buf]. *) val to_buffer : Buffer.t -> t -> unit (** [pp_hum f ipv4] outputs a human-readable representation of [ipv4] to the formatter [f]. *) val pp_hum : Format.formatter -> t -> unit (** {3 Bytestring conversion} *) (** [of_bytes_exn ipv4_octets] is the address represented by [ipv4_octets]. Raises [Parse_error] if [ipv4_octets] is not a valid representation of an IPv4 address. *) val of_bytes_exn : string -> t (** Same as [of_bytes_exn] but returns an option type instead of raising an exception. *) val of_bytes : string -> t option (** Same as [of_bytes_exn] but take an extra paramenter, the offset into the bytes for reading. *) val of_bytes_raw : string -> int -> t (** [to_bytes ipv4] is a string of length 4 encoding [ipv4]. *) val to_bytes : t -> string (** [to_bytes_raw ipv4 bytes offset] writes the 4 byte encoding of [ipv4] into [bytes] at offset [offset]. *) val to_bytes_raw : t -> Bytes.t -> int -> unit (** {3 Int conversion} *) (** [of_int32 ipv4_packed] is the address represented by [ipv4_packed]. *) val of_int32 : int32 -> t (** [to_int32 ipv4] is the 32-bit packed encoding of [ipv4]. *) val to_int32 : t -> int32 (** [of_int16 ipv4_packed] is the address represented by [ipv4_packed]. *) val of_int16 : (int * int) -> t (** [to_int16 ipv4] is the 16-bit packed encoding of [ipv4]. *) val to_int16 : t -> int * int (** {3 MAC conversion} *) (** [multicast_to_mac ipv4] is the MAC address corresponding to the multicast address [ipv4]. Described by {{:http://tools.ietf.org/html/rfc1112#section-6.2}RFC 1112}. *) val multicast_to_mac : t -> Macaddr.t (** {3 Host conversion} *) (** [to_domain_name ipv4] is the domain name label list for reverse lookups of [ipv4]. This includes the [.in-addr.arpa.] suffix. *) val to_domain_name : t -> string list (** {3 Common addresses} *) (** [any] is 0.0.0.0. *) val any : t (** [unspecified] is 0.0.0.0. *) val unspecified : t (** [broadcast] is 255.255.255.255. *) val broadcast : t (** [nodes] is 224.0.0.1. *) val nodes : t (** [routers] is 224.0.0.2. *) val routers : t (** [localhost] is 127.0.0.1. *) val localhost : t (** A module for manipulating IPv4 network prefixes. *) module Prefix : sig type addr = t with sexp (** Type of a internet protocol subnet *) type t with sexp val compare : t -> t -> int (** [mask n] is the pseudo-address of an [n] bit subnet mask. *) val mask : int -> addr (** [make n addr] is the [n] bit subnet prefix to which [addr] belongs. *) val make : int -> addr -> t (** [network_address prefix addr] is the address with prefix [prefix] and suffix from [addr]. See . *) val network_address : t -> addr -> addr (** [of_string_exn cidr] is the subnet prefix represented by the CIDR string, [cidr]. Raises [Parse_error] if [cidr] is not a valid representation of a CIDR notation routing prefix. *) val of_string_exn : string -> t (** Same as [of_string_exn] but returns an option type instead of raising an exception. *) val of_string : string -> t option (** Same as [of_string_exn] but takes as an extra argument the offset into the string for reading. *) val of_string_raw : string -> int ref -> t (** [to_string prefix] is the CIDR notation string representation of [prefix], i.e. XXX.XX.X.XXX/XX. *) val to_string : t -> string (** [pp_hum f prefix] outputs a human-readable representation of [prefix] to the formatter [f]. *) val pp_hum : Format.formatter -> t -> unit (** [of_address_string_exn cidr_addr] is the address and prefix represented by [cidr_addr]. Raises [Parse_error] if [cidr_addr] is not a valid representation of a CIDR-scoped address. *) val of_address_string_exn : string -> t * addr (** Same as [of_address_string_exn] but returns an option type instead of raising an exception. *) val of_address_string : string -> (t * addr) option (** [to_address_string prefix addr] is the network address constructed from [prefix] and [addr]. *) val to_address_string : t -> addr -> string (** [to_buffer buf prefix] writes the string representation of [prefix] into the buffer [buf]. *) val to_buffer : Buffer.t -> t -> unit (** [to_address_buffer buf prefix addr] writes string representation of the network address representing [addr] in [prefix] to the buffer [buf]. *) val to_address_buffer : Buffer.t -> t -> addr -> unit (** [of_netmask netmask addr] is the subnet prefix of [addr] with netmask [netmask]. *) val of_netmask : addr -> addr -> t (** [mem ip subnet] checks whether [ip] is found within [subnet]. *) val mem : addr -> t -> bool (** [of_addr ip] create a subnet composed of only one address, [ip]. It is the same as [make 32 ip]. *) val of_addr : addr -> t (** The default route, all addresses in IPv4-space, 0.0.0.0/0. *) val global : t (** The host loopback network, 127.0.0.0/8. *) val loopback : t (** The local-link network, 169.254.0.0/16. *) val link : t (** The relative addressing network, 0.0.0.0/8. *) val relative : t (** The multicast network, 224.0.0.0/4. *) val multicast : t (** The private subnet with 10 as first octet, 10.0.0.0/8. *) val private_10 : t (** The private subnet with 172 as first octet, 172.16.0.0/12. *) val private_172 : t (** The private subnet with 192 as first octet, 192.168.0.0/16. *) val private_192 : t (** The privately addressable networks: [loopback], [link], [private_10], [private_172], [private_192]. *) val private_blocks : t list (** [broadcast subnet] is the broadcast address for [subnet]. *) val broadcast : t -> addr (** [network subnet] is the address for [subnet]. *) val network : t -> addr (** [netmask subnet] is the netmask for [subnet]. *) val netmask : t -> addr (** [bits subnet] is the bit size of the [subnet] prefix. *) val bits : t -> int include Map.OrderedType with type t := t end (** [scope ipv4] is the classification of [ipv4] by the {! scope } hierarchy. *) val scope : t -> scope (** [is_global ipv4] is a predicate indicating whether [ipv4] globally addresses a node. *) val is_global : t -> bool (** [is_multicast ipv4] is a predicate indicating whether [ipv4] is a multicast address. *) val is_multicast : t -> bool (** [is_private ipv4] is a predicate indicating whether [ipv4] privately addresses a node. *) val is_private : t -> bool include Map.OrderedType with type t := t end (** A collection of functions for IPv6 addresses. *) module V6 : sig (** Type of the internet protocol v6 address of a host *) type t with sexp val compare : t -> t -> int (** Converts the low bytes of eight int values into an abstract {! V6.t }. *) val make : int -> int -> int -> int -> int -> int -> int -> int -> t (** {3 Text string conversion} *) (** [of_string_exn ipv6_string] is the address represented by [ipv6_string]. Raises [Parse_error] if [ipv6_string] is not a valid representation of an IPv6 address. *) val of_string_exn : string -> t (** Same as [of_string_exn] but returns an option type instead of raising an exception. *) val of_string : string -> t option (** Same as [of_string_exn] but takes as an extra argument the offset into the string for reading. *) val of_string_raw : string -> int ref -> t (** [to_string ipv6] is the string representation of [ipv6], i.e. XXX:XX:X::XXX:XX. *) val to_string : ?v4:bool -> t -> string (** [to_buffer buf ipv6] writes the string representation of [ipv6] into the buffer [buf]. *) val to_buffer : ?v4:bool -> Buffer.t -> t -> unit (** [pp_hum f ipv6] outputs a human-readable representation of [ipv6] to the formatter [f]. *) val pp_hum : Format.formatter -> t -> unit (** {3 Bytestring conversion} *) (** [of_bytes_exn ipv6_octets] is the address represented by [ipv6_octets]. Raises [Parse_error] if [ipv6_octets] is not a valid representation of an IPv6 address. *) val of_bytes_exn : string -> t (** Same as [of_bytes_exn] but returns an option type instead of raising an exception. *) val of_bytes : string -> t option (** Same as [of_bytes_exn] but takes an extra paramenter, the offset into the bytes for reading. *) val of_bytes_raw : string -> int -> t (** [to_bytes ipv6] is a string of length 16 encoding [ipv6]. *) val to_bytes : t -> string (** [to_bytes_raw ipv6 bytes offset] writes the 16 bytes encoding of [ipv6] into [bytes] at offset [offset]. *) val to_bytes_raw : t -> Bytes.t -> int -> unit (** {3 Int conversion} *) (** [of_int64 (ho, lo)] is the IPv6 address represented by two int64. *) val of_int64 : int64 * int64 -> t (** [to_int64 ipv6] is the 128-bit packed encoding of [ipv6]. *) val to_int64 : t -> int64 * int64 (** [of_int32 (a, b, c, d)] is the IPv6 address represented by four int32. *) val of_int32 : int32 * int32 * int32 * int32 -> t (** [to_int32 ipv6] is the 128-bit packed encoding of [ipv6]. *) val to_int32 : t -> int32 * int32 * int32 * int32 (** [of_int16 (a, b, c, d, e, f, g, h)] is the IPv6 address represented by eight 16-bit int. *) val of_int16 : int * int * int * int * int * int * int * int -> t (** [to_int16 ipv6] is the 128-bit packed encoding of [ipv6]. *) val to_int16 : t -> int * int * int * int * int * int * int * int (** {3 MAC conversion} *) (** [multicast_to_mac ipv6] is the MAC address corresponding to the multicast address [ipv6]. Described by {{:https://tools.ietf.org/html/rfc2464#section-7}RFC 2464}. *) val multicast_to_mac : t -> Macaddr.t (** {3 Host conversion} *) (** [to_domain_name ipv6] is the domain name label list for reverse lookups of [ipv6]. This includes the [.ip6.arpa.] suffix. *) val to_domain_name : t -> string list (** {3 Common addresses} *) (** [unspecified] is ::. *) val unspecified : t (** [localhost] is ::1. *) val localhost : t (** [interface_nodes] is ff01::01. *) val interface_nodes : t (** [link_nodes] is ff02::01. *) val link_nodes : t (** [interface_routers] is ff01::02. *) val interface_routers : t (** [link_routers] is ff02::02. *) val link_routers : t (** [site_routers] is ff05::02. *) val site_routers : t (** A module for manipulating IPv6 network prefixes. *) module Prefix : sig type addr = t with sexp (** Type of a internet protocol subnet *) type t with sexp val compare : t -> t -> int (** [mask n] is the pseudo-address of an [n] bit subnet mask. *) val mask : int -> addr (** [make n addr] is the [n] bit subnet prefix to which [addr] belongs. *) val make : int -> addr -> t (** [network_address prefix addr] is the address with prefix [prefix] and suffix from [addr]. See . *) val network_address : t -> addr -> addr (** [of_string_exn cidr] is the subnet prefix represented by the CIDR string, [cidr]. Raises [Parse_error] if [cidr] is not a valid representation of a CIDR notation routing prefix. *) val of_string_exn : string -> t (** Same as [of_string_exn] but returns an option type instead of raising an exception. *) val of_string : string -> t option (** Same as [of_string_exn] but takes as an extra argument the offset into the string for reading. *) val of_string_raw : string -> int ref -> t (** [to_string prefix] is the CIDR notation string representation of [prefix], i.e. XXX:XX:X::XXX/XX. *) val to_string : t -> string (** [pp_hum f prefix] outputs a human-readable representation of [prefix] to the formatter [f]. *) val pp_hum : Format.formatter -> t -> unit (** [of_address_string_exn cidr_addr] is the address and prefix represented by [cidr_addr]. Raises [Parse_error] if [cidr_addr] is not a valid representation of a CIDR-scoped address. *) val of_address_string_exn : string -> t * addr (** Same as [of_address_string_exn] but returns an option type instead of raising an exception. *) val of_address_string : string -> (t * addr) option (** [to_address_string prefix addr] is the network address constructed from [prefix] and [addr]. *) val to_address_string : t -> addr -> string (** [to_buffer buf prefix] writes the string representation of [prefix] to the buffer [buf]. *) val to_buffer : Buffer.t -> t -> unit (** [to_address_buffer buf prefix addr] writes string representation of the network address representing [addr] in [prefix] to the buffer [buf]. *) val to_address_buffer : Buffer.t -> t -> addr -> unit (** [of_netmask netmask addr] is the subnet prefix of [addr] with netmask [netmask]. *) val of_netmask : addr -> addr -> t (** [mem ip subnet] checks whether [ip] is found within [subnet]. *) val mem : addr -> t -> bool (** [of_addr ip] create a subnet composed of only one address, [ip]. It is the same as [make 128 ip]. *) val of_addr : addr -> t (** Global Unicast 001, 2000::/3. *) val global_unicast_001 : t (** The Unique Local Unicast (ULA), fc00::/7. *) val unique_local : t (** Link-Local Unicast, fe80::/64. *) val link : t (** The multicast network, ff00::/8. *) val multicast : t (** IPv4-mapped addresses, ::ffff:0:0/96. *) val ipv4_mapped : t (** Global Unicast addresses that don't use Modified EUI64 interface identifiers, ::/3. *) val noneui64_interface : t (** Solicited-Node multicast addresses *) val solicited_node : t (** [network subnet] is the address for [subnet]. *) val network : t -> addr (** [netmask subnet] is the netmask for [subnet]. *) val netmask : t -> addr (** [bits subnet] is the bit size of the [subnet] prefix. *) val bits : t -> int include Map.OrderedType with type t := t end (** [scope ipv6] is the classification of [ipv6] by the {! scope } hierarchy. *) val scope : t -> scope (** [link_address_of_mac mac] is the link-local address for an Ethernet interface derived by the IEEE MAC -> EUI-64 map with the Universal/Local bit complemented for IPv6. @see RFC 2464 *) val link_address_of_mac : Macaddr.t -> t (** [is_global ipv6] is a predicate indicating whether [ipv6] globally addresses a node. *) val is_global : t -> bool (** [is_multicast ipv6] is a predicate indicating whether [ipv6] is a multicast address. *) val is_multicast : t -> bool (** [is_private ipv6] is a predicate indicating whether [ipv6] privately addresses a node. *) val is_private : t -> bool include Map.OrderedType with type t := t end (** Type of either an IPv4 value or an IPv6 value *) type ('v4,'v6) v4v6 = V4 of 'v4 | V6 of 'v6 with sexp (** Type of any IP address *) type t = (V4.t,V6.t) v4v6 with sexp val compare : t -> t -> int (** [to_string addr] is the text string representation of [addr]. *) val to_string : t -> string (** [to_buffer buf addr] writes the text string representation of [addr] into [buf]. *) val to_buffer : Buffer.t -> t -> unit (** [pp_hum f ip] outputs a human-readable representation of [ip] to the formatter [f]. *) val pp_hum : Format.formatter -> t -> unit (** [of_string_exn s] parses [s] as an IPv4 or IPv6 address. Raises [Parse_error] if [s] is not a valid string representation of an IP address. *) val of_string_exn : string -> t (** Same as [of_string_exn] but returns an option type instead of raising an exception. *) val of_string : string -> t option (** Same as [of_string_exn] but takes as an extra argument the offset into the string for reading. *) val of_string_raw : string -> int ref -> t (** [v4_of_v6 ipv6] is the IPv4 representation of the IPv6 address [ipv6]. If [ipv6] is not an IPv4-mapped address, None is returned. *) val v4_of_v6 : V6.t -> V4.t option (** [to_v4 addr] is the IPv4 representation of [addr]. *) val to_v4 : t -> V4.t option (** [v6_of_v4 ipv4] is the IPv6 representation of the IPv4 address [ipv4]. *) val v6_of_v4 : V4.t -> V6.t (** [to_v6 addr] is the IPv6 representation of [addr]. *) val to_v6 : t -> V6.t (** [scope addr] is the classification of [addr] by the {! scope } hierarchy. *) val scope : t -> scope (** [is_global addr] is a predicate indicating whether [addr] globally addresses a node. *) val is_global : t -> bool (** [is_multicast addr] is a predicate indicating whether [addr] is a multicast address. *) val is_multicast : t -> bool (** [is_private addr] is a predicate indicating whether [addr] privately addresses a node. *) val is_private : t -> bool (** [multicast_to_mac addr] is the MAC address corresponding to the multicast address [addr]. See {!V4.multicast_to_mac} and {!V6.multicast_to_mac}.*) val multicast_to_mac : t -> Macaddr.t (** [to_domain_name addr] is the domain name label list for reverse lookups of [addr]. This includes the [.arpa.] suffix. *) val to_domain_name : t -> string list module Prefix : sig type addr = t with sexp (** Type of a internet protocol subnet *) type t = (V4.Prefix.t, V6.Prefix.t) v4v6 with sexp val compare : t -> t -> int (** [to_string subnet] is the text string representation of [subnet]. *) val to_string : t -> string (** [to_buffer buf subnet] writes the text string representation of [subnet] into [buf]. *) val to_buffer : Buffer.t -> t -> unit (** [pp_hum f subnet] outputs a human-readable representation of [subnet] to the formatter [f]. *) val pp_hum : Format.formatter -> t -> unit (** [of_string_exn cidr] is the subnet prefix represented by the CIDR string, [cidr]. Raises [Parse_error] if [cidr] is not a valid representation of a CIDR notation routing prefix. *) val of_string_exn : string -> t (** Same as [of_string_exn] but returns an option type instead of raising an exception. *) val of_string : string -> t option (** Same as [of_string_exn] but takes as an extra argument the offset into the string for reading. *) val of_string_raw : string -> int ref -> t (** [v4_of_v6 ipv6] is the IPv4 representation of the IPv6 subnet [ipv6]. If [ipv6] is not an IPv4-mapped subnet, None is returned. *) val v4_of_v6 : V6.Prefix.t -> V4.Prefix.t option (** [to_v4 subnet] is the IPv4 representation of [subnet]. *) val to_v4 : t -> V4.Prefix.t option (** [v6_of_v4 ipv4] is the IPv6 representation of the IPv4 subnet [ipv4]. *) val v6_of_v4 : V4.Prefix.t -> V6.Prefix.t (** [to_v6 subnet] is the IPv6 representation of [subnet]. *) val to_v6 : t -> V6.Prefix.t (** [mem ip subnet] checks whether [ip] is found within [subnet]. *) val mem : addr -> t -> bool (** [of_addr ip] create a subnet composed of only one address, [ip].*) val of_addr : addr -> t (** [network subnet] is the address for [subnet]. *) val network : t -> addr (** [netmask subnet] is the netmask for [subnet]. *) val netmask : t -> addr include Map.OrderedType with type t := t end include Map.OrderedType with type t := t ocaml-ipaddr-2.6.1/lib/ipaddr.mllib000066400000000000000000000001431247165427200171160ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: d87e9ce6150361cb3829c7282ce6c915) Ipaddr Macaddr # OASIS_STOP ocaml-ipaddr-2.6.1/lib/ipaddr_unix.ml000066400000000000000000000026731247165427200175040ustar00rootroot00000000000000(* * Copyright (c) 2014 Anil Madhavapeddy * * 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_inet_addr t = Unix.inet_addr_of_string (Ipaddr.to_string t) let of_inet_addr t = Ipaddr.of_string_exn (Unix.string_of_inet_addr t) module V4 = struct let to_inet_addr t = Unix.inet_addr_of_string (Ipaddr.V4.to_string t) let of_inet_addr_exn t = Ipaddr.V4.of_string_exn (Unix.string_of_inet_addr t) let of_inet_addr t = try Some (of_inet_addr_exn t) with _ -> None end module V6 = struct let to_inet_addr t = Unix.inet_addr_of_string (Ipaddr.V6.to_string t) let of_inet_addr_exn t = Ipaddr.V6.of_string_exn (Unix.string_of_inet_addr t) let of_inet_addr t = try Some (of_inet_addr_exn t) with _ -> None end ocaml-ipaddr-2.6.1/lib/ipaddr_unix.mldylib000066400000000000000000000001401247165427200205130ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: ee982b4e45569cc57d5ac614e4a92b5b) Ipaddr_unix # OASIS_STOP ocaml-ipaddr-2.6.1/lib/ipaddr_unix.mli000066400000000000000000000044331247165427200176510ustar00rootroot00000000000000(* * Copyright (c) 2014 Anil Madhavapeddy * * 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. * *) (** Convert to and from [Unix] to [Ipaddr] representations *) (** [to_inet_addr ip] is the {! Unix.inet_addr} equivalent of the IPv4 or IPv6 address [ip]. *) val to_inet_addr : Ipaddr.t -> Unix.inet_addr (** [of_inet_addr ip] is the {! Ipaddr.t} equivalent of the {! Unix.inet_addr} [ip]. *) val of_inet_addr : Unix.inet_addr -> Ipaddr.t module V4 : sig (** [to_inet_addr ip] is the {! Unix.inet_addr} equivalent of the IPv4 address [ip]. *) val to_inet_addr : Ipaddr.V4.t -> Unix.inet_addr (** [of_inet_addr_exn ip] is the {! Ipaddr.t} equivalent of the {!Unix.inet_addr} [ip] IPv4 address. Raises {! Ipaddr.Parse_error} if [ip] is not a valid representation of an IPv4 address. *) val of_inet_addr_exn : Unix.inet_addr -> Ipaddr.V4.t (** Same as [of_inet_addr_exn] but returns an option type instead of raising an exception. *) val of_inet_addr : Unix.inet_addr -> Ipaddr.V4.t option end module V6 : sig (** [to_inet_addr ip] is the {! Unix.inet_addr} equivalent of the IPv6 address [ip]. *) val to_inet_addr : Ipaddr.V6.t -> Unix.inet_addr (** [of_inet_addr_exn ip] is the {! Ipaddr.t} equivalent of the {!Unix.inet_addr} [ip] IPv6 address. Raises {! Ipaddr.Parse_error} if [ip] is not a valid representation of an IPv6 address. *) val of_inet_addr_exn : Unix.inet_addr -> Ipaddr.V6.t (** Same as [of_inet_addr_exn] but returns an option type instead of raising an exception. *) val of_inet_addr : Unix.inet_addr -> Ipaddr.V6.t option end ocaml-ipaddr-2.6.1/lib/ipaddr_unix.mllib000066400000000000000000000001401247165427200201560ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: ee982b4e45569cc57d5ac614e4a92b5b) Ipaddr_unix # OASIS_STOP ocaml-ipaddr-2.6.1/lib/macaddr.ml000066400000000000000000000075451247165427200165740ustar00rootroot00000000000000(* * Copyright (c) 2010 Anil Madhavapeddy * Copyright (c) 2014 David Sheets * * 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.Std exception Parse_error of string * string with sexp let need_more x = Parse_error ("not enough data", x) type t = Bytes.t (* length 6 only *) let compare = Bytes.compare (* Raw MAC address off the wire (network endian) *) let of_bytes_exn x = if String.length x <> 6 then raise (Parse_error ("MAC is exactly 6 bytes", x)) else Bytes.of_string x let of_bytes x = try Some (of_bytes_exn x) with _ -> None let int_of_hex_char c = let c = int_of_char (Char.uppercase c) - 48 in if c > 9 then if c > 16 then c - 7 (* upper hex offset *) else -1 (* :;<=>?@ *) else c let is_hex i = i >=0 && i < 16 let bad_char i s = let msg = Printf.sprintf "invalid character '%c' at %d" s.[i] i in Parse_error (msg, s) let parse_hex_int term s i = let len = String.length s in let rec hex prev = let j = !i in if j >= len then prev else let c = s.[j] in let k = int_of_hex_char c in if is_hex k then (incr i; hex ((prev lsl 4) + k)) else if List.mem c term then prev else raise (bad_char j s) in let i = !i in if i < len then if is_hex (int_of_hex_char s.[i]) then hex 0 else raise (bad_char i s) else raise (need_more s) let parse_sextuple s i = let m = Bytes.create 6 in try let p = !i in Bytes.set m 0 (Char.chr (parse_hex_int [':';'-'] s i)); if !i >= String.length s then raise (need_more s) else let sep = [s.[!i]] in (if !i - p <> 2 then raise (Parse_error ("hex pairs required",s))); incr i; for k=1 to 4 do let p = !i in Bytes.set m k (Char.chr (parse_hex_int sep s i)); (if !i - p <> 2 then raise (Parse_error ("hex pairs required",s))); incr i; done; let p = !i in Bytes.set m 5 (Char.chr (parse_hex_int [] s i)); (if !i - p <> 2 then raise (Parse_error ("hex pairs required",s))); m with Invalid_argument "Char.chr" -> raise (Parse_error ("address segment too large",s)) (* Read a MAC address colon-separated string *) let of_string_exn x = parse_sextuple x (ref 0) let of_string x = try Some (of_string_exn x) with _ -> None let chri x i = Char.code (Bytes.get x i) let to_string ?(sep=':') x = Printf.sprintf "%02x%c%02x%c%02x%c%02x%c%02x%c%02x" (chri x 0) sep (chri x 1) sep (chri x 2) sep (chri x 3) sep (chri x 4) sep (chri x 5) let to_bytes x = Bytes.to_string x let sexp_of_t m = Sexplib.Sexp.Atom (to_string m) let t_of_sexp m = match m with | Sexplib.Sexp.Atom m -> of_string_exn m | _ -> raise (Failure "Macaddr.t: Unexpected non-atom in sexp") let broadcast = Bytes.make 6 '\255' let make_local bytegenf = let x = Bytes.create 6 in (* set locally administered and unicast bits *) Bytes.set x 0 (Char.chr ((((bytegenf 0) lor 2) lsr 1) lsl 1)); for i = 1 to 5 do Bytes.set x i (Char.chr (bytegenf i)) done; x let get_oui x = ((chri x 0) lsl 16) lor ((chri x 1) lsl 8) lor (chri x 2) let is_local x = (((chri x 0) lsr 1) land 1) = 1 let is_unicast x = ((chri x 0) land 1) = 0 ocaml-ipaddr-2.6.1/lib/macaddr.mli000066400000000000000000000051411247165427200167330ustar00rootroot00000000000000(* * Copyright (c) 2010-2011 Anil Madhavapeddy * * 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. *) (** A library for manipulation of MAC address representations. *) (** Raised when parsing of MAC address syntax fails. *) exception Parse_error of string * string with sexp (** Type of the hardware address (MAC) of an ethernet interface. *) type t with sexp val compare : t -> t -> int (** Functions converting MAC addresses to bytes/string and vice versa. *) (** [of_bytes_exn buf] is the hardware address extracted from [buf]. Raises [Parse_error] if [buf] has not length 6. *) val of_bytes_exn : string -> t (** Same as above but returns an option type instead of raising an exception. *) val of_bytes : string -> t option (** [of_string_exn mac_string] is the hardware address represented by [mac_string]. Raises [Parse_error] if [mac_string] is not a valid representation of a MAC address. *) val of_string_exn : string -> t (** Same as above but returns an option type instead of raising an exception. *) val of_string : string -> t option (** [to_bytes mac_addr] is a string of size 6 encoding [mac_addr]. *) val to_bytes : t -> string (** [to_string ?(sep=':') mac_addr] is the [sep]-separated string representation of [mac_addr], i.e. xx:xx:xx:xx:xx:xx. *) val to_string : ?sep:char -> t -> string (** [broadcast] is ff:ff:ff:ff:ff:ff. *) val broadcast : t (** [make_local bytegen] creates a unicast, locally administered MAC address given a function mapping octet offset to octet value. *) val make_local : (int -> int) -> t (** [get_oui macaddr] is the integer organization identifier for [macaddr]. *) val get_oui : t -> int (** [is_local macaddr] is the predicate on the locally administered bit of [macaddr]. *) val is_local : t -> bool (** [is_unicast macaddr] the is the predicate on the unicast bit of [macaddr]. *) val is_unicast : t -> bool include Map.OrderedType with type t := t ocaml-ipaddr-2.6.1/lib_test/000077500000000000000000000000001247165427200156735ustar00rootroot00000000000000ocaml-ipaddr-2.6.1/lib_test/Makefile000066400000000000000000000015761247165427200173440ustar00rootroot00000000000000.PHONY: all clean OCAML_VERSION=$(shell ocaml -version | sed -n "s/.*version \(.*\)$$/\1/p") ifneq (,$(findstring 3.12.,$(OCAML_VERSION))) SAFE_STRING= else ifneq (,$(findstring 4.00.,$(OCAML_VERSION))) SAFE_STRING= else ifneq (,$(findstring 4.01.,$(OCAML_VERSION))) SAFE_STRING= else SAFE_STRING=-safe-string endif FLAGS=-package oUnit,sexplib,bytes -g $(SAFE_STRING) -principal all: test_ipaddr.ml test_macaddr.ml @echo Detected OCaml $(OCAML_VERSION) ocamlfind ocamlc -o test_ipaddr $(FLAGS) -I ../_build/lib \ ../_build/lib/macaddr.cmo ../_build/lib/ipaddr.cmo \ -linkpkg test_ipaddr.ml ocamlfind ocamlc -o test_macaddr $(FLAGS) -I ../_build/lib \ ../_build/lib/macaddr.cmo -linkpkg test_macaddr.ml ./test_ipaddr @echo ./test_macaddr @echo $(MAKE) clean clean: rm -f test_ipaddr.cmi test_ipaddr.cmo test_ipaddr rm -f test_macaddr.cmi test_macaddr.cmo test_macaddr ocaml-ipaddr-2.6.1/lib_test/test_ipaddr.ml000066400000000000000000000677131247165427200205450ustar00rootroot00000000000000(* * Copyright (c) 2013-2014 David Sheets * * 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 OUnit open Ipaddr let error s msg = s, Parse_error (msg,s) let need_more s = error s "not enough data" let too_much s = error s "too much data" let bad_char i s = error s (Printf.sprintf "invalid character '%c' at %d" s.[i] i) let assert_raises ~msg exn test_fn = assert_raises ~msg exn (fun () -> try test_fn () with rtexn -> begin (if exn <> rtexn then ( Printf.eprintf "Stacktrace for '%s':\n%!" msg; Printexc.print_backtrace stderr; )); raise rtexn end) module Test_v4 = struct let test_string_rt () = let addrs = [ "192.168.0.1", "192.168.0.1"; ] in List.iter (fun (addr,rt) -> let os = V4.of_string_exn addr in let ts = V4.to_string os in assert_equal ~msg:addr ts rt; let os = V4.t_of_sexp (V4.sexp_of_t os) in let ts = V4.to_string os in assert_equal ~msg:addr ts rt; ) addrs let test_string_rt_bad () = let addrs = [ need_more "192.168.0"; bad_char 11 "192.168.0.1.1"; error "192.268.2.1" "second octet out of bounds"; bad_char 4 "192. 168.1.1"; bad_char 4 "192..0.1"; bad_char 3 "192,168.0.1"; ] in List.iter (fun (addr,exn) -> assert_raises ~msg:addr exn (fun () -> V4.of_string_exn addr) ) addrs let test_string_raw_rt () = let addrs = [ ("IP: 192.168.0.1!!!",4), ("192.168.0.1",15); ("IP: 192.168.0.1.1!!!",4), ("192.168.0.1",15); ] in List.iter (fun ((addr,off),result) -> let c = ref off in let os = V4.of_string_raw addr c in let ts = V4.to_string os in assert_equal ~msg:addr (ts,!c) result ) addrs let test_string_raw_rt_bad () = let addrs = [ (let s = "IP: 192.168.0!!!" in (s,4), (Parse_error ("invalid character '!' at 13",s), 13)); ] in List.iter (fun ((addr,off),(exn,cursor)) -> let c = ref off in assert_raises ~msg:addr exn (fun () -> V4.of_string_raw addr c); assert_equal ~msg:(Printf.sprintf "%s cursor <> %d (%d)" addr cursor !c) !c cursor ) addrs let test_bytes_rt () = let addr = "\254\099\003\128" in assert_equal ~msg:(String.escaped addr) V4.(to_bytes (of_bytes_exn addr)) addr let test_bytes_rt_bad () = let addrs = [ need_more "\254\099\003"; too_much "\254\099\003\128\001"; ] in List.iter (fun (addr,exn) -> assert_raises ~msg:(String.escaped addr) exn (fun () -> V4.of_bytes_exn addr) ) addrs let test_int32_rt () = let addr = 0x0_F0_AB_00_01_l in assert_equal ~msg:(Printf.sprintf "%08lX" addr) V4.(to_int32 (of_int32 addr)) addr let test_prefix_string_rt () = let subnets = [ "192.168.0.0/24", "192.168.0.0/24"; "0.0.0.0/0", "0.0.0.0/0"; "192.168.0.1/24", "192.168.0.0/24"; "192.168.0.0/0", "0.0.0.0/0"; ] in List.iter (fun (subnet,rt) -> let os = V4.Prefix.of_string_exn subnet in let ts = V4.Prefix.to_string os in assert_equal ~msg:subnet ts rt; let os = V4.Prefix.(t_of_sexp (sexp_of_t os)) in let ts = V4.Prefix.to_string os in assert_equal ~msg:subnet ts rt; ) subnets let test_prefix_string_rt_bad () = let subnets = [ bad_char 9 "192.168.0/24"; bad_char 10 "192.168.0./24"; error "192.168.0.0/33" "invalid prefix size"; bad_char 14 "192.168.0.0/30/1"; bad_char 12 "192.168.0.0/-1"; ] in List.iter (fun (subnet,exn) -> assert_raises ~msg:subnet exn (fun () -> V4.Prefix.of_string_exn subnet) ) subnets let test_network_address_rt () = let netaddrs = [ "192.168.0.1/24", "192.168.0.0/24", "192.168.0.1"; ] in List.iter (fun (netaddr,net,addr) -> let netv4 = V4.Prefix.of_string_exn net in let addrv4 = V4.of_string_exn addr in let prefix,v4 = V4.Prefix.of_address_string_exn netaddr in assert_equal ~msg:(net^" <> "^(V4.Prefix.to_string prefix)) netv4 prefix; assert_equal ~msg:(addr^" <> "^(V4.to_string v4)) addrv4 v4; let addrstr = V4.Prefix.to_address_string prefix v4 in assert_equal ~msg:(netaddr^" <> "^addrstr) netaddr addrstr; ) netaddrs let test_prefix_broadcast () = let pairs = [ "192.168.0.0/16", "192.168.255.255"; "192.168.0.0/24", "192.168.0.255"; "192.168.1.1/24", "192.168.1.255"; "192.168.0.128/29", "192.168.0.135"; "0.0.0.0/0", "255.255.255.255"; ] in List.iter (fun (subnet,bcast) -> let r = V4.(to_string (Prefix.(broadcast (of_string_exn subnet)))) in assert_equal ~msg:(subnet ^ " <> " ^ r) r bcast ) pairs let test_prefix_bits () = let pairs = V4.Prefix.([ global, 0; loopback, 8; link, 16; relative, 8; multicast, 4; private_10, 8; private_172, 12; private_192, 16; ]) in List.iter (fun (subnet,bits) -> let msg = (V4.Prefix.to_string subnet) ^ " <> " ^ (string_of_int bits) in assert_equal ~msg (V4.Prefix.bits subnet) bits ) pairs let test_prefix_netmask () = let nets = [ "192.168.0.1/32","255.255.255.255"; "192.168.0.1/31","255.255.255.254"; "192.168.0.1/1", "128.0.0.0"; "192.168.0.1/0", "0.0.0.0"; ] in List.iter (fun (net_str,nm_str) -> let prefix, v4 = V4.Prefix.of_address_string_exn net_str in let nm = V4.Prefix.netmask prefix in let nnm_str = V4.to_string nm in let msg = Printf.sprintf "netmask %s <> %s" nnm_str nm_str in assert_equal ~msg nnm_str nm_str; let prefix = V4.Prefix.of_netmask nm v4 in let nns = V4.Prefix.to_address_string prefix v4 in let msg = Printf.sprintf "%s is %s under netmask iso" net_str nns in assert_equal ~msg net_str nns ) nets let test_prefix_netmask_bad () = let bad_masks = [ error "127.255.255.255" "invalid netmask"; error "255.255.254.128" "invalid netmask"; ] in List.iter (fun (nm_str,exn) -> let nm = V4.of_string_exn nm_str in let addr = V4.of_string_exn "192.168.0.1" in assert_raises ~msg:nm_str exn (fun () -> V4.Prefix.of_netmask nm addr) ) bad_masks let test_scope () = let ip = V4.of_string_exn in (*let is subnet addr = V4.Prefix.(mem addr subnet) in*) let is_scope scop addr = scop = V4.scope addr in let ships = V4.([ unspecified, "global", is_global, false; unspecified, "multicast", is_multicast, false; unspecified, "point", is_scope Point, true; localhost, "global", is_global, false; localhost, "multicast", is_multicast, false; localhost, "interface", is_scope Interface, true; broadcast, "global", is_global, false; broadcast, "multicast", is_multicast, false; broadcast, "admin", is_scope Admin, true; nodes, "global", is_global, false; nodes, "multicast", is_multicast, true; nodes, "interface", is_scope Link, true; routers, "global", is_global, false; routers, "multicast", is_multicast, true; routers, "link", is_scope Link, true; ip "192.168.0.1", "private", is_private, true; ip "10.3.21.155", "private", is_private, true; ip "172.16.0.0", "private", is_private, true; ip "172.31.255.255", "private", is_private, true; ip "172.15.255.255", "private", is_private, false; ip "172.32.0.0", "private", is_private, false; ]) in List.iter (fun (addr,lbl,pred,is_mem) -> let mems = if is_mem then "" else " not" in let msg = (V4.to_string addr)^" is"^mems^" in "^lbl in assert_equal ~msg (pred addr) is_mem ) ships let test_map () = let module M = Map.Make(V4) in let m = M.add (V4.of_string_exn "1.0.0.1") "min" M.empty in let m = M.add (V4.of_string_exn "254.254.254.254") "the greatest host" m in let m = M.add (V4.of_string_exn "1.0.0.1") "the least host" m in assert_equal ~msg:"size" (M.cardinal m) 2; let (min_key, min_val) = M.min_binding m in assert_equal ~msg:("min is '" ^ min_val ^"'") (min_key, min_val) (V4.of_string_exn "1.0.0.1", "the least host"); assert_equal ~msg:"max" (M.max_binding m) (V4.of_string_exn "254.254.254.254", "the greatest host") let test_prefix_map () = let module M = Map.Make(V4.Prefix) in let m = M.add (V4.Prefix.of_string_exn "0.0.0.0/0") "everyone" M.empty in let m = M.add (V4.Prefix.of_string_exn "192.0.0.0/1") "weirdos" m in let m = M.add (V4.Prefix.of_string_exn "128.0.0.0/1") "high-bitters" m in let m = M.add (V4.Prefix.of_string_exn "254.0.0.0/8") "top-end" m in let m = M.add (V4.Prefix.of_string_exn "0.0.0.0/0") "iana" m in assert_equal ~msg:"size" (M.cardinal m) 3; assert_equal ~msg:"min" (M.min_binding m) (V4.Prefix.of_string_exn "0.0.0.0/0", "iana"); assert_equal ~msg:"max" (M.max_binding m) (V4.Prefix.of_string_exn "254.0.0.0/8", "top-end"); assert_equal ~msg:"third" (M.find (V4.Prefix.of_string_exn "128.0.0.0/1") m) "high-bitters" let test_special_addr () = assert_equal ~msg:"broadcast" V4.broadcast V4.Prefix.(broadcast global); assert_equal ~msg:"any" V4.any V4.Prefix.(network global); assert_equal ~msg:"localhost" true V4.(Prefix.(mem localhost loopback)) let test_multicast_mac () = let ip = V4.of_bytes_exn "\xff\xbf\x9f\x8f" in let multicast = V4.Prefix.(network_address multicast ip) in let unicast_mac_str = Macaddr.to_string (V4.multicast_to_mac ip) in let multicast_mac_str = Macaddr.to_string (V4.multicast_to_mac multicast) in let mac_str = "01:00:5e:3f:9f:8f" in assert_equal ~msg:("unicast_mac "^unicast_mac_str^" <> "^mac_str) unicast_mac_str mac_str; assert_equal ~msg:("multicast_mac "^multicast_mac_str^" <> "^mac_str) multicast_mac_str mac_str let test_domain_name () = let ip = V4.of_string_exn "128.64.32.16" in let name = "16.32.64.128.in-addr.arpa." in assert_equal ~msg:"domain_name" (String.concat "." (V4.to_domain_name ip)) name let suite = "Test V4" >::: [ "string_rt" >:: test_string_rt; "string_rt_bad" >:: test_string_rt_bad; "string_raw_rt" >:: test_string_raw_rt; "string_raw_rt_bad" >:: test_string_raw_rt_bad; "bytes_rt" >:: test_bytes_rt; "bytes_rt_bad" >:: test_bytes_rt_bad; "int32_rt" >:: test_int32_rt; "prefix_string_rt" >:: test_prefix_string_rt; "prefix_string_rt_bad" >:: test_prefix_string_rt_bad; "network_address_rt" >:: test_network_address_rt; "prefix_broadcast" >:: test_prefix_broadcast; "prefix_bits" >:: test_prefix_bits; "prefix_netmask" >:: test_prefix_netmask; "prefix_netmask_bad" >:: test_prefix_netmask_bad; "scope" >:: test_scope; "map" >:: test_map; "prefix_map" >:: test_prefix_map; "special_addr" >:: test_special_addr; "multicast_mac" >:: test_multicast_mac; "domain_name" >:: test_domain_name; ] end module Test_v6 = struct let test_string_rt () = let addrs = [ "2001:db8::ff00:42:8329","2001:db8::ff00:42:8329"; "::ffff:192.168.1.1", "::ffff:192.168.1.1"; "::", "::"; "[::]", "::"; "1:1:1:1::1:1:1", "1:1:1:1:0:1:1:1"; "0:0:0:1:1:0:0:0", "::1:1:0:0:0"; "0:0:0:1:1::", "::1:1:0:0:0"; "::1:0:0:0:0", "0:0:0:1::"; "FE80::", "fe80::"; "::192.168.0.1", "::c0a8:1"; ] in List.iter (fun (addr,rt) -> let os = V6.of_string_exn addr in let ts = V6.to_string os in assert_equal ~msg:(addr^" <> "^rt^" ("^ts^")") ts rt; let os = V6.t_of_sexp (V6.sexp_of_t os) in let ts = V6.to_string os in assert_equal ~msg:(addr^" <> "^rt^" ("^ts^")") ts rt; ) addrs let test_string_rt_bad () = let addrs = [ need_more "["; need_more "[]"; (* ? *) need_more ":"; need_more "[::"; bad_char 4 "::1:g:f"; bad_char 3 "::1::"; bad_char 4 "1::2::3"; need_more "1:2:3:4:5:6:7"; bad_char 15 "1:2:3:4:5:6:7:8:9"; bad_char 15 "1:2:3:4:5:6:7:8::"; error "12345::12:2" "component 0 out of bounds"; bad_char 1 ":1"; ] in List.iter (fun (addr,exn) -> assert_raises ~msg:addr exn (fun () -> V6.of_string_exn addr) ) addrs let test_string_raw_rt () = let addrs = [ ("IP: 2001:db8::ff00:42:8329!",4), ("2001:db8::ff00:42:8329",26); ("IP: ::ffff:192.168.1.1 ",4), ("::ffff:192.168.1.1",22); ("IP: :::",4), ("::",6); ("IP: [::]:",4), ("::",8); ("IP: 1:1:1:1::1:1:1:1",4), ("1:1:1:1:0:1:1:1",18); ("IP: ::1:1:0:0:0::g",4), ("::1:1:0:0:0",15); ] in List.iter (fun ((addr,off),(result,cursor)) -> let c = ref off in let os = V6.of_string_raw addr c in let ts = V6.to_string os in let msg = Printf.sprintf "%s at %d: %s at %d <> %s at %d" addr off result cursor ts !c in assert_equal ~msg (ts,!c) (result,cursor) ) addrs let test_string_raw_rt_bad () = let error (s,c) msg c' = (s,c), (Parse_error (msg,s),c') in let need_more loc = error loc "not enough data" in let bad_char i (s,c) = error (s,c) (Printf.sprintf "invalid character '%c' at %d" s.[i] i) i in let addrs = [ need_more ("IP: [] ",4) 5; bad_char 5 ("IP: : ",4); bad_char 7 ("IP: [:: ",4); bad_char 17 ("IP: 1:2:3:4:5:6:7 ",4); error ("IP: 12345::12:2 ",4) "component 0 out of bounds" 15; bad_char 5 ("IP: :1 ",4); need_more ("IP: ::1:1:0:0:0:",4) 16; bad_char 8 ("IP: ::1:g:f ",4); ] in List.iter (fun ((addr,off),(exn,cursor)) -> let c = ref off in assert_raises ~msg:addr exn (fun () -> V6.of_string_raw addr c); assert_equal ~msg:(Printf.sprintf "%s cursor <> %d (%d)" addr cursor !c) !c cursor ) addrs let test_bytes_rt () = let addr = "\000\000\000\000\000\000\000\000\000\000\255\255\192\168\000\001" in let v6 = V6.of_bytes_exn addr in assert_equal ~msg:(String.escaped addr) V6.(to_bytes v6) addr let test_bytes_rt_bad () = let addrs = [ need_more "\000\000\000\000\000\000\000\000\000\000\255\255\192\168\001"; too_much "\000\000\000\000\000\000\000\000\000\000\255\255\192\168\000\000\001"; ] in List.iter (fun (addr,exn) -> assert_raises ~msg:(String.escaped addr) exn (fun () -> V6.of_bytes_exn addr) ) addrs let test_int32_rt () = let (a,b,c,d) as addr = 0x2001_0665_l, 0x0000_0000_l, 0xff00_00ff_l, 0xfe00_0001_l in assert_equal ~msg:(Printf.sprintf "%08lx %08lx %08lx %08lx" a b c d) V6.(to_int32 (of_int32 addr)) addr let test_prefix_string_rt () = let subnets = [ "2000::/3", "2000::/3"; "c012::/2", "c000::/2"; "ffff:ffff:ffff::ffff/0", "::/0"; "::/0", "::/0"; "::/128", "::/128"; "::1/128", "::1/128"; "::/64", "::/64"; "[::]/64", "::/64"; ] in List.iter (fun (subnet,rt) -> let os = V6.Prefix.of_string_exn subnet in let ts = V6.Prefix.to_string os in assert_equal ~msg:subnet ts rt; let os = V6.Prefix.(t_of_sexp (sexp_of_t os)) in let ts = V6.Prefix.to_string os in assert_equal ~msg:subnet ts rt; ) subnets let test_prefix_string_rt_bad () = let subnets = [ need_more "/24"; need_more "::"; error "::/130" "invalid prefix size"; bad_char 5 "::/30/1"; bad_char 7 "2000::/-1"; bad_char 5 "1::3:/4"; ] in List.iter (fun (subnet,exn) -> assert_raises ~msg:subnet exn (fun () -> V6.Prefix.of_string_exn subnet) ) subnets let test_network_address_rt () = let netaddrs = [ "::1/24", "::/24", "::1"; ] in List.iter (fun (netaddr,net,addr) -> let netv4 = V6.Prefix.of_string_exn net in let addrv4 = V6.of_string_exn addr in let prefix,v4 = V6.Prefix.of_address_string_exn netaddr in assert_equal ~msg:(net^" <> "^(V6.Prefix.to_string prefix)) netv4 prefix; assert_equal ~msg:(addr^" <> "^(V6.to_string v4)) addrv4 v4; let addrstr = V6.Prefix.to_address_string prefix v4 in assert_equal ~msg:(netaddr^" <> "^addrstr) netaddr addrstr; ) netaddrs let test_prefix_bits () = let pairs = V6.Prefix.([ global_unicast_001, 3; link, 64; unique_local, 7; multicast, 8; ipv4_mapped, 96; noneui64_interface, 3; ]) in List.iter (fun (subnet,bits) -> let msg = (V6.Prefix.to_string subnet) ^ " <> bits " ^ (string_of_int bits) in assert_equal ~msg (V6.Prefix.bits subnet) bits ) pairs let test_prefix_netmask () = let nets = [ "8::1/128","ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff"; "8::1/127","ffff:ffff:ffff:ffff:ffff:ffff:ffff:fffe"; "8::1/96", "ffff:ffff:ffff:ffff:ffff:ffff::"; "8::1/64", "ffff:ffff:ffff:ffff::"; "8::1/32", "ffff:ffff::"; "8::1/1", "8000::"; "8::1/0", "::"; ] in List.iter (fun (net_str,nm_str) -> let prefix, v6 = V6.Prefix.of_address_string_exn net_str in let nm = V6.Prefix.netmask prefix in let nnm_str = V6.to_string nm in let msg = Printf.sprintf "netmask %s <> %s" nnm_str nm_str in assert_equal ~msg nnm_str nm_str; let prefix = V6.Prefix.of_netmask nm v6 in let nns = V6.Prefix.to_address_string prefix v6 in let msg = Printf.sprintf "%s is %s under netmask iso" net_str nns in assert_equal ~msg net_str nns ) nets let test_prefix_netmask_bad () = let bad_masks = [ error "7fff:ffff:ffff:ffff:ffff:ffff:ffff:ffff" "invalid netmask"; error "ffff:ffff:ffff:ffff:ffff:fffe:8000:0" "invalid netmask"; error "ffff:ffff:ffff:fffe:8000::" "invalid netmask"; error "ffff:fffe:8000::" "invalid netmask"; ] in List.iter (fun (nm_str,exn) -> let nm = V6.of_string_exn nm_str in let addr = V6.of_string_exn "::" in assert_raises ~msg:nm_str exn (fun () -> V6.Prefix.of_netmask nm addr) ) bad_masks let test_scope () = let localhost_v4 = V6.of_string_exn "::ffff:127.0.0.1" in let is subnet addr = V6.Prefix.(mem addr subnet) in let is_scope scop addr = scop = V6.scope addr in let ships = V6.([ unspecified, "global", is_global, false; unspecified, "multicast", is_multicast, false; unspecified, "point", is_scope Point, true; localhost, "global", is_global, false; localhost, "multicast", is_multicast, false; localhost, "interface", is_scope Interface, true; interface_nodes, "global", is_global, false; interface_nodes, "multicast", is_multicast, true; interface_nodes, "interface", is_scope Interface, true; link_nodes, "global", is_global, false; link_nodes, "multicast", is_multicast, true; link_nodes, "link", is_scope Link, true; link_routers, "global", is_global, false; link_routers, "multicast", is_multicast, true; link_routers, "link", is_scope Link, true; localhost_v4, "global", is_global, false; localhost_v4, "multicast", is_multicast, false; localhost_v4, "ipv4", is Prefix.ipv4_mapped, true; localhost_v4, "noneui64", is Prefix.noneui64_interface, true; localhost_v4, "global_001",is Prefix.global_unicast_001, false; localhost_v4, "interface", is_scope Interface, true; ]) in List.iter (fun (addr,lbl,pred,is_mem) -> let mems = if is_mem then "" else " not" in let msg = (V6.to_string addr)^" is"^mems^" in "^lbl in assert_equal ~msg (pred addr) is_mem ) ships let test_map () = let module M = Map.Make(V6) in let maxs = "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff" in let m = M.add (V6.of_string_exn "::0:0") "min" M.empty in let m = M.add (V6.of_string_exn maxs) "the greatest host" m in let m = M.add (V6.of_string_exn "::") "the least host" m in assert_equal ~msg:"size" (M.cardinal m) 2; let (min_key, min_val) = M.min_binding m in assert_equal ~msg:("min is '" ^ min_val ^"'") (min_key, min_val) (V6.of_string_exn "::0:0:0", "the least host"); assert_equal ~msg:"max" (M.max_binding m) (V6.of_string_exn maxs, "the greatest host") let test_prefix_map () = let module M = Map.Make(V6.Prefix) in let m = M.add (V6.Prefix.of_string_exn "::ffff:0.0.0.0/0") "everyone" M.empty in let m = M.add (V6.Prefix.of_string_exn "::ffff:192.0.0.0/1") "weirdos" m in let m = M.add (V6.Prefix.of_string_exn "::ffff:128.0.0.0/1") "high-bitters" m in let m = M.add (V6.Prefix.of_string_exn "::ffff:254.0.0.0/8") "top-end" m in let m = M.add (V6.Prefix.of_string_exn "::ffff:0.0.0.0/0") "iana" m in assert_equal ~msg:"size" (M.cardinal m) 3; assert_equal ~msg:"min" (M.min_binding m) (V6.Prefix.of_string_exn "::ffff:0.0.0.0/0", "iana"); assert_equal ~msg:"max" (M.max_binding m) (V6.Prefix.of_string_exn "::ffff:254.0.0.0/8", "top-end"); assert_equal ~msg:"third" (M.find (V6.Prefix.of_string_exn "::ffff:128.0.0.0/1") m) "high-bitters" let test_multicast_mac () = let on = 0xFFFF in let ip = V6.make on on on on on 0xFFFF 0xFEFE 0xFDFD in let unicast = V6.Prefix.(network_address global_unicast_001 ip) in let multicast = V6.Prefix.(network_address multicast ip) in let unicast_mac_str = Macaddr.to_string (V6.multicast_to_mac unicast) in let multicast_mac_str = Macaddr.to_string (V6.multicast_to_mac multicast) in let mac_str = "33:33:fe:fe:fd:fd" in assert_equal ~msg:("unicast_mac "^unicast_mac_str^" <> "^mac_str) unicast_mac_str mac_str; assert_equal ~msg:("multicast_mac "^multicast_mac_str^" <> "^mac_str) multicast_mac_str mac_str let test_domain_name () = let ip = V6.of_string_exn "2a00:1450:4009:800::200e" in let name = "e.0.0.2.0.0.0.0.0.0.0.0.0.0.0.0.0.0.8.0.9.0.0.4.0.5.4.1.0.0.a.2.ip6.arpa." in assert_equal ~msg:"domain_name" (String.concat "." (V6.to_domain_name ip)) name let test_link_address_of_mac () = let mac = Macaddr.of_string_exn "34-56-78-9A-BC-DE" in let ip_str = V6.(to_string (link_address_of_mac mac)) in let expected = "fe80::3656:78ff:fe9a:bcde" in assert_equal ~msg:("link_address_of_mac "^ip_str^" <> "^expected) ip_str expected let suite = "Test V6" >::: [ "string_rt" >:: test_string_rt; "string_rt_bad" >:: test_string_rt_bad; "string_raw_rt" >:: test_string_raw_rt; "string_raw_rt_bad" >:: test_string_raw_rt_bad; "bytes_rt" >:: test_bytes_rt; "bytes_rt_bad" >:: test_bytes_rt_bad; "int32_rt" >:: test_int32_rt; "prefix_string_rt" >:: test_prefix_string_rt; "prefix_string_rt_bad" >:: test_prefix_string_rt_bad; "network_address_rt" >:: test_network_address_rt; "prefix_bits" >:: test_prefix_bits; "prefix_netmask" >:: test_prefix_netmask; "prefix_netmask_bad" >:: test_prefix_netmask_bad; "scope" >:: test_scope; "map" >:: test_map; "prefix_map" >:: test_prefix_map; "multicast_mac" >:: test_multicast_mac; "domain_name" >:: test_domain_name; "link_address_of_mac" >:: test_link_address_of_mac; ] end let test_string_raw_rt () = let addrs = [ ("IP: 192.168.0.0!!",4), ("192.168.0.0",15); ("IP: 192:168:0::!!",4), ("192:168::",15); ("IP: [192:168::]!!",4), ("192:168::",15); ] in List.iter (fun ((addr,off),(result,cursor)) -> let c = ref off in let os = of_string_raw addr c in let ts = to_string os in let msg = Printf.sprintf "%s at %d: %s at %d <> %s at %d" addr off result cursor ts !c in assert_equal ~msg (ts,!c) (result,cursor) ) addrs let test_string_raw_rt_bad () = let error (s,c) msg c' = (s,c), (Parse_error (msg,s),c') in let addrs = [ error ("IP: ::192.168 ",4) "not an IPv4 address: invalid character ':' at 4\nnot an IPv6 address: invalid character ' ' at 13" 13; error ("IP: [::192.168] ",4) "not an IPv4 address: invalid character '[' at 4\nnot an IPv6 address: invalid character ']' at 14" 14; (* ? *) error ("IP: 192:168::3.5 ",4) "not an IPv4 address: invalid character ':' at 7\nnot an IPv6 address: invalid character ' ' at 16" 16; ] in List.iter (fun ((addr,off),(exn,cursor)) -> let c = ref off in assert_raises ~msg:addr exn (fun () -> of_string_raw addr c); assert_equal ~msg:(Printf.sprintf "%s cursor <> %d (%d)" addr cursor !c) !c cursor ) addrs let test_map () = let module M = Map.Make(Ipaddr) in let maxv6 = "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff" in let maxv4 = "254.254.254.254" in let m = M.add (of_string_exn maxv4) "the greatest host v4" M.empty in let m = M.add (of_string_exn "::0:0") "minv6" m in let m = M.add (of_string_exn maxv6) "the greatest host v6" m in let m = M.add (of_string_exn "::") "the least host v6" m in let m = M.add (of_string_exn "1.0.0.1") "minv4" m in let m = M.add (of_string_exn "1.0.0.1") "the least host v4" m in assert_equal ~msg:"size" (M.cardinal m) 4; let (min_key, min_val) = M.min_binding m in assert_equal ~msg:("min is '" ^ min_val ^"'") (min_key, min_val) (of_string_exn "1.0.0.1", "the least host v4"); assert_equal ~msg:"max" (M.max_binding m) (of_string_exn maxv6, "the greatest host v6") let test_prefix_mem () = let ip = of_string_exn in let ships = [ ip "192.168.0.1", V4 V4.Prefix.private_192, true; ip "192.168.0.1", Prefix.of_string_exn "::ffff:0:0/96", true; ip "192.168.0.1", Prefix.of_string_exn "::ffff:0:0/95", true; ip "192.168.0.1", Prefix.of_string_exn "::ffff:0:0/97", false; ip "192.168.0.1", Prefix.of_string_exn "::ffff:128.0.0.0/97", true; ip "::ffff:10.0.0.1", V4 V4.Prefix.private_10, true; ip "::fffe:10.0.0.1", V4 V4.Prefix.private_10, false; ] in List.iter (fun (addr,subnet,is_mem) -> let msg = Printf.sprintf "%s is%s in %s" (to_string addr) (if is_mem then "" else " not") (Prefix.to_string subnet) in assert_equal ~msg (Prefix.mem addr subnet) is_mem ) ships let suite = "Test Generic Addresses" >::: [ "string_raw_rt" >:: test_string_raw_rt; "string_raw_rt_bad" >:: test_string_raw_rt_bad; "map" >:: test_map; "prefix_mem" >:: test_prefix_mem; ] ;; let _results = run_test_tt_main Test_v4.suite in let _results = run_test_tt_main Test_v6.suite in let _results = run_test_tt_main suite in () ocaml-ipaddr-2.6.1/lib_test/test_macaddr.ml000066400000000000000000000052401247165427200206600ustar00rootroot00000000000000(* * Copyright (c) 2013-2014 David Sheets * * 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 OUnit open Macaddr let test_string_rt () = let addrs = [ "ca:fe:ba:be:ee:ee", ':'; "ca-fe-ba-be-ee-ee", '-'; ] in List.iter (fun (addr,sep) -> let os = of_string_exn addr in let ts = to_string ~sep os in assert_equal ~msg:(addr ^ " <> " ^ ts) ts addr; let os = t_of_sexp (sexp_of_t os) in let ts = to_string ~sep os in assert_equal ~msg:(addr ^ " <> " ^ ts) ts addr; ) addrs let test_string_rt_bad () = let addrs = [ "ca:fe:ba:be:ee:e"; "ca:fe:ba:be:ee:eee"; "ca:fe:ba:be:eeee"; "ca:fe:ba:be:ee::ee"; "ca:fe:ba:be:e:eee"; "ca:fe:ba:be:ee-ee"; ] in List.iter (fun addr -> assert_equal ~msg:addr (of_string addr) None) addrs let test_bytes_rt () = let addr = "\254\099\003\128\000\000" in assert_equal ~msg:(String.escaped addr) (to_bytes (of_bytes_exn addr)) addr let test_bytes_rt_bad () = let addrs = [ "\254\099\003\128\000"; "\254\099\003\128\000\000\233"; ] in List.iter (fun addr -> assert_equal ~msg:(String.escaped addr) (of_bytes addr) None) addrs let test_make_local () = let () = Random.self_init () in let bytegen i = if i = 0 then 253 else 255 - i in let local_addr = make_local bytegen in assert_equal ~msg:"is_local" (is_local local_addr) true; assert_equal ~msg:"is_unicast" (is_unicast local_addr) true; assert_equal ~msg:"localize" (to_bytes local_addr).[0] (Char.chr 254); for i=1 to 5 do assert_equal ~msg:("addr.["^(string_of_int i)^"]") (to_bytes local_addr).[i] (Char.chr (bytegen i)) done; assert_equal ~msg:"get_oui" (get_oui local_addr) ((254 lsl 16) + (254 lsl 8) + 253) let suite = "Test" >::: [ "string_rt" >:: test_string_rt; "string_rt_bad" >:: test_string_rt_bad; "bytes_rt" >:: test_bytes_rt; "bytes_rt_bad" >:: test_bytes_rt_bad; "make_local" >:: test_make_local; ] ;; run_test_tt_main suite ocaml-ipaddr-2.6.1/myocamlbuild.ml000066400000000000000000000426201247165427200171050ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: bad12c52d2295e9705af01fa611f2526) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end # 132 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 237 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild * by N. Pouillard and others * * Updated on 2009/02/28 * * Modified by Sylvain Le Gall *) open Ocamlbuild_plugin (* these functions are not really officially exported *) let run_and_read = Ocamlbuild_pack.My_unix.run_and_read let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings let exec_from_conf exec = let exec = let env_filename = Pathname.basename BaseEnvLight.default_filename in let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in try BaseEnvLight.var_get exec env with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" exec; exec in let fix_win32 str = if Sys.os_type = "Win32" then begin let buff = Buffer.create (String.length str) in (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. *) String.iter (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) str; Buffer.contents buff end else begin str end in fix_win32 exec let split s ch = let buf = Buffer.create 13 in let x = ref [] in let flush () = x := (Buffer.contents buf) :: !x; Buffer.clear buf in String.iter (fun c -> if c = ch then flush () else Buffer.add_char buf c) s; flush (); List.rev !x let split_nl s = split s '\n' let before_space s = try String.before s (String.index s ' ') with Not_found -> s (* ocamlfind command *) let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] (* This lists all supported packages. *) let find_packages () = List.map before_space (split_nl & run_and_read "ocamlfind list") (* Mock to list available syntaxes. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] let well_known_syntax = [ "camlp4.quotations.o"; "camlp4.quotations.r"; "camlp4.exceptiontracer"; "camlp4.extend"; "camlp4.foldgenerator"; "camlp4.listcomprehension"; "camlp4.locationstripper"; "camlp4.macro"; "camlp4.mapgenerator"; "camlp4.metagenerator"; "camlp4.profiler"; "camlp4.tracer" ] let dispatch = function | After_options -> (* By using Before_options one let command line options have an higher * priority on the contrary using After_options will guarantee to have * the higher priority override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; Options.ocamlmktop := ocamlfind & A"ocamlmktop"; Options.ocamlmklib := ocamlfind & A"ocamlmklib" | After_rules -> (* When one link an OCaml library/binary/package, one should use * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> let base_args = [A"-package"; A pkg] in (* TODO: consider how to really choose camlp4o or camlp4r. *) let syn_args = [A"-syntax"; A "camlp4o"] in let args = (* Heuristic to identify syntax extensions: whether they end in ".syntax"; some might not. *) if Filename.check_suffix pkg "syntax" || List.mem pkg well_known_syntax then syn_args @ base_args else base_args in flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; end (find_packages ()); (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. * Indeed, the default rules add the "threads.cma" or "threads.cmxa" * options when using this tag. When using the "-linkpkg" option with * ocamlfind, this module will then be added twice on the command line. * * To solve this, one approach is to add the "-thread" option when using * the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); | _ -> () end module MyOCamlbuildBase = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall *) open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler type dir = string type file = string type name = string type tag = string (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { lib_ocaml: (name * dir list * string list) list; lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) includes: (dir * dir list) list; } let env_filename = Pathname.basename BaseEnvLight.default_filename let dispatch_combine lst = fun e -> List.iter (fun dispatch -> dispatch e) lst let tag_libstubs nm = "use_lib"^nm^"_stubs" let nm_libstubs nm = nm^"_stubs" let dispatch t e = let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then String.sub s 1 ((String.length s) - 1) else s in List.iter (fun (opt, var) -> try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; Options.ext_dll, "ext_dll"; ] | After_rules -> (* Declare OCaml libraries *) List.iter (function | nm, [], intf_modules -> ocaml_lib nm; let cmis = List.map (fun m -> (String.uncapitalize m) ^ ".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis | nm, dir :: tl, intf_modules -> ocaml_lib ~dir:dir (dir^"/"^nm); List.iter (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) tl; let cmis = List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] cmis) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; (* Declare C libraries *) List.iter (fun (lib, dir, headers) -> (* Handle C part of library *) flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. *) dep ["link"; "ocaml"; "program"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; "program"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) dep ["compile"; "c"] headers; (* Setup search path for lib *) flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; (* Add flags *) List.iter (fun (tags, cond_specs) -> let spec = BaseEnvLight.var_choose cond_specs env in let rec eval_specs = function | S lst -> S (List.map eval_specs lst) | A str -> A (BaseEnvLight.var_expand str env) | spec -> spec in flag tags & (eval_specs spec)) t.flags | _ -> () let dispatch_default t = dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch; ] end # 594 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [ ("ipaddr", ["lib"], []); ("ipaddr_unix", ["lib"], []); ("ipaddr_top", ["top"], []) ]; lib_c = []; flags = [ (["oasis_library_ipaddr_byte"; "ocaml"; "link"; "byte"], [(OASISExpr.EBool true, S [A "-w"; A "@f@p@u@s@40"])]); (["oasis_library_ipaddr_native"; "ocaml"; "link"; "native"], [(OASISExpr.EBool true, S [A "-w"; A "@f@p@u@s@40"])]); (["oasis_library_ipaddr_byte"; "ocaml"; "ocamldep"; "byte"], [(OASISExpr.EBool true, S [A "-w"; A "@f@p@u@s@40"])]); (["oasis_library_ipaddr_native"; "ocaml"; "ocamldep"; "native"], [(OASISExpr.EBool true, S [A "-w"; A "@f@p@u@s@40"])]); (["oasis_library_ipaddr_byte"; "ocaml"; "compile"; "byte"], [(OASISExpr.EBool true, S [A "-w"; A "@f@p@u@s@40"])]); (["oasis_library_ipaddr_native"; "ocaml"; "compile"; "native"], [(OASISExpr.EBool true, S [A "-w"; A "@f@p@u@s@40"])]) ]; includes = [] } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; # 627 "myocamlbuild.ml" (* OASIS_STOP *) let () = let additional_rules = function | After_rules -> pflag ["compile"; "ocaml"] "I" (fun x -> S [A "-I"; A x]); | _ -> () in Ocamlbuild_plugin.dispatch (MyOCamlbuildBase.dispatch_combine [MyOCamlbuildBase.dispatch_default package_default; additional_rules]) ocaml-ipaddr-2.6.1/opam000066400000000000000000000013151247165427200147450ustar00rootroot00000000000000opam-version: "1.2" maintainer: "sheets@alum.mit.edu" authors: [ "David Sheets" "Anil Madhavapeddy" "Hugo Heuzard" ] license: "ISC" homepage: "https://github.com/mirage/ocaml-ipaddr" bug-reports: "https://github.com/mirage/ocaml-ipaddr/issues" dev-repo: "https://github.com/mirage/ocaml-ipaddr.git" tags: [ "org:mirage" "org:xapi-project" ] build: [ ["ocaml" "setup.ml" "-configure" "--prefix" prefix "--%{ounit:enable}%-tests"] [make "build"] ] build-test: [ [make "test"] ] install: [ [make "install"] ] remove: [ ["ocamlfind" "remove" "ipaddr"] ] depends: [ "ocamlfind" {build} "base-bytes" "sexplib" "type_conv" "ounit" {test} ] ocaml-ipaddr-2.6.1/setup.ml000066400000000000000000005446311247165427200155750ustar00rootroot00000000000000(* setup.ml generated for the first time by OASIS v0.4.1 *) (* OASIS_START *) (* DO NOT EDIT (digest: 90b714c94abc1fe7e83f38515fbe8e31) *) (* Regenerated by OASIS v0.4.4 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISContext = struct (* # 22 "src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; } let quiet = {!default with quiet = true} let fspecs () = (* TODO: don't act on default. *) let ignore_plugins = ref false in ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), s_ " Run quietly"; "-info", Arg.Unit (fun () -> default := {!default with info = true}), s_ " Display information message"; "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), s_ " Output debug message"; "-ignore-plugins", Arg.Set ignore_plugins, s_ " Ignore plugin's field."; "-C", (* TODO: remove this chdir. *) Arg.String (fun str -> Sys.chdir str), s_ "dir Change directory before running."], fun () -> {!default with ignore_plugins = !ignore_plugins} end module OASISString = struct (* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; if !what_idx = String.length what then true else false let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; if !what_idx = -1 then true else false let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = String.make (String.length s) 'X' in for i = 0 to String.length s - 1 do buf.[i] <- f s.[i] done; buf end module OASISUtils = struct (* # 22 "src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) let compare_csl s1 s2 = String.compare (String.lowercase s1) (String.lowercase s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (String.lowercase s1) = (String.lowercase s2) let hash s = Hashtbl.hash (String.lowercase s) end) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in String.lowercase buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt end module PropList = struct (* # 22 "src/oasis/PropList.ml" *) open OASISGettext type name = string exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 78 "src/oasis/PropList.ml" *) end module Schema = struct type ('ctxt, 'extra) value = { get: Data.t -> string; set: Data.t -> ?context:'ctxt -> string -> unit; help: (unit -> string) option; extra: 'extra; } type ('ctxt, 'extra) t = { name: name; fields: (name, ('ctxt, 'extra) value) Hashtbl.t; order: name Queue.t; name_norm: string -> string; } let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); name_norm = (if case_insensitive then String.lowercase else fun s -> s); } let add t nm set get extra help = let key = t.name_norm nm in if Hashtbl.mem t.fields key then failwith (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); Hashtbl.add t.fields key { set = set; get = get; help = help; extra = extra; }; Queue.add nm t.order let mem t nm = Hashtbl.mem t.fields nm let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> raise (Unknown_field (nm, t.name)) let get t data nm = (find t nm).get data let set t data nm ?context x = (find t nm).set data ?context x let fold f acc t = Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) acc t.order let iter f t = fold (fun () -> f) () t let name t = t.name end module Field = struct type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; get: Data.t -> 'value; sets: Data.t -> ?context:'ctxt -> string -> unit; gets: Data.t -> string; help: (unit -> string) option; extra: 'extra; } let new_id = let last_id = ref 0 in fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) let v = ref None in (* If name is not given, create unique one *) let nm = match name with | Some s -> s | None -> Printf.sprintf "_anon_%d" (new_id ()) in (* Last chance to get a value: the default *) let default () = match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in (* Get data *) let get data = (* Get value *) try (Hashtbl.find data nm) (); match !v with | Some x -> x | None -> default () with Not_found -> default () in (* Set data *) let set data ?context x = let x = match update with | Some f -> begin try f ?context (get data) x with Not_set _ -> x end | None -> x in Hashtbl.replace data nm (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> f | None -> fun ?context s -> failwith (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) in (* Set data, from string *) let sets data ?context s = set ?context data (parse ?context s) in (* Output value as string, if possible *) let print = match print with | Some f -> f | None -> fun _ -> raise (No_printer nm) in (* Get data, as a string *) let gets data = print (get data) in begin match schema with | Some t -> Schema.add t nm sets gets extra help | None -> () end; { set = set; get = get; sets = sets; gets = gets; help = help; extra = extra; } let fset data t ?context x = t.set data ?context x let fget data t = t.get data let fsets data t ?context s = t.sets data ?context s let fgets data t = t.gets data end module FieldRO = struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld end end module OASISMessage = struct (* # 22 "src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true in Printf.ksprintf (fun str -> if cond then begin ctxt.printf lvl str end) fmt let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct (* # 22 "src/oasis/OASISVersion.ml" *) open OASISGettext type s = string type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = str let string_of_version t = t let version_compare_string s1 s2 = version_compare (version_of_string s1) (version_of_string s2) let chop t = try let pos = String.rindex t '.' in String.sub t 0 pos with Not_found -> t let rec comparator_apply v op = match op with | VGreater cv -> (version_compare v cv) > 0 | VGreaterEqual cv -> (version_compare v cv) >= 0 | VLesser cv -> (version_compare v cv) < 0 | VLesserEqual cv -> (version_compare v cv) <= 0 | VEqual cv -> (version_compare v cv) = 0 | VOr (op1, op2) -> (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) | VEqual v -> "= "^(string_of_version v) | VLesser v -> "< "^(string_of_version v) | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat p (OASISUtils.varname_of_string (string_of_version v)) in function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v | VGreaterEqual v -> concat "ge" v | VLesserEqual v -> concat "le" v | VOr (c1, c2) -> (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) let rec comparator_ge v' = let cmp v = version_compare v v' >= 0 in function | VEqual v | VGreaterEqual v | VGreater v -> cmp v | VLesserEqual _ | VLesser _ -> false | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 end module OASISLicense = struct (* # 22 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall *) type license = string type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion type license_dep_5_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module OASISText = struct (* # 22 "src/oasis/OASISText.ml" *) type elt = | Para of string | Verbatim of string | BlankLine type t = elt list end module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) type name = string type package_name = string type url = string type unix_dirname = string type unix_filename = string type host_dirname = string type host_filename = string type prog = string type arg = string type args = string list type command_line = (prog * arg list) type findlib_name = string type findlib_full = string type compiled_object = | Byte | Native | Best type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name | InternalExecutable of name type vcs = | Darcs | Git | Svn | Cvs | Hg | Bzr | Arch | Monotone | OtherVCS of url type plugin_kind = [ `Configure | `Build | `Doc | `Test | `Install | `Extra ] type plugin_data_purpose = [ `Configure | `Build | `Install | `Clean | `Distclean | `Install | `Uninstall | `Test | `Doc | `Extra | `Other of string ] type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list (* # 115 "src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; } type executable = { exec_custom: bool; exec_main_is: unix_filename; } type flag = { flag_description: string option; flag_default: bool conditional; } type source_repository = { src_repo_type: vcs; src_repo_location: url; src_repo_browser: url option; src_repo_module: string option; src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; } type test = { test_type: [`Test] plugin; test_command: command_line conditional; test_custom: custom; test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; } type doc_format = | HTML of unix_filename | DocText | PDF | PostScript | Info of unix_filename | DVI | OtherDoc type doc = { doc_type: [`Doc] plugin; doc_custom: custom; doc_build: bool conditional; doc_install: bool conditional; doc_install_dir: unix_filename; doc_title: string; doc_authors: string list; doc_abstract: string option; doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; } type section = | Library of common_section * build_section * library | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc type section_kind = [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; alpha_features: string list; beta_features: string list; name: package_name; version: OASISVersion.t; license: OASISLicense.t; license_file: unix_filename option; copyrights: string list; maintainers: string list; authors: string list; homepage: url option; synopsis: string; description: OASISText.t option; categories: url list; conf_type: [`Configure] plugin; conf_custom: custom; build_type: [`Build] plugin; build_custom: custom; install_type: [`Install] plugin; install_custom: custom; uninstall_custom: custom; clean_custom: custom; distclean_custom: custom; files_ab: unix_filename list; sections: section list; plugins: [`Extra] plugin list; disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISFeatures = struct (* # 22 "src/oasis/OASISFeatures.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISVersion module MapPlugin = Map.Make (struct type t = plugin_kind * name let compare = Pervasives.compare end) module Data = struct type t = { oasis_version: OASISVersion.t; plugin_versions: OASISVersion.t option MapPlugin.t; alpha_features: string list; beta_features: string list; } let create oasis_version alpha_features beta_features = { oasis_version = oasis_version; plugin_versions = MapPlugin.empty; alpha_features = alpha_features; beta_features = beta_features } let of_package pkg = create pkg.OASISTypes.oasis_version pkg.OASISTypes.alpha_features pkg.OASISTypes.beta_features let add_plugin (plugin_kind, plugin_name, plugin_version) t = {t with plugin_versions = MapPlugin.add (plugin_kind, plugin_name) plugin_version t.plugin_versions} let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions let to_string t = Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" (OASISVersion.string_of_version t.oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ (match ver_opt with | Some v -> " "^(OASISVersion.string_of_version v) | None -> "")) :: acc) t.plugin_versions [])) end type origin = | Field of string * string | Section of string | NoOrigin type stage = Alpha | Beta let string_of_stage = function | Alpha -> "alpha" | Beta -> "beta" let field_of_stage = function | Alpha -> "AlphaFeatures" | Beta -> "BetaFeatures" type publication = InDev of stage | SinceVersion of OASISVersion.t type t = { name: string; plugin: all_plugin option; publication: publication; description: unit -> string; } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 let since_version ver_str = SinceVersion (version_of_string ver_str) let alpha = InDev Alpha let beta = InDev Beta let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" t.name (match t.plugin with | None -> "" | Some (_, nm, _) -> nm) (match t.publication with | InDev stage -> string_of_stage stage | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) let data_check t data origin = let no_message = "no message" in let check_feature features stage = let has_feature = List.mem t.name features in if not has_feature then match origin with | Field (fld, where) -> Some (Printf.sprintf (f_ "Field %s in %s is only available when feature %s \ is in field %s.") fld where t.name (field_of_stage stage)) | Section sct -> Some (Printf.sprintf (f_ "Section %s is only available when features %s \ is in field %s.") sct t.name (field_of_stage stage)) | NoOrigin -> Some no_message else None in let version_is_good ~min_version version fmt = let version_is_good = OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in Printf.ksprintf (fun str -> if version_is_good then None else Some str) fmt in match origin, t.plugin, t.publication with | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha | _, _, InDev Beta -> check_feature data.Data.beta_features Beta | Field(fld, where), None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Field %s in %s is only valid since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking \ OASIS changelog.") fld where (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Field(fld, where), Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Field %s in %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") fld where plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Field %s in %s is only valid when the OASIS plugin %s \ is defined.") fld where plugin_name in version_is_good ~min_version plugin_version_current (f_ "Field %s in %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") fld where plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | Section sct, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Section %s is only valid for since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking OASIS \ changelog.") sct (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Section sct, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Section %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") sct plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Section %s is only valid when the OASIS plugin %s \ is defined.") sct plugin_name in version_is_good ~min_version plugin_version_current (f_ "Section %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") sct plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | NoOrigin, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version "%s" no_message | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> raise Not_found in version_is_good ~min_version plugin_version_current "%s" no_message with Not_found -> Some no_message end let data_assert t data origin = match data_check t data origin with | None -> () | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with | None -> true | Some str -> false let package_test t pkg = data_test t (Data.of_package pkg) let create ?plugin name publication description = let () = if Hashtbl.mem all_features name then failwithf "Feature '%s' is already declared." name in let t = { name = name; plugin = plugin; publication = publication; description = description; } in Hashtbl.add all_features name t; t let get_stage name = try (Hashtbl.find all_features name).publication with Not_found -> failwithf (f_ "Feature %s doesn't exist.") name let list () = Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] (* * Real flags. *) let features = create "features_fields" (since_version "0.4") (fun () -> s_ "Enable to experiment not yet official features.") let flag_docs = create "flag_docs" (since_version "0.3") (fun () -> s_ "Building docs require '-docs' flag at configure.") let flag_tests = create "flag_tests" (since_version "0.3") (fun () -> s_ "Running tests require '-tests' flag at configure.") let pack = create "pack" (since_version "0.3") (fun () -> s_ "Allow to create packed library.") let section_object = create "section_object" beta (fun () -> s_ "Implement an object section.") let dynrun_for_release = create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> s_ "It compiles the setup.ml and speed-up actions done with it.") let disable_oasis_section = create "disable_oasis_section" alpha (fun () -> s_ "Allows the OASIS section comments and digest to be omitted in \ generated files.") end module OASISUnixPath = struct (* # 22 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string type host_filename = string type host_dirname = string let current_dir_name = "." let parent_dir_name = ".." let is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in f1'^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.capitalize base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize base) end module OASISHostPath = struct (* # 22 "src/oasis/OASISHostPath.ml" *) open Filename module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = if Sys.os_type = "Unix" then ufn else make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISString.nsplit ufn '/')) end module OASISSection = struct (* # 22 "src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Object (cs, _, _) -> `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section sct = let k, nm = section_id sct in (match k with | `Library -> "library" | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc") ^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 22 "src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct (* # 22 "src/oasis/OASISExecutable.ml" *) open OASISTypes let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () | Byte -> false in OASISUnixPath.concat dir (cs.cs_name^(suffix_program ())), if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 22 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists bs modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) [modul; OASISUnixPath.uncapitalize_file modul; OASISUnixPath.capitalize_file modul] in (* TODO: we should be able to be able to determine the source for every * files. Hence we should introduce a Module(source: fn) for the fields * Modules and InternalModules *) List.fold_left (fun acc base_fn -> match acc with | `No_sources _ -> begin let file_found = List.fold_left (fun acc ext -> if source_file_exists (base_fn^ext) then (base_fn^ext) :: acc else acc) [] [".ml"; ".mli"; ".mll"; ".mly"] in match file_found with | [] -> acc | lst -> `Sources (base_fn, lst) end | `Sources _ -> acc) (`No_sources possible_base_fn) possible_base_fn let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module source_file_exists bs modul with | `Sources (base_fn, [fn]) when ext <> "cmi" && Filename.check_suffix fn ".mli" -> None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> Some [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; Some lst in List.fold_left (fun acc nm -> match find_module nm with | None -> acc | Some base_fns -> List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in (* The headers that should be compiled along *) let headers = if lib.lib_pack then [] else find_modules lib.lib_modules "cmi" in (* The .cmx that be compiled along *) let cmxs = let should_be_built = match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then if lib.lib_pack then find_modules [cs.cs_name] "cmx" else find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath end else acc_nopath in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) end module OASISObject = struct (* # 22 "src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name; acc) [] obj.obj_modules let generated_unix_files ~ctxt ~is_native ~source_file_exists (cs, bs, obj) = let find_module ext modul = match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, _) -> [base_fn ^ ext] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name ; lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, find_module ".cmo" m, find_module ".cmx" m, find_module ".o" m, fun x -> x) | _ -> ([cs.cs_name ^ ".cmi"], [cs.cs_name ^ ".cmo"], [cs.cs_name ^ ".cmx"], [cs.cs_name ^ ".o"], OASISUnixPath.concat bs.bs_path) in List.map (List.map f) ( match bs.bs_compiled_object with | Native -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] | Byte | Best -> byte :: header :: []) end module OASISFindlib = struct (* # 22 "src/oasis/OASISFindlib.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * [`Library of library | `Object of object_] * group_t list) type data = common_section * build_section * [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Object (cs, _, obj) -> begin let obj_name = cs.cs_name in if MapString.mem obj_name mp then failwithf (f_ "The object name '%s' is used more than once.") obj_name; let findlib_full_name = match obj.obj_findlib_fullname with | Some ns -> String.concat "." ns | None -> obj_name in MapString.add obj_name (`Solved findlib_full_name) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children: tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let rec group_of_tree mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> Package (nm, cs, bs, lib, group_of_tree children) | Node (None, children) -> Container (nm, group_of_tree children) | Leaf (cs, bs, lib) -> Package (nm, cs, bs, lib, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, `Library lib) mp | Object (cs, bs, obj) -> add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree group_mp in let library_name_of_findlib_name = Lazy.lazy_from_fun (fun () -> (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty) in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 22 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 22 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 22 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 22 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 22 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 22 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 22 "src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) let ( * ) lst1 lst2 = List.flatten (List.map (fun a -> List.map (fun b -> a, b) lst2) lst1) in let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> let acc = (List.map (fun (a, b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) | [e] -> e | [] -> [] in let alternatives = List.map (fun (p, e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in List.find (fun file -> (if case_sensitive then file_exists_case file else Sys.file_exists file) && not (Sys.is_directory file) ) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) let ln = String.length dn in if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then fix_dir (String.sub dn 0 (ln - 1)) else dn let q = Filename.quote (**/**) let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") tgt end let glob ~ctxt fn = let basename = Filename.basename fn in if String.length basename >= 2 && basename.[0] = '*' && basename.[1] = '.' then begin let ext_len = (String.length basename) - 2 in let ext = String.sub basename 2 ext_len in let dirname = Filename.dirname fn in Array.fold_left (fun acc fn -> try let fn_ext = String.sub fn ((String.length fn) - ext_len) ext_len in if fn_ext = ext then (Filename.concat dirname fn) :: acc else acc with Invalid_argument _ -> acc) [] (Sys.readdir dirname) end else begin if file_exists_case fn then [fn] else [] end end # 2878 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 2983 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) (* TODO: get rid of this module. *) open OASISContext let args () = fst (fspecs ()) let default = default end module BaseMessage = struct (* # 22 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage open BaseContext let debug fmt = debug ~ctxt:!default fmt let info fmt = info ~ctxt:!default fmt let warning fmt = warning ~ctxt:!default fmt let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct (* # 22 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (o, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (e: unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = BaseEnvLight.default_filename let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () let unload () = env_from_file := MapString.empty; Data.clear env let dump ?(filename=default_filename) () = let chn = open_out_bin filename in let output nm value = Printf.fprintf chn "%s=%S\n" nm value in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try let value = Schema.get schema env nm in output nm value with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; (* End of the dump *) close_out chn let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration: \n"; List.iter (fun (name, value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 22 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext let parse argv args = (* Simulate command line for Arg *) let current = ref 0 in try Arg.parse_argv ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") with | Arg.Help txt -> print_endline txt; exit 0 | Arg.Bad txt -> prerr_endline txt; exit 1 end module BaseCheck = struct (* # 22 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) with Not_found -> None) None prg_lst in match alternate with | Some prg -> prg | None -> raise Not_found) let prog prg = prog_best prg [prg] let prog_opt prg = prog_best prg [prg^".opt"; prg] let ocamlfind = prog "ocamlfind" let version var_prefix cmp fversion () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in var_redefine ~hide:true var (fun () -> let version_str = match fversion () with | "[Distributed with OCaml]" -> begin try (var_get "ocaml_version") with Not_found -> warning (f_ "Variable ocaml_version not defined, fallback \ to default"); Sys.ocaml_version end | res -> res in let version = OASISVersion.version_of_string version_str in if OASISVersion.comparator_apply version cmp then version_str else failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = OASISUtils.varname_concat "pkg_" (OASISUtils.varname_of_string pkg) in let findlib_dir pkg = let dir = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> findlib_dir pkg) () in ( match version_comparator with | Some ver_cmp -> ignore (version var ver_cmp (fun _ -> package_version pkg) ()) | None -> () ); vl end module BaseOCamlcConfig = struct (* # 22 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext module SMap = Map.Make(String) let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) *) let rec split_field mp lst = match lst with | line :: tl -> let mp = try let pos_semicolon = String.index line ':' in if pos_semicolon > 1 then ( let name = String.sub line 0 pos_semicolon in let linelen = String.length line in let value = if linelen > pos_semicolon + 2 then String.sub line (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" in SMap.add name value mp ) else ( mp ) with Not_found -> ( mp ) in split_field mp tl | [] -> mp in let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 22 "src/base/BaseStandardVar.ml" *) open OASISGettext open OASISTypes open OASISExpr open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") let var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" (* TODO: Check standard variable presence at runtime *) let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" let bytecomp_c_compiler = c "bytecomp_c_compiler" let native_c_compiler = c "native_c_compiler" let model = c "model" let ext_obj = c "ext_obj" let ext_asm = c "ext_asm" let ext_lib = c "ext_lib" let ext_dll = c "ext_dll" let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" let flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) let p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> match os_type () with | "Win32" -> let program_files = Sys.getenv "PROGRAMFILES" in program_files/(pkg_name ()) | _ -> "/usr/local") let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s: string = ocamlopt () in "true" with PropList.Not_set _ -> let _s: string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" | "Cygwin" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 22 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage let to_filename fn = let fn = OASISHostPath.of_unix fn in if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; Filename.chop_extension fn let replace fn_lst = let buff = Buffer.create 13 in List.iter (fun fn -> let fn = OASISHostPath.of_unix fn in let chn_in = open_in fn in let chn_out = open_out (to_filename fn) in ( try while true do Buffer.add_string buff (var_expand (input_line chn_in)); Buffer.add_char buff '\n' done with End_of_file -> () ); Buffer.output_buffer chn_out buff; Buffer.clear buff; close_in chn_in; close_out chn_out) fn_lst end module BaseLog = struct (* # 22 "src/base/BaseLog.ml" *) open OASISUtils let default_filename = Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" module SetTupleString = Set.Make (struct type t = string * string let compare (s11, s12) (s21, s22) = match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) let load () = if Sys.file_exists default_filename then begin let chn = open_in default_filename in let scbuf = Scanf.Scanning.from_file default_filename in let rec read_aux (st, lst) = if not (Scanf.Scanning.end_of_input scbuf) then begin let acc = try Scanf.bscanf scbuf "%S %S\n" (fun e d -> let t = e, d in if SetTupleString.mem t st then st, lst else SetTupleString.add t st, t :: lst) with Scanf.Scan_failure _ -> failwith (Scanf.bscanf scbuf "%l" (fun line -> Printf.sprintf "Malformed log file '%s' at line %d" default_filename line)) in read_aux acc end else begin close_in chn; List.rev lst end in read_aux (SetTupleString.empty, []) end else begin [] end let register event data = let chn_out = open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename in Printf.fprintf chn_out "%S %S\n" event data; close_out chn_out let unregister event data = if Sys.file_exists default_filename then begin let lst = load () in let chn_out = open_out default_filename in let write_something = ref false in List.iter (fun (e, d) -> if e <> event || d <> data then begin write_something := true; Printf.fprintf chn_out "%S %S\n" e d end) lst; close_out chn_out; if not !write_something then Sys.remove default_filename end let filter events = let st_events = List.fold_left (fun st e -> SetString.add e st) SetString.empty events in List.filter (fun (e, _) -> SetString.mem e st_events) (load ()) let exists event data = List.exists (fun v -> (event, data) = v) (load ()) end module BaseBuilt = struct (* # 22 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BObj -> "obj" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register t nm lst = BaseLog.register (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISFileUtil.file_exists_case fn then begin BaseLog.register (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else registered) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister t nm = List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [to_log_event_file t nm; to_log_event_done t nm]) let fold t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISFileUtil.file_exists_case fn then begin f acc fn end else begin warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf (match t with | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") | BObj -> (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter [to_log_event_file t nm]) let is_built t nm = List.fold_left (fun is_built (_, d) -> (try bool_of_string d with _ -> false)) false (BaseLog.filter [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst let of_object ffn (cs, bs, obj) = let unix_lst = OASISObject.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) (cs, bs, obj) in let evs = [BObj, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 22 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in match var_choose ~name:(s_ "Pre/Post Command") ~printer lst with | Some (cmd, args) -> begin try run cmd args [||] with e when failsafe -> warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) (match e with | Failure msg -> msg | e -> Printexc.to_string e) end | None -> () in let res = optional_command cstm.pre_command; f e in optional_command cstm.post_command; res end module BaseDynVar = struct (* # 22 "src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, exec) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) (OASISUtils.varname_of_string cs.cs_name) (fun () -> let fn_opt = fold BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 22 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISExpr open OASISGettext let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let failed, n = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg; (* Possible explanation why the tests where not run. *) if OASISFeatures.package_test OASISFeatures.flag_tests pkg && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 22 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin pkg (cs, doc)) extra_args end in List.iter one_doc lst; if OASISFeatures.package_test OASISFeatures.flag_docs pkg && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 22 "src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISSection open OASISGettext open OASISUtils type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load (); with _ -> () end; (* Run plugin's configure *) t.configure t.package args; (* Dump to allow postconf to change it *) dump ()) (); (* Reload environment *) unload (); load (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace t.package.files_ab let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args let doc t args = BaseDoc.doc (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args let test t args = BaseTest.test (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args let all t args = let rno_doc = ref false in let rno_test = ref false in let arg_rest = ref [] in Arg.parse_argv ~current:(ref 0) (Array.of_list ((Sys.executable_name^" all") :: (Array.to_list args))) [ "-no-doc", Arg.Set rno_doc, s_ "Don't run doc target"; "-no-test", Arg.Set rno_test, s_ "Don't run test target"; "--", Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure t (Array.of_list (List.rev !arg_rest)); info "Running build step"; build t [||]; (* Load setup.log dynamic variables *) BaseDynVar.init t.package; if not !rno_doc then begin info "Running doc step"; doc t [||]; end else begin info "Skipping doc step" end; if not !rno_test then begin info "Running test step"; test t [||] end else begin info "Skipping test step" end let install t args = BaseCustom.hook t.package.install_custom (t.install t.package) args let uninstall t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall t.package) args let reinstall t args = uninstall t args; install t args let clean, distclean = let failsafe f a = try f a with e -> warning (f_ "Action fail with error: %s") (match e with | Failure msg -> msg | e -> Printexc.to_string e) in let generic_clean t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm (fun () -> (* Clean section *) List.iter (function | Test (cs, test) -> let f = try List.assoc cs.cs_name tests with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, test)) args | Doc (cs, doc) -> let f = try List.assoc cs.cs_name docs with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, doc)) args | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f t.package) args) mains) () in let clean t args = generic_clean t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean t args = (* Call clean *) clean t args; (* Call distclean code *) generic_clean t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args; (* Remove generated file *) List.iter (fun fn -> if Sys.file_exists fn then begin info (f_ "Remove '%s'") fn; Sys.remove fn end) (BaseEnv.default_filename :: BaseLog.default_filename :: (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in clean, distclean let version t _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") let default_oasis_fn = "_oasis" let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> default_oasis_fn in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | n -> failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file default_oasis_fn then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in try let act_ref = ref (fun _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in Arg.parse (Arg.align ([ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n"); (* Build initial environment *) load ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init t.package; if t.setup_update && update_setup_ml t then () else !act_ref t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end # 5394 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall *) open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage (** Configure build using provided series of check to be done * and then output corresponding file. *) let configure pkg argv = let var_ignore_eval var = let _s: string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf (fun b -> errors := SetString.add (Buffer.contents b) !errors; Buffer.clear b) buff fmt in let warn_exception e = warning "%s" (Printexc.to_string e) in (* Check tools *) let check_tools lst = List.iter (function | ExternalTool tool -> begin try var_ignore_eval (BaseCheck.prog tool) with e -> warn_exception e; add_errors (f_ "Cannot find external tool '%s'") tool end | InternalExecutable nm1 -> (* Check that matching tool is built *) List.iter (function | Executable ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal executable \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) lst in let build_checks sct bs = if var_choose bs.bs_build then begin if bs.bs_compiled_object = Native then begin try var_ignore_eval BaseStandardVar.ocamlopt with e -> warn_exception e; add_errors (f_ "Section %s requires native compilation") (OASISSection.string_of_section sct) end; (* Check tools *) check_tools bs.bs_build_tools; (* Check depends *) List.iter (function | FindlibPackage (findlib_pkg, version_comparator) -> begin try var_ignore_eval (BaseCheck.package ?version_comparator findlib_pkg) with e -> warn_exception e; match version_comparator with | None -> add_errors (f_ "Cannot find findlib package %s") findlib_pkg | Some ver_cmp -> add_errors (f_ "Cannot find findlib package %s (%s)") findlib_pkg (OASISVersion.string_of_comparator ver_cmp) end | InternalLibrary nm1 -> (* Check that matching library is built *) List.iter (function | Library ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal library \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) bs.bs_build_depends end in (* Parse command line *) BaseArgExt.parse argv (BaseEnv.args ()); (* OCaml version *) begin match pkg.ocaml_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "ocaml" ver_cmp BaseStandardVar.ocaml_version) with e -> warn_exception e; add_errors (f_ "OCaml version %s doesn't match version constraint %s") (BaseStandardVar.ocaml_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Findlib version *) begin match pkg.findlib_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "findlib" ver_cmp BaseStandardVar.findlib_version) with e -> warn_exception e; add_errors (f_ "Findlib version %s doesn't match version constraint %s") (BaseStandardVar.findlib_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Make sure the findlib version is fine for the OCaml compiler. *) begin let ocaml_ge4 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) (OASISVersion.version_of_string "4.0.0") >= 0 in if ocaml_ge4 then let findlib_lt132 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) (OASISVersion.version_of_string "1.3.2") < 0 in if findlib_lt132 then add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || BaseStandardVar.os_type () = "Cygwin" then begin try var_ignore_eval BaseStandardVar.flexlink with e -> warn_exception e; add_errors (f_ "Cannot find 'flexlink'") end; (* Check build depends *) List.iter (function | Executable (_, bs, _) | Library (_, bs, _) as sct -> build_checks sct bs | Doc (_, doc) -> if var_choose doc.doc_build then check_tools doc.doc_build_tools | Test (_, test) -> if var_choose test.test_run then check_tools test.test_tools | _ -> ()) pkg.sections; (* Check if we need native dynlink (presence of libraries that compile to * native) *) begin let has_cmxa = List.exists (function | Library (_, bs, _) -> var_choose bs.bs_build && (bs.bs_compiled_object = Native || (bs.bs_compiled_object = Best && bool_of_string (BaseStandardVar.is_native ()))) | _ -> false) pkg.sections in if has_cmxa then var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) if SetString.empty != !errors then begin List.iter (fun e -> error "%s" e) (SetString.elements !errors); failwithf (fn_ "%d configuration error" "%d configuration errors" (SetString.cardinal !errors)) (SetString.cardinal !errors) end end module InternalInstallPlugin = struct (* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISFindlib open OASISGettext open OASISUtils let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) let obj_hook = ref (fun (cs, bs, obj) -> cs, bs, obj, []) let doc_hook = ref (fun (cs, doc) -> cs, doc) let install_file_ev = "install-file" let install_dir_ev = "install-dir" let install_findlib_ev = "install-findlib" let win32_max_command_line_length = 8000 let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) let first_args = ["install"; findlib_name; meta] in (* Arguments for remaining commands: *) let other_args = ["install"; findlib_name; "-add"] in (* Extract as much files as possible from [files], [len] is the current command line length: *) let rec get_files len acc files = match files with | [] -> (List.rev acc, []) | file :: rest -> let len = len + 1 + String.length file in if len > win32_max_command_line_length then (List.rev acc, files) else get_files len (file :: acc) rest in (* Split the command into several commands. *) let rec split args files = match files with | [] -> [] | _ -> (* Length of "ocamlfind install [META|-add]" *) let len = List.fold_left (fun len arg -> len + 1 (* for the space *) + String.length arg) (String.length ocamlfind) args in match get_files len [] files with | ([], _) -> failwith (s_ "Command line too long.") | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) let () = let findlib_ge_132 = OASISVersion.comparator_apply (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf (f_ "Installing the library %s require to use the \ flag '-add' of ocamlfind because the command \ line is too long. This flag is only available \ for findlib 1.3.2. Please upgrade findlib from \ %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in cmd :: cmds in (* The first command does not use -add: *) split first_args files else ["install" :: findlib_name :: meta :: files] let install pkg argv = let in_destdir = try let destdir = destdir () in (* Practically speaking destdir is prepended * at the beginning of the target filename *) fun fn -> destdir^fn with PropList.Not_set _ -> fun fn -> fn in let install_file ?tgt_fn src_file envdir = let tgt_dir = in_destdir (envdir ()) in let tgt_file = Filename.concat tgt_dir (match tgt_fn with | Some fn -> fn | None -> Filename.basename src_file) in (* Create target directory if needed *) OASISFileUtil.mkdir_parent ~ctxt:!BaseContext.default (fun dn -> info (f_ "Creating directory '%s'") dn; BaseLog.register install_dir_ev dn) tgt_dir; (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; BaseLog.register install_file_ev tgt_file in (* Install data into defined directory *) let install_data srcdir lst tgtdir = let tgtdir = OASISHostPath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> let real_srcs = OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat srcdir src) in if real_srcs = [] then failwithf (f_ "Wildcard '%s' doesn't match any files") src; List.iter (fun fn -> install_file fn (fun () -> match tgt_opt with | Some s -> OASISHostPath.of_unix (var_expand s) | None -> tgtdir)) real_srcs) lst in (** Install all libraries *) let install_libs pkg = let files_of_library (f_data, acc) data_lib = let cs, bs, lib, lib_extra = !lib_hook data_lib in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then begin let acc = (* Start with acc + lib_extra *) List.rev_append lib_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left (fun acc modul -> try List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) [modul^".mli"; modul^".ml"; String.uncapitalize modul^".mli"; String.capitalize modul^".mli"; String.uncapitalize modul^".ml"; String.capitalize modul^".ml"]) :: acc with Not_found -> begin warning (f_ "Cannot find source header for module %s \ in library %s") modul cs.cs_name; acc end) acc lib.lib_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BLib cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the library *) install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end and files_of_object (f_data, acc) data_obj = let cs, bs, obj, obj_extra = !obj_hook data_obj in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then begin let acc = (* Start with acc + obj_extra *) List.rev_append obj_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left (fun acc modul -> try List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) [modul^".mli"; modul^".ml"; String.uncapitalize modul^".mli"; String.capitalize modul^".mli"; String.uncapitalize modul^".ml"; String.capitalize modul^".ml"]) :: acc with Not_found -> begin warning (f_ "Cannot find source header for module %s \ in object %s") modul cs.cs_name; acc end) acc obj.obj_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BObj cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the object *) install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end in (* Install one group of library *) let install_group_lib grp = (* Iterate through all group nodes *) let rec install_group_lib_aux data_and_files grp = let data_and_files, children = match grp with | Container (_, children) -> data_and_files, children | Package (_, cs, bs, `Library lib, children) -> files_of_library data_and_files (cs, bs, lib), children | Package (_, cs, bs, `Object obj, children) -> files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux data_and_files children in (* Findlib name of the root library *) let findlib_name = findlib_of_group grp in (* Determine root library *) let root_lib = root_of_group grp in (* All files to install for this library *) let f_data, files = install_group_lib_aux (ignore, []) grp in (* Really install, if there is something to install *) if files = [] then begin warning (f_ "Nothing to install for findlib library '%s'") findlib_name end else begin let meta = (* Search META file *) let _, bs, _ = root_lib in let res = Filename.concat bs.bs_path "META" in if not (OASISFileUtil.file_exists_case res) then failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) let remove_prefix p n = let plen = String.length p in let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in String.sub n cutpoint (nlen - cutpoint) end else n in List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") findlib_name; let ocamlfind = ocamlfind () in let commands = split_install_command ocamlfind findlib_name meta files in List.iter (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) commands; BaseLog.register install_findlib_ev findlib_name end; (* Install data files *) f_data (); in let group_libs, _, _ = findlib_mapping pkg in (* We install libraries in groups *) List.iter install_group_lib group_libs in let install_execs pkg = let install_exec data_exec = let cs, bs, exec = !exec_hook data_exec in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then begin let exec_libdir () = Filename.concat (libdir ()) pkg.name in BaseBuilt.fold BaseBuilt.BExec cs.cs_name (fun () fn -> install_file ~tgt_fn:(cs.cs_name ^ ext_program ()) fn bindir) (); BaseBuilt.fold BaseBuilt.BExecLib cs.cs_name (fun () fn -> install_file fn exec_libdir) (); install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name) end in List.iter (function | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) | _ -> ()) pkg.sections in let install_docs pkg = let install_doc data = let cs, doc = !doc_hook data in if var_choose doc.doc_install && BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then begin let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in BaseBuilt.fold BaseBuilt.BDoc cs.cs_name (fun () fn -> install_file fn (fun () -> tgt_dir)) (); install_data Filename.current_dir_name doc.doc_data_files doc.doc_install_dir end in List.iter (function | Doc (cs, doc) -> install_doc (cs, doc) | _ -> ()) pkg.sections in install_libs pkg; install_execs pkg; install_docs pkg (* Uninstall already installed data *) let uninstall _ argv = List.iter (fun (ev, data) -> if ev = install_file_ev then begin if OASISFileUtil.file_exists_case data then begin info (f_ "Removing file '%s'") data; Sys.remove data end else begin warning (f_ "File '%s' doesn't exist anymore") data end end else if ev = install_dir_ev then begin if Sys.file_exists data && Sys.is_directory data then begin if Sys.readdir data = [||] then begin info (f_ "Removing directory '%s'") data; OASISFileUtil.rmdir ~ctxt:!BaseContext.default data end else begin warning (f_ "Directory '%s' is not empty (%s)") data (String.concat ", " (Array.to_list (Sys.readdir data))) end end else begin warning (f_ "Directory '%s' doesn't exist anymore") data end end else if ev = install_findlib_ev then begin info (f_ "Removing findlib library '%s'") data; OASISExec.run ~ctxt:!BaseContext.default (ocamlfind ()) ["remove"; data] end else failwithf (f_ "Unknown log event '%s'") ev; BaseLog.unregister ev data) (* We process event in reverse order *) (List.rev (BaseLog.filter [install_file_ev; install_dir_ev; install_findlib_ev])) end # 6243 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) open OASISGettext open BaseEnv open BaseStandardVar open OASISTypes type extra_args = string list let ocamlbuild_clean_ev = "ocamlbuild-clean" let ocamlbuildflags = var_define ~short_desc:(fun () -> "OCamlbuild additional flags") "ocamlbuildflags" (fun () -> "") (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten [ if (os_type ()) = "Win32" then [ "-classic-display"; "-no-log"; "-no-links"; "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") ] else []; if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then [ "-byte-plugin" ] else []; args; if bool_of_string (debug ()) then ["-tag"; "debug"] else []; if bool_of_string (profile ()) then ["-tag"; "profile"] else []; OASISString.nsplit (ocamlbuildflags ()) ' '; Array.to_list extra_argv; ] (** Run 'ocamlbuild -clean' if not already done *) let run_clean extra_argv = let extra_cli = String.concat " " (Array.to_list extra_argv) in (* Run if never called with these args *) if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then begin OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args ["-clean"] extra_argv); BaseLog.register ocamlbuild_clean_ev extra_cli; at_exit (fun () -> try BaseLog.unregister ocamlbuild_clean_ev extra_cli with _ -> ()) end (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html *) OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args args extra_argv); (* Remove any clean event, we must run it again *) List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [ocamlbuild_clean_ev]) (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = function | "-build-dir" :: dir :: tl -> search_args dir tl | _ :: tl -> search_args dir tl | [] -> dir in search_args "_build" (fix_args [] extra_argv) end module OCamlbuildPlugin = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISUtils open OASISString open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage let cond_targets_hook = ref (fun lst -> lst) let build extra_args pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat (build_dir argv) fn in (* Return the unix filename in host build directory *) let in_build_dir_of_unix fn = in_build_dir (OASISHostPath.of_unix fn) in let cond_targets = List.fold_left (fun acc -> function | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_library in_build_dir_of_unix (cs, bs, lib) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ~what:".cma" fn || ends_with ~what:".cmxs" fn || ends_with ~what:".cmxa" fn || ends_with ~what:(ext_lib ()) fn || ends_with ~what:(ext_dll ()) fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for library %s") cs.cs_name end | Object (cs, bs, obj) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_object in_build_dir_of_unix (cs, bs, obj) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ".cmo" fn || ends_with ".cmx" fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for object %s") cs.cs_name end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) in let target ext = let unix_tgt = (OASISUnixPath.concat bs.bs_path (OASISUnixPath.chop_extension exec.exec_main_is))^ext in let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs in evs, [unix_tgt] in (* Add executable *) let acc = match bs.bs_compiled_object with | Native -> (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte | Best -> (target ".byte") :: acc in acc end | Library _ | Object _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] (* Keep the pkg.sections ordered *) (List.rev pkg.sections); in (* Check and register built files *) let check_and_register (bt, bnm, lst) = List.iter (fun fns -> if not (List.exists OASISFileUtil.file_exists_case fns) then failwithf (fn_ "Expected built file %s doesn't exist." "None of expected built files %s exists." (List.length fns)) (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in (* Run the hook *) let cond_targets = !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; (* ... and register events *) List.iter check_and_register (List.flatten (List.map fst cond_targets)) let clean pkg extra_args = run_clean extra_args; List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections end module OCamlbuildDocPlugin = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISMessage open OCamlbuildCommon open BaseStandardVar type run_t = { extra_args: string list; run_path: unix_filename; } let doc_build run pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ run.run_path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = OASISHostPath.make [ build_dir argv; OASISHostPath.of_unix run.run_path; cs.cs_name^".docdir"; ] in run_ocamlbuild (index_html :: run.extra_args) argv; List.iter (fun glb -> BaseBuilt.register BaseBuilt.BDoc cs.cs_name [OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] let doc_clean run pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name end # 6616 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) (** Generate custom configure/build/doc/test/install system @author *) open BaseEnv open OASISGettext open OASISTypes type t = { cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; } let run = BaseCustom.run let main t _ extra_args = let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in run cmd args extra_args let clean t pkg extra_args = match var_choose t.cmd_clean with | Some (cmd, args) -> run cmd args extra_args | _ -> () let distclean t pkg extra_args = match var_choose t.cmd_distclean with | Some (cmd, args) -> run cmd args extra_args | _ -> () module Build = struct let main t pkg extra_args = main t pkg extra_args; List.iter (fun sct -> let evs = match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, _ = BaseBuilt.of_library OASISHostPath.of_unix (cs, bs, lib) in evs end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, _, _ = BaseBuilt.of_executable OASISHostPath.of_unix (cs, bs, exec) in evs end | _ -> [] in List.iter (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) evs) pkg.sections let clean t pkg extra_args = clean t pkg extra_args; (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild * considering moving this to BaseSetup? *) List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections let distclean t pkg extra_args = distclean t pkg extra_args end module Test = struct let main t pkg (cs, test) extra_args = try main t pkg extra_args; 0.0 with Failure s -> BaseMessage.warning (f_ "Test '%s' fails: %s") cs.cs_name s; 1.0 let clean t pkg (cs, test) extra_args = clean t pkg extra_args let distclean t pkg (cs, test) extra_args = distclean t pkg extra_args end module Doc = struct let main t pkg (cs, _) extra_args = main t pkg extra_args; BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] let clean t pkg (cs, _) extra_args = clean t pkg extra_args; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name let distclean t pkg (cs, _) extra_args = distclean t pkg extra_args end end # 6764 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build []; test = [ ("ipaddr", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; doc = []; install = InternalInstallPlugin.install; uninstall = InternalInstallPlugin.uninstall; clean = [OCamlbuildPlugin.clean]; clean_test = [ ("ipaddr", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; clean_doc = []; distclean = []; distclean_test = [ ("ipaddr", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; distclean_doc = []; package = { oasis_version = "0.3"; ocaml_version = None; findlib_version = None; alpha_features = []; beta_features = []; name = "ipaddr"; version = "2.6.0"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { OASISLicense.license = "ISC"; excption = None; version = OASISLicense.NoVersion }); license_file = None; copyrights = []; maintainers = []; authors = ["David Sheets"; "Anil Madhavapeddy"; "Hugo Heuzard"]; homepage = None; synopsis = "A library for manipulation of IP (and MAC) address representations"; description = None; categories = []; conf_type = (`Configure, "internal", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; build_type = (`Build, "ocamlbuild", Some "0.4"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "internal", Some "0.4"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; files_ab = []; sections = [ Flag ({ cs_name = "unix"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "build the Unix library"; flag_default = [(OASISExpr.EBool true, true)] }); Flag ({ cs_name = "top"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "build the toplevel printers"; flag_default = [(OASISExpr.EBool true, true)] }); Library ({ cs_name = "ipaddr"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("bytes", None); FindlibPackage ("sexplib", None); FindlibPackage ("sexplib.syntax", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, ["-w"; "@f@p@u@s@40"])]; bs_nativeopt = [(OASISExpr.EBool true, ["-w"; "@f@p@u@s@40"])] }, { lib_modules = ["Ipaddr"; "Macaddr"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = Some "ipaddr"; lib_findlib_containers = [] }); Library ({ cs_name = "ipaddr_unix"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "unix", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("unix", None); InternalLibrary "ipaddr" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Ipaddr_unix"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "ipaddr"; lib_findlib_name = Some "unix"; lib_findlib_containers = [] }); Library ({ cs_name = "ipaddr_top"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "top", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "top"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Ipaddr_top"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "ipaddr"; lib_findlib_name = Some "top"; lib_findlib_containers = [] }); Test ({ cs_name = "ipaddr"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { test_type = (`Test, "custom", Some "0.4"); test_command = [(OASISExpr.EBool true, ("make", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; test_working_directory = Some "lib_test"; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", true) ]; test_tools = [ExternalTool "ocamlbuild"] }) ]; plugins = [(`Extra, "META", Some "0.3"); (`Extra, "DevFiles", Some "0.3")]; disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.4"; oasis_digest = Some "ex\027k\201\006S;\144\164\190\024\173\210%`"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 7042 "setup.ml" (* OASIS_STOP *) let () = setup ();; ocaml-ipaddr-2.6.1/top/000077500000000000000000000000001247165427200146705ustar00rootroot00000000000000ocaml-ipaddr-2.6.1/top/ipaddr_top.ml000066400000000000000000000013231247165427200173460ustar00rootroot00000000000000let printers = [ "Ipaddr.pp_hum"; "Ipaddr.Prefix.pp_hum"; "Ipaddr.V4.pp_hum"; "Ipaddr.V4.Prefix.pp_hum"; "Ipaddr.V6.pp_hum"; "Ipaddr.V6.Prefix.pp_hum"; ] let eval_string ?(print_outcome = false) ?(err_formatter = Format.err_formatter) str = let lexbuf = Lexing.from_string str in let phrase = !Toploop.parse_toplevel_phrase lexbuf in Toploop.execute_phrase print_outcome err_formatter phrase let rec install_printers = function | [] -> true | printer :: printers -> let cmd = Printf.sprintf "#install_printer %s;;" printer in eval_string cmd && install_printers printers let () = if not (install_printers printers) then Format.eprintf "Problem installing Ipaddr-printers@." ocaml-ipaddr-2.6.1/top/ipaddr_top.mldylib000066400000000000000000000001371247165427200203740ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 3d356511396d154b0f981aed8b64d9b1) Ipaddr_top # OASIS_STOP ocaml-ipaddr-2.6.1/top/ipaddr_top.mllib000066400000000000000000000001371247165427200200370ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 3d356511396d154b0f981aed8b64d9b1) Ipaddr_top # OASIS_STOP