diff options
| author | Stephane Glondu <steph@glondu.net> | 2019-08-03 10:15:25 +0200 |
|---|---|---|
| committer | Stephane Glondu <steph@glondu.net> | 2019-08-03 10:15:25 +0200 |
| commit | b9449b94e0faa21e421f6c7957e928f38fc7ac63 (patch) | |
| tree | 2e81d81b8d7b0f61e56b0c667d6a43f166acca53 | |
| parent | 7393ea7f502b73fa229f16326fdf590fab71a508 (diff) | |
| parent | caf332912456c7af52ba76387bad03b460b3b2b8 (diff) | |
Update upstream source from tag 'upstream/1.13'
Update to upstream version '1.13'
with Debian dir afd842a0836a57246ac9743b6e42088a31794409
| -rw-r--r-- | .gitignore | 5 | ||||
| -rw-r--r-- | Changes | 19 | ||||
| -rw-r--r-- | LICENSE | 501 | ||||
| -rw-r--r-- | README.md | 84 | ||||
| -rw-r--r-- | README.txt | 4 | ||||
| -rw-r--r-- | _oasis | 31 | ||||
| -rw-r--r-- | _tags | 12 | ||||
| -rw-r--r-- | ardivink.lua | 14 | ||||
| -rw-r--r-- | myocamlbuild.ml | 645 | ||||
| -rw-r--r-- | setup.ml | 7018 | ||||
| -rw-r--r-- | src/.depend | 21 | ||||
| -rw-r--r-- | src/META | 4 | ||||
| -rw-r--r-- | src/aesni.c | 27 | ||||
| -rw-r--r-- | src/chacha20.c | 162 | ||||
| -rw-r--r-- | src/chacha20.h | 23 | ||||
| -rw-r--r-- | src/cryptokit.ml | 126 | ||||
| -rw-r--r-- | src/cryptokit.mli | 167 | ||||
| -rw-r--r-- | src/keccak.c | 5 | ||||
| -rw-r--r-- | src/keccak.h | 3 | ||||
| -rw-r--r-- | src/libcryptokit_stubs.clib | 4 | ||||
| -rw-r--r-- | src/stubs-chacha20.c | 58 | ||||
| -rw-r--r-- | src/stubs-sha3.c | 16 | ||||
| -rw-r--r-- | test/.depend | 0 | ||||
| -rw-r--r-- | test/prngtest.ml | 49 | ||||
| -rw-r--r-- | test/speedtest.ml | 14 | ||||
| -rw-r--r-- | test/test.ml | 126 |
26 files changed, 5542 insertions, 3596 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..ffcec6b --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +_build +setup.data +setup.log +*.native +*~ @@ -1,3 +1,22 @@ +Release 1.13: +- Add the Chacha20 stream cipher. +- Add the AES-CMAC (a.k.a. AES-OMAC1) message authentication code. +- Pseudo-random number generator: replace the old AES-CBC-Fibonacci generator + with a faster, simpler generator based on Chacha20. +- Add an alternate pseudo-random number generator based on AES in CTR mode. +- Documentation: warn about known cryptographic weaknesses in Triple DES, + Blowfish, and ARCfour. +- Documentation: warn about problems with variable-length messages in + MACs based on block ciphers in CBC mode. + +Release 1.12: +- Fix x86-32 compilation error and improve detection of AES-NI for x86 + processors (Jeremie Dimino, Etienne Millon) + (Closes: #1646) +- AES-NI: align key_schedule on a 16 byte boundary (Etienne Millon) + (Closes: #1709) +- Add original Keccak submission to SHA-3 (Yoichi Hirai) + Release 1.11: - Adapt to "safe string" mode (OCaml 4.02 and later required). The API should remain backward-compatible for clients compiled @@ -0,0 +1,501 @@ +This Library is distributed under the terms of the GNU Library General +Public License version 2 (included below). + +As a special exception to the GNU Library General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute +that executable file under terms of your choice, without any of the +additional requirements listed in clause 6 of the GNU Library General +Public License. By "a publicly distributed version of the Library", +we mean either the unmodified Library as distributed by INRIA, or a +modified version of the Library that is distributed under the +conditions defined in clause 3 of the GNU Library General Public +License. This exception does not however invalidate any other reasons +why the executable file might be covered by the GNU Library General +Public License. + +---------------------------------------------------------------------- + + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if +you distribute copies of the library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, so that any problems introduced by others will not reflect on +the original authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the source code distributed need not include anything that is normally +distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the library's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, + MA 02111-1307, USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + <signature of Ty Coon>, 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/README.md b/README.md new file mode 100644 index 0000000..fb23f8a --- /dev/null +++ b/README.md @@ -0,0 +1,84 @@ +# The Cryptokit library + +## Overview + +The Cryptokit library for OCaml provides a variety of cryptographic primitives that can be used to implement cryptographic protocols in security-sensitive applications. The primitives provided include: + +* Symmetric-key ciphers: AES, Chacha20, DES, Triple-DES, Blowfish, ARCfour, in ECB, CBC, CFB, OFB and counter modes. +* Public-key cryptography: RSA encryption and signature, Diffie-Hellman key agreement. +* Hash functions and MACs: SHA-3, SHA-1, SHA-2, RIPEMD-160, MD5, and MACs based on AES and DES. +* Random number generation. +* Encodings and compression: base 64, hexadecimal, Zlib compression. + +Additional ciphers and hashes can easily be used in conjunction with the library. In particular, basic mechanisms such as chaining modes, output buffering, and padding are provided by generic classes that can easily be composed with user-provided ciphers. More generally, the library promotes a "Lego"-like style of constructing and composing transformations over character streams. + +This library is distributed under the conditions of the GNU Library General Public license version 2, with the special OCaml exception on linking described in file LICENSE. + +## Requirements + +* OCaml 4.02 or more recent. +* The findlib/ocamlfind tool. +* The Zarith library, version 1.4 or more recent. +* The Zlib C library, version 1.1.3 or up is recommended. If it is not installed on your system (look for libz.a or libz.so), get it from http://www.gzip.org/, or indicate in the Makefile that you do not have it. If you are running Linux or BSD or MacOS, your distribution provides precompiled binaries for this library. +* If the operating system does not provide the `/dev/random` device for random number generation, consider installing the [EGD](http://egd.sourceforge.net/) entropy gathering daemon. Without `/dev/random` nor EGD, this library cannot generate cryptographically-strong random data nor RSA keys. The remainder of the library still works, though. + +## Installation + +``` +./configure --enable-tests +make +make test +make install +``` + +## Documentation + +See the extensive documentation comments in file src/cryptokit.mli. + +Compilation options: `ocamlfind ocamlopt -package cryptokit`... + +Linking options: `ocamlfind ocamlopt -linkpkg -package cryptokit`... + +## Warnings and disclaimers + +Disclaimer 1: the author is not an expert in cryptography. While reasonable care has been taken to select good, widely-used implementations of the ciphers and hashes, and follow recommended practices found in reputable applied cryptography textbooks, you are advised to review thoroughly the implementation of this module before using it in a security-critical application. + +Disclaimer 2: some knowledge of cryptography is needed to use effectively this library. A recommended reading is the [Handbook of Applied Cryptography](http://www.cacr.math.uwaterloo.ca/hac/). Building secure applications out of cryptographic primitives also requires a general background in computer security. + +Disclaimer 3: in some countries, the use, distribution, import and/or export of cryptographic applications is restricted by law. The precise restrictions may depend on the strenght of the cryptography used (e.g. key size), but also on its purpose (e.g. confidentiality vs. authentication). It is up to the users of this library to comply with regulations applicable in their country. + +## Design notes and references + +The library is organized around the concept of "transforms". A transform is an object that accepts strings, sub-strings, characters and bytes as input, transforms them, and buffers the output. While it is possible to enter all input, then fetch the output, lower memory requirements can be achieved by purging the output periodically during data input. + +The AES implementation is the public-domain optimized reference implementation by Daemen, Rijmen and Barreto. On x86 processors that support the AES-NI extensions, hardware implementation is used instead. + +The Chacha20 implementation is due to D.J.Bernstein, https://cr.yp.to/streamciphers/timings/estreambench/submissions/salsa20/chacha8/regs/chacha.c . It is in the public domain. + +The DES implementation is based on Outerbridge's popular "d3des" implementation. This is not the fastest DES implementation available, but one of the cleanest. Outerbridge's code is marked as public domain. + +The Blowfish implementation is that of Paul Kocher with some performance improvements. It is under the LGPL. It passes the test vectors listed at http://www.schneier.com/code/vectors.txt + +ARCfour (``alleged RC4'') is implemented from scratch, based on the algorithm described in Schneier's _Applied Cryptography_ + +SHA-1 is also implemented from scratch, based on the algorithm described in the _Handbook of Applied Cryptography_. It passes the FIPS test vectors. + +SHA-2 is implemented from scratch based on FIPS publication 180-2. It passes the FIPS test vectors. + +SHA-3 is based on the "readable" implementation of Keccak written by Markku-Juhani O. Saarinen <mjos@iki.fi>. + +RIPEMD-160 is based on the reference implementation by A.Bosselaers. It passes the test vectors listed at http://www.esat.kuleuven.ac.be/~bosselae/ripemd160.html + +MD5 uses the public-domain implementation by Colin Plumb that is also used in the OCaml runtime system for module Digest. + +RSA encryption and decryption was implemented from scratch, using the Zarith OCaml library for arbitrary-precision arithmetic, which itself uses GMP. Modular exponentiation is the constant-time implementation provided by GMP. The Chinese remainder theorem is exploited when possible, though. Like all ciphers in this library, the RSA implementation is *not* protected against timing attacks. + +RSA key generation uses GMP's `nextprime` function for probabilistic primality testing. + +The hardware RNG uses the RDRAND instruction of recent x86 processors, if supported. It is not available on other platforms. + +The seeded PRNG is just the Chacha20 stream cipher encrypting the all-zeroes message. The seed is used as the Chacha20 key. An alternate seeded PRNG is provided, based on AES encryption of a 128-bit counter. Both PRNGs pass the Dieharder statistical tests. Still, better use the system RNG or the hardware RNG if high-quality random numbers are needed. + +## Performance + +If you configure with the options `--enable-tests --enable-bench`, then do `make test`, a simple benchmark is performed and shows the speed of various operations from this library. @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 54340abf9f934bc8c8a02312afd5aa74) *) +(* DO NOT EDIT (digest: 38dc311195a3981d90ae188e25b31bc8) *) cryptokit - Cryptographic primitives ==================================== @@ -8,7 +8,7 @@ This library provides a variety of cryptographic primitives that can be used to implement cryptographic protocols in security-sensitive applications. The primitives provided include: -- Symmetric-key ciphers: AES, DES, Triple-DES, ARCfour, +- Symmetric-key ciphers: AES, Chacha20, Blowfish, DES, Triple-DES, ARCfour, in ECB, CBC, CFB, OFB and counter modes. - Public-key cryptography: RSA encryption, Diffie-Hellman key agreement. - Hash functions and MACs: SHA-1, SHA-2, SHA-3, RIPEMD160, MD5, @@ -1,6 +1,6 @@ OASISFormat: 0.3 Name: cryptokit -Version: 1.11 +Version: 1.13 Authors: Xavier Leroy License: LGPL-2 with OCaml linking exception BuildTools: ocamlbuild, ocamldoc @@ -12,7 +12,7 @@ Description: to implement cryptographic protocols in security-sensitive applications. The primitives provided include: . - - Symmetric-key ciphers: AES, DES, Triple-DES, ARCfour, + - Symmetric-key ciphers: AES, Chacha20, Blowfish, DES, Triple-DES, ARCfour, in ECB, CBC, CFB, OFB and counter modes. - Public-key cryptography: RSA encryption, Diffie-Hellman key agreement. - Hash functions and MACs: SHA-1, SHA-2, SHA-3, RIPEMD160, MD5, @@ -32,7 +32,7 @@ Flag zlib Default$: !os_type(Win32) Flag hardwaresupport - Description: Enable hardware support for AES (needs GCC or Clang) + Description: Enable hardware support for AES and GCM (needs GCC or Clang) Default$: (architecture(amd64) || architecture(i386)) && !os_type(Win32) Library cryptokit @@ -70,7 +70,10 @@ Library cryptokit stubs-zlib.c, keccak.h, keccak.c, - stubs-sha3.c + stubs-sha3.c, + chacha20.h, + chacha20.c, + stubs-chacha20.c BuildDepends: unix, zarith if flag(zlib) CCOpt: -DHAVE_ZLIB @@ -93,6 +96,14 @@ Executable test Build$: flag(tests) Install: false +Executable prngtest + Path: test + MainIs: prngtest.ml + CompiledObject: native + BuildDepends: cryptokit + Build$: flag(tests) + Install: false + Test main Command: $test TestTools: test @@ -123,11 +134,11 @@ Document "api-cryptokit" XOCamlbuildLibraries: cryptokit SourceRepository head - Type: svn - Location: http://scm.ocamlcore.org/svnroot/cryptokit/trunk - Browser: https://forge.ocamlcore.org/scm/browser.php?group_id=133 + Type: git + Location: https://github.com/xavierleroy/cryptokit + Browser: https://github.com/xavierleroy/cryptokit SourceRepository this - Type: svn - Location: http://scm.ocamlcore.org/svnroot/tags/release111 - Browser: https://forge.ocamlcore.org/scm/browser.php?group_id=133 + Type: git + Location: https://github.com/xavierleroy/cryptokit/releases/tag/release113 + Browser: https://github.com/xavierleroy/cryptokit/releases/tag/release113 @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 0942acdef56237583b50126ab62c0ec8) +# DO NOT EDIT (digest: 62ba61e1d8ad56a1e96795f7c6fb78e2) # 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 @@ -40,6 +40,8 @@ true: annot, bin_annot "src/stubs-zlib.c": oasis_library_cryptokit_ccopt "src/keccak.c": oasis_library_cryptokit_ccopt "src/stubs-sha3.c": oasis_library_cryptokit_ccopt +"src/chacha20.c": oasis_library_cryptokit_ccopt +"src/stubs-chacha20.c": oasis_library_cryptokit_ccopt <src/cryptokit.{cma,cmxa}>: oasis_library_cryptokit_cclib "src/libcryptokit_stubs.lib": oasis_library_cryptokit_cclib "src/dllcryptokit_stubs.dll": oasis_library_cryptokit_cclib @@ -94,10 +96,18 @@ true: annot, bin_annot "src/keccak.c": pkg_zarith "src/stubs-sha3.c": pkg_unix "src/stubs-sha3.c": pkg_zarith +"src/chacha20.c": pkg_unix +"src/chacha20.c": pkg_zarith +"src/stubs-chacha20.c": pkg_unix +"src/stubs-chacha20.c": pkg_zarith # Executable test "test/test.native": pkg_unix "test/test.native": pkg_zarith "test/test.native": use_cryptokit +# Executable prngtest +"test/prngtest.native": pkg_unix +"test/prngtest.native": pkg_zarith +"test/prngtest.native": use_cryptokit # Executable speedtest "test/speedtest.native": pkg_unix "test/speedtest.native": pkg_zarith diff --git a/ardivink.lua b/ardivink.lua deleted file mode 100644 index ce05bfe..0000000 --- a/ardivink.lua +++ /dev/null @@ -1,14 +0,0 @@ -ci = require("ci") -oasis = require("oasis") -dist = require("dist") - -ci.init() -oasis.init() - -ci.prependenv("PATH", "/usr/opt/godi/bin") -ci.prependenv("PATH", "/usr/opt/godi/sbin") -ci.putenv("OUNIT_OUTPUT_HTML_DIR", dist.make_filename("ounit-log.html")) -ci.putenv("OUNIT_OUTPUT_JUNIT_FILE", dist.make_filename("junit.xml")) -ci.putenv("OUNIT_OUTPUT_FILE", dist.make_filename("ounit-log.txt")) - -oasis.std_process("--enable-tests") diff --git a/myocamlbuild.ml b/myocamlbuild.ml index fe9d4d6..a07c579 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,19 +1,12 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 24b175474dc2908a1391cac648439f5e) *) +(* DO NOT EDIT (digest: 7ab3acc49c3c9131310ec300b2562fe8) *) 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 ns_ str = str + let s_ str = str + let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = @@ -23,10 +16,7 @@ module OASISGettext = struct fmt2^^"" - let init = - [] - - + let init = [] end module OASISString = struct @@ -38,7 +28,7 @@ module OASISString = struct Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall - *) + *) let nsplitf str f = @@ -52,19 +42,19 @@ module OASISString = struct 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 + 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) @@ -72,18 +62,18 @@ module OASISString = struct 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 + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx else - !str_idx - !what_idx + 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 = @@ -106,19 +96,16 @@ module OASISString = struct 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 + 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 - false + ok := false; + incr str_idx + done; + !what_idx = String.length what let strip_starts_with ~what str = @@ -132,19 +119,16 @@ module OASISString = struct 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 + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx else - false + ok := false; + decr str_idx + done; + !what_idx = -1 let strip_ends_with ~what str = @@ -189,19 +173,181 @@ module OASISString = struct end -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) +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 - open OASISGettext + module Make (Ord: Map.OrderedType) = + struct + include Map.Make(Ord) + let rec add_list t = + function + | (k, v) :: tl -> add_list (add k v t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] + end + end + + + module MapString = MapExt.Make(String) + + + module SetExt = + struct + module type S = + sig + include Set.S + val add_list: t -> elt list -> t + val of_list: elt list -> t + val to_list: t -> elt list + end + + module Make (Ord: Set.OrderedType) = + struct + include Set.Make(Ord) + + let rec add_list t = + function + | e :: tl -> add_list (add e t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list = elements + end + end + + + module SetString = SetExt.Make(String) + + + let compare_csl s1 s2 = + String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) + + + module HashStringCsl = + Hashtbl.Make + (struct + type t = string + let equal s1 s2 = (compare_csl s1 s2) = 0 + let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) + end) + + module SetStringCsl = + SetExt.Make + (struct + type t = string + let compare = compare_csl + end) + + + let varname_of_string ?(hyphen='_') s = + if String.length s = 0 then + begin + invalid_arg "varname_of_string" + end + else + begin + let buf = + OASISString.replace_chars + (fun c -> + if ('a' <= c && c <= 'z') + || + ('A' <= c && c <= 'Z') + || + ('0' <= c && c <= '9') then + c + else + hyphen) + s; + in + let buf = + (* Start with a _ if digit *) + if '0' <= s.[0] && s.[0] <= '9' then + "_"^buf + else + buf + in + OASISString.lowercase_ascii buf + end + + + let varname_concat ?(hyphen='_') p s = + let what = String.make 1 hyphen in + let p = + try + OASISString.strip_ends_with ~what p + with Not_found -> + p + in + let s = + try + OASISString.strip_starts_with ~what s + with Not_found -> + s + in + p^what^s + + + let is_varname str = + str = varname_of_string str - type test = string + let failwithf fmt = Printf.ksprintf failwith fmt + + let rec file_location ?pos1 ?pos2 ?lexbuf () = + match pos1, pos2, lexbuf with + | Some p, None, _ | None, Some p, _ -> + file_location ~pos1:p ~pos2:p ?lexbuf () + | Some p1, Some p2, _ -> + let open Lexing in + let fn, lineno = p1.pos_fname, p1.pos_lnum in + let c1 = p1.pos_cnum - p1.pos_bol in + let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in + Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 + | _, _, Some lexbuf -> + file_location + ~pos1:(Lexing.lexeme_start_p lexbuf) + ~pos2:(Lexing.lexeme_end_p lexbuf) + () + | None, None, None -> + s_ "<position undefined>" + + + let failwithpf ?pos1 ?pos2 ?lexbuf fmt = + let loc = file_location ?pos1 ?pos2 ?lexbuf () in + Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt + + +end + +module OASISExpr = struct +(* # 22 "src/oasis/OASISExpr.ml" *) + + + open OASISGettext + open OASISUtils + + + type test = string type flag = string @@ -214,7 +360,6 @@ module OASISExpr = struct | ETest of test * string - type 'a choices = (t * 'a) list @@ -289,7 +434,7 @@ module OASISExpr = struct end -# 292 "myocamlbuild.ml" +# 437 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -300,132 +445,103 @@ module BaseEnvLight = struct type t = string MapString.t - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" + 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 + let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = + let line = ref 1 in + let lexer st = + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + Genlex.make_lexer ["="] st_line + in + let rec read_file lxr mp = + match Stream.npeek 3 lxr with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; + read_file lxr (MapString.add nm value mp) + | [] -> mp + | _ -> + failwith + (Printf.sprintf "Malformed data file '%s' line %d" filename !line) + in + match stream with + | Some st -> read_file (lexer st) MapString.empty + | None -> + if Sys.file_exists filename then begin + let chn = open_in_bin filename in + let st = Stream.of_channel chn in + try + let mp = read_file (lexer st) MapString.empty in + close_in chn; mp + with e -> + close_in chn; raise e + end else if allow_empty then begin MapString.empty - end - else - begin + 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 + 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 -# 397 "myocamlbuild.ml" +# 517 "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 + * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html * by N. Pouillard and others * - * Updated on 2009/02/28 + * Updated on 2016-06-02 * * Modified by Sylvain Le Gall - *) + *) open Ocamlbuild_plugin - type conf = - { no_automatic_syntax: bool; - } - (* these functions are not really officially exported *) - let run_and_read = - Ocamlbuild_pack.My_unix.run_and_read + type conf = {no_automatic_syntax: bool} + + let run_and_read = Ocamlbuild_pack.My_unix.run_and_read - let blank_sep_strings = - Ocamlbuild_pack.Lexers.blank_sep_strings + + let 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 + let env = BaseEnvLight.load ~allow_empty:true () in try BaseEnvLight.var_get exec env with Not_found -> @@ -436,7 +552,7 @@ module MyOCamlbuildFindlib = struct 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; @@ -445,7 +561,8 @@ module MyOCamlbuildFindlib = struct str end in - fix_win32 exec + fix_win32 exec + let split s ch = let buf = Buffer.create 13 in @@ -454,15 +571,15 @@ module MyOCamlbuildFindlib = struct 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 + 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' @@ -504,85 +621,89 @@ module MyOCamlbuildFindlib = struct let dispatch conf = function | After_options -> - (* By using Before_options one let command line options have an higher - * priority on the contrary using After_options will guarantee to have - * the higher priority override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop"; - Options.ocamlmklib := ocamlfind & A"ocamlmklib" + (* 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"; - - if not (conf.no_automatic_syntax) then begin - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - let base_args = [A"-package"; A pkg] in - (* TODO: consider how to really choose camlp4o or camlp4r. *) - let syn_args = [A"-syntax"; A "camlp4o"] in - let (args, pargs) = - (* Heuristic to identify syntax extensions: whether they end in - ".syntax"; some might not. - *) - if Filename.check_suffix pkg "syntax" || - List.mem pkg well_known_syntax then - (syn_args @ base_args, syn_args) - else - (base_args, []) - in - flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; - flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; - - (* TODO: Check if this is allowed for OCaml < 3.12.1 *) - flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; - end - (find_packages ()); - end; - - (* Like -package but for extensions syntax. Morover -syntax is useless - * when linking. *) - List.iter begin fun syntax -> + (* Avoid warnings for unused tag *) + flag ["tests"] N; + + (* When one link an OCaml library/binary/package, one should use + * -linkpkg *) + flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + let base_args = [A"-package"; A pkg] in + (* TODO: consider how to really choose camlp4o or camlp4r. *) + let syn_args = [A"-syntax"; A "camlp4o"] in + let (args, pargs) = + (* Heuristic to identify syntax extensions: whether they end in + ".syntax"; some might not. + *) + if not (conf.no_automatic_syntax) && + (Filename.check_suffix pkg "syntax" || + List.mem pkg well_known_syntax) then + (syn_args @ base_args, syn_args) + else + (base_args, []) + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + + (* TODO: Check if this is allowed for OCaml < 3.12.1 *) + flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; + end + (find_packages ()); + + (* Like -package but for extensions syntax. Morover -syntax is useless + * when linking. *) + List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & - S[A"-syntax"; A syntax]; - end (find_syntaxes ()); - - (* The default "thread" tag is not compatible with ocamlfind. - * Indeed, the default rules add the "threads.cma" or "threads.cmxa" - * options when using this tag. When using the "-linkpkg" option with - * ocamlfind, this module will then be added twice on the command line. - * - * To solve this, one approach is to add the "-thread" option when using - * the "threads" package using the previous plugin. - *) - flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); - flag ["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"]); + S[A"-syntax"; A syntax]; + end (find_syntaxes ()); + + (* The default "thread" tag is not compatible with ocamlfind. + * Indeed, the default rules add the "threads.cma" or "threads.cmxa" + * options when using this tag. When using the "-linkpkg" option with + * ocamlfind, this module will then be added twice on the command line. + * + * To solve this, one approach is to add the "-thread" option when using + * the "threads" package using the previous plugin. + *) + flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); + flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); + flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]); | _ -> - () + () end module MyOCamlbuildBase = struct @@ -594,9 +715,6 @@ module MyOCamlbuildBase = struct *) - - - open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler @@ -607,9 +725,6 @@ module MyOCamlbuildBase = struct type tag = string -(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - type t = { lib_ocaml: (name * dir list * string list) list; @@ -622,9 +737,10 @@ module MyOCamlbuildBase = struct } - let env_filename = - Pathname.basename - BaseEnvLight.default_filename +(* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + + let env_filename = Pathname.basename BaseEnvLight.default_filename let dispatch_combine lst = @@ -643,12 +759,7 @@ module MyOCamlbuildBase = struct let dispatch t e = - let env = - BaseEnvLight.load - ~filename:env_filename - ~allow_empty:true - () - in + let env = BaseEnvLight.load ~allow_empty:true () in match e with | Before_options -> let no_trailing_dot s = @@ -712,18 +823,19 @@ module MyOCamlbuildBase = struct 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))]); + if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. This holds both for programs and for libraries. *) - dep ["link"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["link"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - dep ["compile"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["compile"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) @@ -763,7 +875,7 @@ module MyOCamlbuildBase = struct end -# 766 "myocamlbuild.ml" +# 878 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -782,7 +894,8 @@ let package_default = "src/sha1.h"; "src/sha256.h"; "src/sha512.h"; - "src/keccak.h" + "src/keccak.h"; + "src/chacha20.h" ]) ]; flags = @@ -1089,6 +1202,6 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 1093 "myocamlbuild.ml" +# 1206 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.4.6 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 6677bd17709754e5ac925a3571f6a0c2) *) +(* DO NOT EDIT (digest: d4c571bd5629a18c3343ee6fabc026b5) *) (* - Regenerated by OASIS v0.4.6 + Regenerated by OASIS v0.4.10 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -11,16 +11,9 @@ 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 ns_ str = str + let s_ str = str + let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = @@ -30,90 +23,7 @@ module OASISGettext = struct 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} + let init = [] end module OASISString = struct @@ -125,7 +35,7 @@ module OASISString = struct Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall - *) + *) let nsplitf str f = @@ -139,19 +49,19 @@ module OASISString = struct 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 + 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) @@ -159,18 +69,18 @@ module OASISString = struct 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 + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx else - !str_idx - !what_idx + 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 = @@ -193,19 +103,16 @@ module OASISString = struct 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 + 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 - false + ok := false; + incr str_idx + done; + !what_idx = String.length what let strip_starts_with ~what str = @@ -219,19 +126,16 @@ module OASISString = struct 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 + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx else - false + ok := false; + decr str_idx + done; + !what_idx = -1 let strip_ends_with ~what str = @@ -416,6 +320,398 @@ module OASISUtils = struct let failwithf fmt = Printf.ksprintf failwith fmt + let rec file_location ?pos1 ?pos2 ?lexbuf () = + match pos1, pos2, lexbuf with + | Some p, None, _ | None, Some p, _ -> + file_location ~pos1:p ~pos2:p ?lexbuf () + | Some p1, Some p2, _ -> + let open Lexing in + let fn, lineno = p1.pos_fname, p1.pos_lnum in + let c1 = p1.pos_cnum - p1.pos_bol in + let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in + Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 + | _, _, Some lexbuf -> + file_location + ~pos1:(Lexing.lexeme_start_p lexbuf) + ~pos2:(Lexing.lexeme_end_p lexbuf) + () + | None, None, None -> + s_ "<position undefined>" + + + let failwithpf ?pos1 ?pos2 ?lexbuf fmt = + let loc = file_location ?pos1 ?pos2 ?lexbuf () in + Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt + + +end + +module OASISUnixPath = struct +(* # 22 "src/oasis/OASISUnixPath.ml" *) + + + type unix_filename = string + type unix_dirname = string + + + type host_filename = string + type host_dirname = string + + + let current_dir_name = "." + + + let parent_dir_name = ".." + + + let is_current_dir fn = + fn = current_dir_name || fn = "" + + + let concat f1 f2 = + if is_current_dir f1 then + f2 + else + let f1' = + try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 + in + f1'^"/"^f2 + + + let make = + function + | hd :: tl -> + List.fold_left + (fun f p -> concat f p) + hd + tl + | [] -> + invalid_arg "OASISUnixPath.make" + + + let dirname f = + try + String.sub f 0 (String.rindex f '/') + with Not_found -> + current_dir_name + + + let basename f = + try + let pos_start = + (String.rindex f '/') + 1 + in + String.sub f pos_start ((String.length f) - pos_start) + with Not_found -> + f + + + let chop_extension f = + try + let last_dot = + String.rindex f '.' + in + let sub = + String.sub f 0 last_dot + in + try + let last_slash = + String.rindex f '/' + in + if last_slash < last_dot then + sub + else + f + with Not_found -> + sub + + with Not_found -> + f + + + let capitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (OASISString.capitalize_ascii base) + + + let uncapitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (OASISString.uncapitalize_ascii base) + + +end + +module OASISHostPath = struct +(* # 22 "src/oasis/OASISHostPath.ml" *) + + + open Filename + open OASISGettext + + + module Unix = OASISUnixPath + + + let make = + function + | [] -> + invalid_arg "OASISHostPath.make" + | hd :: tl -> + List.fold_left Filename.concat hd tl + + + let of_unix ufn = + match Sys.os_type with + | "Unix" | "Cygwin" -> ufn + | "Win32" -> + make + (List.map + (fun p -> + if p = Unix.current_dir_name then + current_dir_name + else if p = Unix.parent_dir_name then + parent_dir_name + else + p) + (OASISString.nsplit ufn '/')) + | os_type -> + OASISUtils.failwithf + (f_ "Don't know the path format of os_type %S when translating unix \ + filename. %S") + os_type ufn + + +end + +module OASISFileSystem = struct +(* # 22 "src/oasis/OASISFileSystem.ml" *) + + (** File System functions + + @author Sylvain Le Gall + *) + + type 'a filename = string + + class type closer = + object + method close: unit + end + + class type reader = + object + inherit closer + method input: Buffer.t -> int -> unit + end + + class type writer = + object + inherit closer + method output: Buffer.t -> unit + end + + class type ['a] fs = + object + method string_of_filename: 'a filename -> string + method open_out: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> writer + method open_in: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> reader + method file_exists: 'a filename -> bool + method remove: 'a filename -> unit + end + + + module Mode = + struct + let default_in = [Open_rdonly] + let default_out = [Open_wronly; Open_creat; Open_trunc] + + let text_in = Open_text :: default_in + let text_out = Open_text :: default_out + + let binary_in = Open_binary :: default_in + let binary_out = Open_binary :: default_out + end + + let std_length = 4096 (* Standard buffer/read length. *) + let binary_out = Mode.binary_out + let binary_in = Mode.binary_in + + let of_unix_filename ufn = (ufn: 'a filename) + let to_unix_filename fn = (fn: string) + + + let defer_close o f = + try + let r = f o in o#close; r + with e -> + o#close; raise e + + + let stream_of_reader rdr = + let buf = Buffer.create std_length in + let pos = ref 0 in + let eof = ref false in + let rec next idx = + let bpos = idx - !pos in + if !eof then begin + None + end else if bpos < Buffer.length buf then begin + Some (Buffer.nth buf bpos) + end else begin + pos := !pos + Buffer.length buf; + Buffer.clear buf; + begin + try + rdr#input buf std_length; + with End_of_file -> + if Buffer.length buf = 0 then + eof := true + end; + next idx + end + in + Stream.from next + + + let read_all buf rdr = + try + while true do + rdr#input buf std_length + done + with End_of_file -> + () + + class ['a] host_fs rootdir : ['a] fs = + object (self) + method private host_filename fn = Filename.concat rootdir fn + method string_of_filename = self#host_filename + + method open_out ?(mode=Mode.text_out) ?(perm=0o666) fn = + let chn = open_out_gen mode perm (self#host_filename fn) in + object + method close = close_out chn + method output buf = Buffer.output_buffer chn buf + end + + method open_in ?(mode=Mode.text_in) ?(perm=0o666) fn = + (* TODO: use Buffer.add_channel when minimal version of OCaml will + * be >= 4.03.0 (previous version was discarding last chars). + *) + let chn = open_in_gen mode perm (self#host_filename fn) in + let strm = Stream.of_channel chn in + object + method close = close_in chn + method input buf len = + let read = ref 0 in + try + for _i = 0 to len do + Buffer.add_char buf (Stream.next strm); + incr read + done + with Stream.Failure -> + if !read = 0 then + raise End_of_file + end + + method file_exists fn = Sys.file_exists (self#host_filename fn) + method remove fn = Sys.remove (self#host_filename fn) + end + +end + +module OASISContext = struct +(* # 22 "src/oasis/OASISContext.ml" *) + + + open OASISGettext + + + type level = + [ `Debug + | `Info + | `Warning + | `Error] + + + type source + type source_filename = source OASISFileSystem.filename + + + let in_srcdir ufn = OASISFileSystem.of_unix_filename ufn + + + type t = + { + (* TODO: replace this by a proplist. *) + quiet: bool; + info: bool; + debug: bool; + ignore_plugins: bool; + ignore_unknown_fields: bool; + printf: level -> string -> unit; + srcfs: source OASISFileSystem.fs; + load_oasis_plugin: string -> bool; + } + + + let printf lvl str = + let beg = + match lvl with + | `Error -> s_ "E: " + | `Warning -> s_ "W: " + | `Info -> s_ "I: " + | `Debug -> s_ "D: " + in + prerr_endline (beg^str) + + + let default = + ref + { + quiet = false; + info = false; + debug = false; + ignore_plugins = false; + ignore_unknown_fields = false; + printf = printf; + srcfs = new OASISFileSystem.host_fs(Sys.getcwd ()); + load_oasis_plugin = (fun _ -> false); + } + + + let quiet = + {!default with quiet = true} + + + let fspecs () = + (* TODO: don't act on default. *) + let ignore_plugins = ref false in + ["-quiet", + Arg.Unit (fun () -> default := {!default with quiet = true}), + s_ " Run quietly"; + + "-info", + Arg.Unit (fun () -> default := {!default with info = true}), + s_ " Display information message"; + + + "-debug", + Arg.Unit (fun () -> default := {!default with debug = true}), + s_ " Output debug message"; + + "-ignore-plugins", + Arg.Set ignore_plugins, + s_ " Ignore plugin's field."; + + "-C", + Arg.String + (fun str -> + Sys.chdir str; + default := {!default with srcfs = new OASISFileSystem.host_fs str}), + s_ "dir Change directory before running (affects setup.{data,log})."], + fun () -> {!default with ignore_plugins = !ignore_plugins} end module PropList = struct @@ -436,27 +732,27 @@ module PropList = struct 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) + | 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 + (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 @@ -465,27 +761,27 @@ module PropList = struct Hashtbl.clear t -(* # 78 "src/oasis/PropList.ml" *) +(* # 77 "src/oasis/PropList.ml" *) end module Schema = struct type ('ctxt, 'extra) value = - { - get: Data.t -> string; - set: Data.t -> ?context:'ctxt -> string -> unit; - help: (unit -> string) option; - extra: 'extra; - } + { + 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; - } + { + name: name; + fields: (name, ('ctxt, 'extra) value) Hashtbl.t; + order: name Queue.t; + name_norm: string -> string; + } let create ?(case_insensitive=false) nm = { @@ -504,21 +800,21 @@ module PropList = struct 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 + 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 @@ -544,7 +840,7 @@ module PropList = struct let v = find t k in - f acc k v.extra v.help) + f acc k v.extra v.help) acc t.order @@ -562,20 +858,20 @@ module PropList = struct 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; - } + { + 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 + fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) @@ -614,33 +910,33 @@ module PropList = struct let x = match update with | Some f -> - begin - try - f ?context (get data) x - with Not_set _ -> - x - end + begin + try + f ?context (get data) x + with Not_set _ -> + x + end | None -> - x + x in - Hashtbl.replace - data - nm - (fun () -> v := Some x) + Hashtbl.replace + data + nm + (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> - f + f | None -> - fun ?context s -> - failwith - (Printf.sprintf - (f_ "Cannot parse field '%s' when setting value %S") - nm - s) + fun ?context s -> + failwith + (Printf.sprintf + (f_ "Cannot parse field '%s' when setting value %S") + nm + s) in (* Set data, from string *) @@ -652,9 +948,9 @@ module PropList = struct let print = match print with | Some f -> - f + f | None -> - fun _ -> raise (No_printer nm) + fun _ -> raise (No_printer nm) in (* Get data, as a string *) @@ -662,22 +958,22 @@ module PropList = struct print (get data) in - begin - match schema with - | Some t -> - Schema.add t nm sets gets extra help - | None -> - () - end; + 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; - } + { + set = set; + get = get; + sets = sets; + gets = gets; + help = help; + extra = extra; + } let fset data t ?context x = t.set data ?context x @@ -699,7 +995,7 @@ module PropList = struct let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in - fun data -> Field.fget data fld + fun data -> Field.fget data fld end end @@ -721,13 +1017,13 @@ module OASISMessage = struct | `Info -> ctxt.info | _ -> true in - Printf.ksprintf - (fun str -> - if cond then - begin - ctxt.printf lvl str - end) - fmt + Printf.ksprintf + (fun str -> + if cond then + begin + ctxt.printf lvl str + end) + fmt let debug ~ctxt fmt = @@ -754,12 +1050,6 @@ module OASISVersion = struct open OASISGettext - - - - type s = string - - type t = string @@ -773,20 +1063,10 @@ module OASISVersion = struct | 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 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 = @@ -794,7 +1074,7 @@ module OASISVersion = struct 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 @@ -829,45 +1109,44 @@ module OASISVersion = struct 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 + 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 + 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 + 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 @@ -876,16 +1155,12 @@ module OASISVersion = struct 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 + String.sub t 0 pos with Not_found -> t @@ -893,19 +1168,19 @@ module OASISVersion = struct let rec comparator_apply v op = match op with | VGreater cv -> - (version_compare v cv) > 0 + (version_compare v cv) > 0 | VGreaterEqual cv -> - (version_compare v cv) >= 0 + (version_compare v cv) >= 0 | VLesser cv -> - (version_compare v cv) < 0 + (version_compare v cv) < 0 | VLesserEqual cv -> - (version_compare v cv) <= 0 + (version_compare v cv) <= 0 | VEqual cv -> - (version_compare v cv) = 0 + (version_compare v cv) = 0 | VOr (op1, op2) -> - (comparator_apply v op1) || (comparator_apply v op2) + (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> - (comparator_apply v op1) && (comparator_apply v op2) + (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = @@ -916,9 +1191,9 @@ module OASISVersion = struct | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> - (string_of_comparator c1)^" || "^(string_of_comparator c2) + (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> - (string_of_comparator c1)^" && "^(string_of_comparator c2) + (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = @@ -928,28 +1203,16 @@ module OASISVersion = struct (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 + | VGreater v -> concat "gt" v + | VLesser v -> concat "lt" v + | VEqual v -> concat "eq" v + | VGreaterEqual v -> concat "ge" v + | VLesserEqual v -> concat "le" v + | VOr (c1, c2) -> + (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) + | VAnd (c1, c2) -> + (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) end @@ -960,15 +1223,10 @@ module OASISLicense = struct (** License for _oasis fields @author Sylvain Le Gall - *) - - - + *) type license = string - - type license_exception = string @@ -978,7 +1236,6 @@ module OASISLicense = struct | NoVersion - type license_dep_5_unit = { license: license; @@ -987,7 +1244,6 @@ module OASISLicense = struct } - type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list @@ -999,22 +1255,17 @@ module OASISLicense = struct | OtherLicense of string (* URL *) - end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) - - - open OASISGettext + open OASISUtils type test = string - - type flag = string @@ -1027,7 +1278,6 @@ module OASISExpr = struct | ETest of test * string - type 'a choices = (t * 'a) list @@ -1104,32 +1354,157 @@ 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" *) +module OASISSourcePatterns = struct +(* # 22 "src/oasis/OASISSourcePatterns.ml" *) + + open OASISUtils + open OASISGettext + + module Templater = + struct + (* TODO: use this module in BaseEnv.var_expand and BaseFileAB, at least. *) + type t = + { + atoms: atom list; + origin: string + } + and atom = + | Text of string + | Expr of expr + and expr = + | Ident of string + | String of string + | Call of string * expr + + + type env = + { + variables: string MapString.t; + functions: (string -> string) MapString.t; + } + + + let eval env t = + let rec eval_expr env = + function + | String str -> str + | Ident nm -> + begin + try + MapString.find nm env.variables + with Not_found -> + (* TODO: add error location within the string. *) + failwithf + (f_ "Unable to find variable %S in source pattern %S") + nm t.origin + end + + | Call (fn, expr) -> + begin + try + (MapString.find fn env.functions) (eval_expr env expr) + with Not_found -> + (* TODO: add error location within the string. *) + failwithf + (f_ "Unable to find function %S in source pattern %S") + fn t.origin + end + in + String.concat "" + (List.map + (function + | Text str -> str + | Expr expr -> eval_expr env expr) + t.atoms) + + + let parse env s = + let lxr = Genlex.make_lexer [] in + let parse_expr s = + let st = lxr (Stream.of_string s) in + match Stream.npeek 3 st with + | [Genlex.Ident fn; Genlex.Ident nm] -> Call(fn, Ident nm) + | [Genlex.Ident fn; Genlex.String str] -> Call(fn, String str) + | [Genlex.String str] -> String str + | [Genlex.Ident nm] -> Ident nm + (* TODO: add error location within the string. *) + | _ -> failwithf (f_ "Unable to parse expression %S") s + in + let parse s = + let lst_exprs = ref [] in + let ss = + let buff = Buffer.create (String.length s) in + Buffer.add_substitute + buff + (fun s -> lst_exprs := (parse_expr s) :: !lst_exprs; "\000") + s; + Buffer.contents buff + in + let rec join = + function + | hd1 :: tl1, hd2 :: tl2 -> Text hd1 :: Expr hd2 :: join (tl1, tl2) + | [], tl -> List.map (fun e -> Expr e) tl + | tl, [] -> List.map (fun e -> Text e) tl + in + join (OASISString.nsplit ss '\000', List.rev (!lst_exprs)) + in + let t = {atoms = parse s; origin = s} in + (* We rely on a simple evaluation for checking variables/functions. + It works because there is no if/loop statement. + *) + let _s : string = eval env t in + t + +(* # 144 "src/oasis/OASISSourcePatterns.ml" *) + end + + + type t = Templater.t + + + let env ~modul () = + { + Templater. + variables = MapString.of_list ["module", modul]; + functions = MapString.of_list + [ + "capitalize_file", OASISUnixPath.capitalize_file; + "uncapitalize_file", OASISUnixPath.uncapitalize_file; + ]; + } + + let all_possible_files lst ~path ~modul = + let eval = Templater.eval (env ~modul ()) in + List.fold_left + (fun acc pat -> OASISUnixPath.concat path (eval pat) :: acc) + [] lst + + let to_string t = t.Templater.origin +end + +module OASISTypes = struct +(* # 22 "src/oasis/OASISTypes.ml" *) type name = string type package_name = string type url = string type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string + type unix_filename = string (* TODO: replace everywhere. *) + type host_dirname = string (* TODO: replace everywhere. *) + type host_filename = string (* TODO: replace everywhere. *) type prog = string type arg = string type args = string list @@ -1146,19 +1521,16 @@ module OASISTypes = struct | 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 @@ -1171,30 +1543,29 @@ module OASISTypes = struct | OtherVCS of url - type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install - | `Extra - ] + [ `Configure + | `Build + | `Doc + | `Test + | `Install + | `Extra + ] type plugin_data_purpose = - [ `Configure - | `Build - | `Install - | `Clean - | `Distclean - | `Install - | `Uninstall - | `Test - | `Doc - | `Extra - | `Other of string - ] + [ `Configure + | `Build + | `Install + | `Clean + | `Distclean + | `Install + | `Uninstall + | `Test + | `Doc + | `Extra + | `Other of string + ] type 'a plugin = 'a * name * OASISVersion.t option @@ -1206,129 +1577,128 @@ module OASISTypes = struct 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; - } - + { + 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; - } - + { + 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; - } - + { + bs_build: bool conditional; + bs_install: bool conditional; + bs_path: unix_dirname; + bs_compiled_object: compiled_object; + bs_build_depends: dependency list; + bs_build_tools: tool list; + bs_interface_patterns: OASISSourcePatterns.t list; + bs_implementation_patterns: OASISSourcePatterns.t list; + bs_c_sources: unix_filename list; + bs_data_files: (unix_filename * unix_filename option) list; + bs_findlib_extra_files: unix_filename list; + bs_ccopt: args conditional; + bs_cclib: args conditional; + bs_dlllib: args conditional; + bs_dllpath: args conditional; + bs_byteopt: args conditional; + bs_nativeopt: args conditional; + } type library = - { - lib_modules: string list; - lib_pack: bool; - lib_internal_modules: string list; - lib_findlib_parent: findlib_name option; - lib_findlib_name: findlib_name option; - lib_findlib_containers: findlib_name list; - } + { + lib_modules: string list; + lib_pack: bool; + lib_internal_modules: string list; + lib_findlib_parent: findlib_name option; + lib_findlib_name: findlib_name option; + lib_findlib_directory: unix_dirname option; + lib_findlib_containers: findlib_name list; + } type object_ = - { - obj_modules: string list; - obj_findlib_fullname: findlib_name list option; - } + { + obj_modules: string list; + obj_findlib_fullname: findlib_name list option; + obj_findlib_directory: unix_dirname option; + } type executable = - { - exec_custom: bool; - exec_main_is: unix_filename; - } + { + exec_custom: bool; + exec_main_is: unix_filename; + } type flag = - { - flag_description: string option; - flag_default: bool conditional; - } + { + 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; - } + { + 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; - } + { + 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 + | HTML of unix_filename (* TODO: source filename. *) | DocText | PDF | PostScript - | Info of unix_filename + | Info of unix_filename (* TODO: source filename. *) | DVI | OtherDoc - type doc = - { - doc_type: [`Doc] plugin; - doc_custom: custom; - doc_build: bool conditional; - doc_install: bool conditional; - doc_install_dir: unix_filename; - 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; - } + { + doc_type: [`Doc] plugin; + doc_custom: custom; + doc_build: bool conditional; + doc_install: bool conditional; + doc_install_dir: unix_filename; (* TODO: dest filename ?. *) + doc_title: string; + doc_authors: string list; + doc_abstract: string option; + doc_format: doc_format; + (* TODO: src filename. *) + doc_data_files: (unix_filename * unix_filename option) list; + doc_build_tools: tool list; + } type section = @@ -1341,50 +1711,51 @@ module OASISTypes = struct | Doc of common_section * doc - type section_kind = - [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + [ `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; - } + { + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; (* TODO: source filename. *) + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + bugreports: url option; + synopsis: string; + description: OASISText.t option; + tags: string list; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; (* TODO: source filename. *) + sections: section list; + plugins: [`Extra] plugin list; + disable_oasis_section: unix_filename list; (* TODO: source filename. *) + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } end @@ -1400,19 +1771,19 @@ module OASISFeatures = struct module MapPlugin = Map.Make (struct - type t = plugin_kind * name - let compare = Pervasives.compare - end) + 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; - } + { + 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 = { @@ -1430,10 +1801,10 @@ module OASISFeatures = struct 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} + 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 @@ -1442,17 +1813,17 @@ module OASISFeatures = struct Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" - (OASISVersion.string_of_version t.oasis_version) + (OASISVersion.string_of_version (t:t).oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ - (match ver_opt with - | Some v -> - " "^(OASISVersion.string_of_version v) - | None -> "")) + (match ver_opt with + | Some v -> + " "^(OASISVersion.string_of_version v) + | None -> "")) :: acc) t.plugin_versions [])) end @@ -1467,24 +1838,24 @@ module OASISFeatures = struct let string_of_stage = function - | Alpha -> "alpha" - | Beta -> "beta" + | Alpha -> "alpha" + | Beta -> "beta" let field_of_stage = function - | Alpha -> "AlphaFeatures" - | Beta -> "BetaFeatures" + | 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; - } + { + name: string; + plugin: all_plugin option; + publication: publication; + description: unit -> string; + } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 @@ -1498,35 +1869,35 @@ module OASISFeatures = struct let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" - t.name + (t:t).name (match t.plugin with - | None -> "<none>" - | Some (_, nm, _) -> nm) + | None -> "<none>" + | Some (_, nm, _) -> nm) (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) + | 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 + let has_feature = List.mem (t: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 + match (origin:origin) with + | Field (fld, where) -> + Some + (Printf.sprintf + (f_ "Field %s in %s is only available when feature %s \ + is in field %s.") + fld where t.name (field_of_stage stage)) + | Section sct -> + Some + (Printf.sprintf + (f_ "Section %s is only available when features %s \ + is in field %s.") + sct t.name (field_of_stage stage)) + | NoOrigin -> + Some no_message else None in @@ -1536,132 +1907,128 @@ module OASISFeatures = struct OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in - Printf.ksprintf - (fun str -> - if version_is_good then - None - else - Some str) - fmt + 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 + | _, _, 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 - 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 + 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 + | 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 - 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 + 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, 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 + | 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 + | None -> () + | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with - | None -> true - | Some str -> false + | None -> true + | Some _ -> false let package_test t pkg = @@ -1681,8 +2048,8 @@ module OASISFeatures = struct description = description; } in - Hashtbl.add all_features name t; - t + Hashtbl.add all_features name t; + t let get_stage name = @@ -1711,14 +2078,14 @@ module OASISFeatures = struct create "flag_docs" (since_version "0.3") (fun () -> - s_ "Building docs require '-docs' flag at configure.") + s_ "Make 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.") + s_ "Make running tests require '-tests' flag at configure.") let pack = @@ -1743,13 +2110,13 @@ module OASISFeatures = struct let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> - s_ "It compiles the setup.ml and speed-up actions done with it.") + s_ "Compile 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.") + s_ "Allow the OASIS section comments and digests to be omitted in \ + generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha @@ -1757,139 +2124,22 @@ module OASISFeatures = struct s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ that matches the internal heuristic (if a dependency ends with \ a .syntax or is a well known syntax).") -end - -module OASISUnixPath = struct -(* # 22 "src/oasis/OASISUnixPath.ml" *) - - - type unix_filename = string - type unix_dirname = string - - - type host_filename = string - type host_dirname = string - - - let current_dir_name = "." - - - let parent_dir_name = ".." - - - let is_current_dir fn = - fn = current_dir_name || fn = "" - - let concat f1 f2 = - if is_current_dir f1 then - f2 - else - let f1' = - try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 - in - f1'^"/"^f2 - - - let make = - function - | hd :: tl -> - List.fold_left - (fun f p -> concat f p) - hd - tl - | [] -> - invalid_arg "OASISUnixPath.make" - - - let dirname f = - try - String.sub f 0 (String.rindex f '/') - with Not_found -> - current_dir_name - - - let basename f = - try - let pos_start = - (String.rindex f '/') + 1 - in - String.sub f pos_start ((String.length f) - pos_start) - with Not_found -> - f - - - let chop_extension f = - try - let last_dot = - String.rindex f '.' - in - let sub = - String.sub f 0 last_dot - in - try - let last_slash = - String.rindex f '/' - in - if last_slash < last_dot then - sub - else - f - with Not_found -> - sub - - with Not_found -> - f - - - let capitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (OASISString.capitalize_ascii base) - - - let uncapitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (OASISString.uncapitalize_ascii base) - - -end - -module OASISHostPath = struct -(* # 22 "src/oasis/OASISHostPath.ml" *) - - - open Filename - - - 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 '/')) + let findlib_directory = + create "findlib_directory" beta + (fun () -> + s_ "Allow to install findlib libraries in sub-directories of the target \ + findlib directory.") + let findlib_extra_files = + create "findlib_extra_files" beta + (fun () -> + s_ "Allow to install extra files for findlib libraries.") + let source_patterns = + create "source_patterns" alpha + (fun () -> + s_ "Customize mapping between module name and source file.") end module OASISSection = struct @@ -1902,19 +2152,19 @@ module OASISSection = struct let section_kind_common = function | Library (cs, _, _) -> - `Library, cs + `Library, cs | Object (cs, _, _) -> - `Object, cs + `Object, cs | Executable (cs, _, _) -> - `Executable, cs + `Executable, cs | Flag (cs, _) -> - `Flag, cs + `Flag, cs | SrcRepo (cs, _) -> - `SrcRepo, cs + `SrcRepo, cs | Test (cs, _) -> - `Test, cs + `Test, cs | Doc (cs, _) -> - `Doc, cs + `Doc, cs let section_common sct = @@ -1933,27 +2183,28 @@ module OASISSection = struct (** Key used to identify section - *) + *) let section_id sct = let k, cs = section_kind_common sct in - k, cs.cs_name + k, cs.cs_name + + + let string_of_section_kind = + function + | `Library -> "library" + | `Object -> "object" + | `Executable -> "executable" + | `Flag -> "flag" + | `SrcRepo -> "src repository" + | `Test -> "test" + | `Doc -> "doc" let string_of_section sct = - let k, nm = - section_id sct - in - (match k with - | `Library -> "library" - | `Object -> "object" - | `Executable -> "executable" - | `Flag -> "flag" - | `SrcRepo -> "src repository" - | `Test -> "test" - | `Doc -> "doc") - ^" "^nm + let k, nm = section_id sct in + (string_of_section_kind k)^" "^nm let section_find id scts = @@ -1988,6 +2239,32 @@ end module OASISBuildSection = struct (* # 22 "src/oasis/OASISBuildSection.ml" *) + open OASISTypes + + (* Look for a module file, considering capitalization or not. *) + let find_module source_file_exists bs modul = + let possible_lst = + OASISSourcePatterns.all_possible_files + (bs.bs_interface_patterns @ bs.bs_implementation_patterns) + ~path:bs.bs_path + ~modul + in + match List.filter source_file_exists possible_lst with + | (fn :: _) as fn_lst -> `Sources (OASISUnixPath.chop_extension fn, fn_lst) + | [] -> + let open OASISUtils in + let _, rev_lst = + List.fold_left + (fun (set, acc) fn -> + let base_fn = OASISUnixPath.chop_extension fn in + if SetString.mem base_fn set then + set, acc + else + SetString.add base_fn set, base_fn :: acc) + (SetString.empty, []) possible_lst + in + `No_sources (List.rev rev_lst) + end @@ -2011,16 +2288,16 @@ module OASISExecutable = struct | Byte -> false in - OASISUnixPath.concat - dir - (cs.cs_name^(suffix_program ())), + 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 + 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 @@ -2030,99 +2307,57 @@ module OASISLibrary = struct 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 find_module ~ctxt source_file_exists cs bs modul = + match OASISBuildSection.find_module source_file_exists bs modul with + | `Sources _ as res -> res + | `No_sources _ as res -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching module '%s' in library %s.") + modul cs.cs_name; + OASISMessage.warning + ~ctxt + (f_ "Use InterfacePatterns or ImplementationPatterns to define \ + this file with feature %S.") + (OASISFeatures.source_patterns.OASISFeatures.name); + res let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> - match find_module 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) + match find_module ~ctxt source_file_exists cs bs modul with + | `Sources (base_fn, lst) -> (base_fn, lst) :: acc + | `No_sources _ -> acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files - ~ctxt - ~is_native - ~has_native_dynlink - ~ext_lib - ~ext_dll - ~source_file_exists - (cs, bs, lib) = + ~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 + match find_module ~ctxt source_file_exists cs bs modul with + | `Sources (_, [fn]) when ext <> "cmi" + && Filename.check_suffix fn ".mli" -> + None (* No implementation files for pure interface. *) + | `Sources (base_fn, _) -> Some [base_fn] + | `No_sources lst -> Some lst in List.fold_left (fun acc nm -> - match find_module nm with - | None -> acc - | Some base_fns -> - List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) + match find_module nm with + | None -> acc + | Some base_fns -> + List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in @@ -2131,21 +2366,21 @@ module OASISLibrary = struct let cmxs = let should_be_built = match bs.bs_compiled_object with - | Native -> true - | Best -> is_native - | Byte -> false + | 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" + 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 = @@ -2160,15 +2395,12 @@ module OASISLibrary = struct else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map - begin - List.fold_left - begin fun accu s -> + (List.fold_left + (fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in - List.map ((^) base) sufx @ accu - end - [] - end + List.map ((^) base) sufx @ accu) + []) (find_modules lib.lib_modules "cmi") in @@ -2191,38 +2423,35 @@ module OASISLibrary = struct [cs.cs_name^".cmxs"] :: acc else acc) in - [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc + [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 + 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] - :: + if bs.bs_c_sources <> [] then begin + ["lib"^cs.cs_name^"_stubs"^ext_lib] + :: + if has_native_dynlink then + ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath + else acc_nopath - end - else + end else begin acc_nopath + end in - (* All the files generated *) - List.rev_append - (List.rev_map - (List.rev_map - (OASISUnixPath.concat bs.bs_path)) - acc_nopath) - (headers @ cmxs) + (* All the files generated *) + List.rev_append + (List.rev_map + (List.rev_map + (OASISUnixPath.concat bs.bs_path)) + acc_nopath) + (headers @ cmxs) end @@ -2235,62 +2464,64 @@ module OASISObject = struct open OASISGettext + let find_module ~ctxt source_file_exists cs bs modul = + match OASISBuildSection.find_module source_file_exists bs modul with + | `Sources _ as res -> res + | `No_sources _ as res -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching module '%s' in object %s.") + modul cs.cs_name; + OASISMessage.warning + ~ctxt + (f_ "Use InterfacePatterns or ImplementationPatterns to define \ + this file with feature %S.") + (OASISFeatures.source_patterns.OASISFeatures.name); + res + let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> - match 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) + match find_module ~ctxt source_file_exists cs bs modul with + | `Sources (base_fn, lst) -> (base_fn, lst) :: acc + | `No_sources _ -> acc) [] obj.obj_modules let generated_unix_files - ~ctxt - ~is_native - ~source_file_exists - (cs, bs, obj) = + ~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 + match find_module ~ctxt source_file_exists cs bs modul with + | `Sources (base_fn, _) -> [base_fn ^ ext] + | `No_sources lst -> lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, - find_module ".cmo" m, - find_module ".cmx" m, - find_module ".o" m, - fun x -> x) + 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) + [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 :: []) + 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 @@ -2302,7 +2533,6 @@ module OASISFindlib = struct open OASISTypes open OASISUtils open OASISGettext - open OASISSection type library_name = name @@ -2320,12 +2550,13 @@ module OASISFindlib = struct common_section * build_section * [`Library of library | `Object of object_] * + unix_dirname option * group_t list) type data = common_section * - build_section * - [`Library of library | `Object of object_] + build_section * + [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data @@ -2343,53 +2574,53 @@ module OASISFindlib = struct let name = String.concat "." (lib.lib_findlib_containers @ [name]) in - name + 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 + 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 - obj_name - (`Solved findlib_full_name) + lib_name + (`Unsolved (lib_name_parent, fndlb_parts)) mp - end + | None -> + MapString.add + lib_name + (`Solved fndlb_parts) + mp + end - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> - mp) - MapString.empty - pkg.sections + | 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. *) @@ -2401,40 +2632,40 @@ module OASISFindlib = struct 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 + 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 + (* Solved initialy, no need to go further *) + mp | `Unsolved _ -> - let _, mp = solve SetString.empty mp lib_name "<none>" in - mp) + let _, mp = solve SetString.empty mp lib_name "<none>" 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 + MapString.map + (function + | `Solved fndlb_nm -> fndlb_nm + | `Unsolved _ -> assert false) + mp in (* Convert an internal library name to a findlib name. *) @@ -2446,75 +2677,89 @@ module OASISFindlib = struct 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 + 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 + 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 + (* 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) + 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 + (* 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 (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> - Node (data_opt, add_children tl children) + Node (data_opt, add_children tl children) end and new_node = function | [] -> - Leaf sct + Leaf sct | hd :: tl -> - Node (None, MapString.add hd (new_node tl) MapString.empty) + Node (None, MapString.add hd (new_node tl) MapString.empty) + in + add_children (OASISString.nsplit fndlb_fullname '.') mp + in + + let unix_directory dn lib = + let directory = + match lib with + | `Library lib -> lib.lib_findlib_directory + | `Object obj -> obj.obj_findlib_directory in - add_children (OASISString.nsplit fndlb_fullname '.') mp + match dn, directory with + | None, None -> None + | None, Some dn | Some dn, None -> Some dn + | Some dn1, Some dn2 -> Some (OASISUnixPath.concat dn1 dn2) in - let rec group_of_tree mp = + let rec group_of_tree dn 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, []) + | Node (Some (cs, bs, lib), children) -> + let current_dn = unix_directory dn lib in + Package (nm, cs, bs, lib, current_dn, group_of_tree current_dn children) + | Node (None, children) -> + Container (nm, group_of_tree dn children) + | Leaf (cs, bs, lib) -> + let current_dn = unix_directory dn lib in + Package (nm, cs, bs, lib, current_dn, []) in - cur :: acc) + cur :: acc) mp [] in @@ -2523,18 +2768,16 @@ module OASISFindlib = struct (fun mp -> function | Library (cs, bs, lib) -> - add (cs, bs, `Library lib) mp + add (cs, bs, `Library lib) mp | Object (cs, bs, obj) -> - add (cs, bs, `Object obj) mp + add (cs, bs, `Object obj) mp | _ -> - mp) + mp) MapString.empty pkg.sections in - let groups = - group_of_tree group_mp - in + let groups = group_of_tree None group_mp in let library_name_of_findlib_name = lazy begin @@ -2552,15 +2795,15 @@ module OASISFindlib = struct raise (FindlibPackageNotFound fndlb_nm) in - groups, - findlib_name_of_library_name, - library_name_of_findlib_name + groups, + findlib_name_of_library_name, + library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) - | Package (fndlb_nm, _, _, _, _) -> fndlb_nm + | Package (fndlb_nm, _, _, _, _, _) -> fndlb_nm let root_of_group grp = @@ -2568,24 +2811,24 @@ module OASISFindlib = struct (* 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) + 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) + 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 @@ -2631,7 +2874,7 @@ module OASISExec = struct (* 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 @@ -2649,57 +2892,57 @@ module OASISExec = struct 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 + 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 + 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 - 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 + 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 + fst | lst -> - failwithf - (f_ "Command return unexpected output %S") - (String.concat "\n" lst) + failwithf + (f_ "Command return unexpected output %S") + (String.concat "\n" lst) end module OASISFileUtil = struct @@ -2712,15 +2955,15 @@ module OASISFileUtil = struct 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)) + if Sys.file_exists dirname then + if basename = Filename.current_dir_name then + true else - false + List.mem + basename + (Array.to_list (Sys.readdir dirname)) + else + false let find_file ?(case_sensitive=true) paths exts = @@ -2739,16 +2982,16 @@ module OASISFileUtil = struct 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) + let acc = + (List.map + (fun (a, b) -> Filename.concat a b) + (p1 * p2)) + in + combined_paths (acc :: tl) | [e] -> - e + e | [] -> - [] + [] in let alternatives = @@ -2760,46 +3003,46 @@ module OASISFileUtil = struct 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 + 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) + "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> - [""] + [""] in - find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + 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 + 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 @@ -2810,24 +3053,24 @@ module OASISFileUtil = struct if recurse then match Sys.os_type with | "Win32" -> - OASISExec.run ~ctxt - "xcopy" [q src; q tgt; "/E"] + OASISExec.run ~ctxt + "xcopy" [q src; q tgt; "/E"] | _ -> - OASISExec.run ~ctxt - "cp" ["-r"; q src; q tgt] + OASISExec.run ~ctxt + "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with - | "Win32" -> "copy" - | _ -> "cp") + | "Win32" -> "copy" + | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with - | "Win32" -> "md" - | _ -> "mkdir") + | "Win32" -> "md" + | _ -> "mkdir") [q tgt] @@ -2835,32 +3078,32 @@ module OASISFileUtil = struct 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 + 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 "rd" [q tgt] | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] + OASISExec.run ~ctxt "rm" ["-r"; q tgt] end else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") @@ -2869,51 +3112,51 @@ module OASISFileUtil = struct 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 + 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 -# 2916 "setup.ml" +# 3159 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -2924,101 +3167,76 @@ module BaseEnvLight = struct type t = string MapString.t - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" + 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 + let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = + let line = ref 1 in + let lexer st = + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + Genlex.make_lexer ["="] st_line + in + let rec read_file lxr mp = + match Stream.npeek 3 lxr with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; + read_file lxr (MapString.add nm value mp) + | [] -> mp + | _ -> + failwith + (Printf.sprintf "Malformed data file '%s' line %d" filename !line) + in + match stream with + | Some st -> read_file (lexer st) MapString.empty + | None -> + if Sys.file_exists filename then begin + let chn = open_in_bin filename in + let st = Stream.of_channel chn in + try + let mp = read_file (lexer st) MapString.empty in + close_in chn; mp + with e -> + close_in chn; raise e + end else if allow_empty then begin MapString.empty - end - else - begin + 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 + 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 -# 3021 "setup.ml" +# 3239 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -3039,7 +3257,7 @@ module BaseMessage = struct (** Message to user, overrid for Base @author Sylvain Le Gall - *) + *) open OASISMessage open BaseContext @@ -3062,6 +3280,7 @@ module BaseEnv = struct open OASISGettext open OASISUtils + open OASISContext open PropList @@ -3084,83 +3303,79 @@ module BaseEnv = struct type definition_t = - { - hide: bool; - dump: bool; - cli: cli_handle_t; - arg_help: string option; - group: string option; - } + { + hide: bool; + dump: bool; + cli: cli_handle_t; + arg_help: string option; + group: string option; + } - let schema = - Schema.create "environment" + let schema = Schema.create "environment" (* Environment data *) - let env = - Data.create () + let env = Data.create () (* Environment data from file *) - let env_from_file = - ref MapString.empty + let env_from_file = ref MapString.empty (* Lexer for var *) - let var_lxr = - Genlex.make_lexer [] + 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 + 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 = @@ -3175,7 +3390,7 @@ module BaseEnv = struct raise e end in - var_expand vl + var_expand vl let var_choose ?printer ?name lst = @@ -3190,24 +3405,24 @@ module BaseEnv = struct 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 + 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 = + ?(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 = [ @@ -3228,22 +3443,22 @@ module BaseEnv = struct 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) -> + (fun (errors, res) (_, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> - errors, res + errors, res | Failure rsn -> - (rsn :: errors), res + (rsn :: errors), res | e -> - (Printexc.to_string e) :: errors, res + (Printexc.to_string e) :: errors, res end else errors, res) @@ -3253,13 +3468,13 @@ module BaseEnv = struct 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))) + 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 = @@ -3275,24 +3490,24 @@ module BaseEnv = struct ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default - ~update:(fun ?context x old_x -> x @ old_x) + ~update:(fun ?context:_ x old_x -> x @ old_x) ?help extra in - fun () -> - var_expand (var_get_low (var_get_lst env)) + fun () -> + var_expand (var_get_low (var_get_lst env)) let var_redefine - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt = + ?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 () *) @@ -3313,7 +3528,7 @@ module BaseEnv = struct end - let var_ignore (e: unit -> string) = () + let var_ignore (_: unit -> string) = () let print_hidden = @@ -3338,12 +3553,34 @@ module BaseEnv = struct schema) - let default_filename = - BaseEnvLight.default_filename - - - let load ?allow_empty ?filename () = - env_from_file := BaseEnvLight.load ?allow_empty ?filename () + let default_filename = in_srcdir "setup.data" + + + let load ~ctxt ?(allow_empty=false) ?(filename=default_filename) () = + let open OASISFileSystem in + env_from_file := + let repr_filename = ctxt.srcfs#string_of_filename filename in + if ctxt.srcfs#file_exists filename then begin + let buf = Buffer.create 13 in + defer_close + (ctxt.srcfs#open_in ~mode:binary_in filename) + (read_all buf); + defer_close + (ctxt.srcfs#open_in ~mode:binary_in filename) + (fun rdr -> + OASISMessage.info ~ctxt "Loading environment from %S." repr_filename; + BaseEnvLight.load ~allow_empty + ~filename:(repr_filename) + ~stream:(stream_of_reader rdr) + ()) + end else if allow_empty then begin + BaseEnvLight.MapString.empty + end else begin + failwith + (Printf.sprintf + (f_ "Unable to load environment, the file '%s' doesn't exist.") + repr_filename) + end let unload () = @@ -3351,40 +3588,32 @@ module BaseEnv = struct 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 dump ~ctxt ?(filename=default_filename) () = + let open OASISFileSystem in + defer_close + (ctxt.OASISContext.srcfs#open_out ~mode:binary_out filename) + (fun wrtr -> + let buf = Buffer.create 63 in + let output nm value = + Buffer.add_string buf (Printf.sprintf "%s=%S\n" nm value) + in + let mp_todo = + (* Dump data from schema *) + Schema.fold + (fun mp_todo nm def _ -> + if def.dump then begin + try + output nm (Schema.get schema env nm) + with Not_set _ -> + () + end; + MapString.remove nm mp_todo) + !env_from_file + schema + in + (* Dump data defined outside of schema *) + MapString.iter output mp_todo; + wrtr#output buf) let print () = let printable_vars = @@ -3393,20 +3622,15 @@ module BaseEnv = struct if not def.hide || bool_of_string (print_hidden ()) then begin try - let value = - Schema.get - schema - env - nm - in + let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in - (txt, value) :: acc + (txt, value) :: acc with Not_set _ -> - acc + acc end else acc) @@ -3418,123 +3642,122 @@ module BaseEnv = struct (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"; + 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) + Printf.printf "%s: %s" name (dot_pad name); + if value = "" then + Printf.printf "\n" + else + Printf.printf " %s\n" value) (List.rev printable_vars); Printf.printf "\n%!" let args () = - let arg_concat = - OASISUtils.varname_concat ~hyphen:'-' - in - [ - "--override", - Arg.Tuple - ( - let rvr = ref "" - in - let rvl = ref "" - in - [ - Arg.Set_string rvr; - Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set - schema - env - ~context:OCommandLine - !rvr - !rvl) - ] - ), - "var+val Override any configuration variable."; + 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 + (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 arg_name = + OASISUtils.varname_of_string ~hyphen:'-' name + in - let hlp = - match short_descr_opt with - | Some txt -> txt () - | None -> "" - 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 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 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) + 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 @@ -3548,25 +3771,25 @@ module BaseArgExt = struct let parse argv args = - (* Simulate command line for Arg *) - let current = - ref 0 - in + (* 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 + 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 @@ -3588,18 +3811,18 @@ module BaseCheck = struct (fun res e -> match res with | Some _ -> - res + res | None -> - try - Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) - with Not_found -> - 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) + match alternate with + | Some prg -> prg + | None -> raise Not_found) let prog prg = @@ -3615,45 +3838,45 @@ module BaseCheck = struct let version - var_prefix - cmp - fversion - () = + 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) - () + 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 = @@ -3674,13 +3897,13 @@ module BaseCheck = struct (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 + 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 @@ -3688,19 +3911,19 @@ module BaseCheck = struct (fun () -> findlib_dir pkg) () in - ( - match version_comparator with - | Some ver_cmp -> - ignore - (version - var - ver_cmp - (fun _ -> package_version pkg) - ()) - | None -> - () - ); - vl + ( + match version_comparator with + | Some ver_cmp -> + ignore + (version + var + ver_cmp + (fun _ -> package_version pkg) + ()) + | None -> + () + ); + vl end module BaseOCamlcConfig = struct @@ -3722,46 +3945,46 @@ module BaseOCamlcConfig = struct 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 -> + 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 ) - in - split_field mp tl + with Not_found -> + ( + mp + ) + in + split_field mp tl | [] -> - mp + mp in let cache = @@ -3775,13 +3998,13 @@ module BaseOCamlcConfig = struct (ocamlc ()) ["-config"])) [])) in - var_redefine - "ocamlc_config_map" - ~hide:true - ~dump:false - (fun () -> - (* TODO: update if ocamlc change !!! *) - Lazy.force cache) + var_redefine + "ocamlc_config_map" + ~hide:true + ~dump:false + (fun () -> + (* TODO: update if ocamlc change !!! *) + Lazy.force cache) let var_define nm = @@ -3796,30 +4019,30 @@ module BaseOCamlcConfig = struct String.sub s 0 (String.index s '+') with _ -> s - in + in let nm_config, value_config = match nm with | "ocaml_version" -> - "version", chop_version_suffix + "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 ())) + 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 @@ -3829,7 +4052,6 @@ module BaseStandardVar = struct open OASISGettext open OASISTypes - open OASISExpr open BaseCheck open BaseEnv @@ -3859,11 +4081,11 @@ module BaseStandardVar = struct let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in - var_cond := + var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; - fun () -> !holder () + fun () -> !holder () (**/**) @@ -3924,11 +4146,11 @@ module BaseStandardVar = struct 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) + match lst with + | line :: _ -> + Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) + | [] -> + raise Not_found) (**/**) @@ -3944,7 +4166,7 @@ module BaseStandardVar = struct let (/) a b = if os_type () = Sys.os_type then Filename.concat a b - else if os_type () = "Unix" then + else if os_type () = "Unix" || os_type () = "Cygwin" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") @@ -3958,12 +4180,12 @@ module BaseStandardVar = struct (fun () -> match os_type () with | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) | _ -> - "/usr/local") + "/usr/local") let exec_prefix = @@ -4099,12 +4321,12 @@ module BaseStandardVar = struct let _s: string = ocamlopt () in - "true" + "true" with PropList.Not_set _ -> let _s: string = ocamlc () in - "false") + "false") let ext_program = @@ -4157,7 +4379,7 @@ module BaseStandardVar = struct (fun () -> var_define ~short_desc:(fun () -> - s_ "Compile tests executable and library and run them") + s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) @@ -4196,35 +4418,35 @@ module BaseStandardVar = struct 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 + 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 - else if ocaml_lt_312 () then + 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 - 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 + end + else + true in - string_of_bool res) + string_of_bool res) let init pkg = @@ -4240,48 +4462,29 @@ module BaseFileAB = struct open BaseEnv open OASISGettext open BaseMessage + open OASISContext 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 + if not (Filename.check_suffix fn ".ab") then + warning (f_ "File '%s' doesn't have '.ab' extension") fn; + OASISFileSystem.of_unix_filename (Filename.chop_extension fn) - let replace 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 + let replace ~ctxt fn_lst = + let open OASISFileSystem in + let ibuf, obuf = Buffer.create 13, Buffer.create 13 in + List.iter + (fun fn -> + Buffer.clear ibuf; Buffer.clear obuf; + defer_close + (ctxt.srcfs#open_in (of_unix_filename fn)) + (read_all ibuf); + Buffer.add_string obuf (var_expand (Buffer.contents ibuf)); + defer_close + (ctxt.srcfs#open_out (to_filename fn)) + (fun wrtr -> wrtr#output obuf)) + fn_lst end module BaseLog = struct @@ -4289,126 +4492,92 @@ module BaseLog = struct open OASISUtils + open OASISContext + open OASISGettext + open OASISFileSystem - let default_filename = - Filename.concat - (Filename.dirname BaseEnv.default_filename) - "setup.log" - + let default_filename = in_srcdir "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 load ~ctxt () = + let module SetTupleString = + Set.Make + (struct + type t = string * string + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with + | 0 -> String.compare s12 s22 + | n -> n + end) + in + if ctxt.srcfs#file_exists default_filename then begin + defer_close + (ctxt.srcfs#open_in default_filename) + (fun rdr -> + let line = ref 1 in + let lxr = Genlex.make_lexer [] (stream_of_reader rdr) in + let rec read_aux (st, lst) = + match Stream.npeek 2 lxr with + | [Genlex.String e; Genlex.String d] -> + let t = e, d in + Stream.junk lxr; Stream.junk lxr; + if SetTupleString.mem t st then + read_aux (st, lst) + else + read_aux (SetTupleString.add t st, t :: lst) + | [] -> List.rev lst + | _ -> + failwithf + (f_ "Malformed log file '%s' at line %d") + (ctxt.srcfs#string_of_filename default_filename) + !line + in + read_aux (SetTupleString.empty, [])) + end else begin + [] + end - let register 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 register ~ctxt event data = + defer_close + (ctxt.srcfs#open_out + ~mode:[Open_append; Open_creat; Open_text] + ~perm:0o644 + default_filename) + (fun wrtr -> + let buf = Buffer.create 13 in + Printf.bprintf buf "%S %S\n" event data; + wrtr#output buf) - let unregister 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 unregister ~ctxt event data = + let lst = load ~ctxt () in + let buf = Buffer.create 13 in + List.iter + (fun (e, d) -> + if e <> event || d <> data then + Printf.bprintf buf "%S %S\n" e d) + lst; + if Buffer.length buf > 0 then + defer_close + (ctxt.srcfs#open_out default_filename) + (fun wrtr -> wrtr#output buf) + else + ctxt.srcfs#remove default_filename - let filter 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 filter ~ctxt events = + let st_events = SetString.of_list events in + List.filter + (fun (e, _) -> SetString.mem e st_events) + (load ~ctxt ()) - let exists event data = + let exists ~ctxt event data = List.exists (fun v -> (event, data) = v) - (load ()) + (load ~ctxt ()) end module BaseBuilt = struct @@ -4431,100 +4600,81 @@ module BaseBuilt = struct let to_log_event_file t nm = "built_"^ - (match t with - | BExec -> "exec" - | BExecLib -> "exec_lib" - | BLib -> "lib" - | BObj -> "obj" - | BDoc -> "doc")^ - "_"^nm + (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"; + let register ~ctxt t nm lst = + BaseLog.register ~ctxt (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> - if OASISFileUtil.file_exists_case fn then - begin - BaseLog.register - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end - else - registered) + if OASISFileUtil.file_exists_case fn then begin + BaseLog.register ~ctxt + (to_log_event_file t nm) + (if Filename.is_relative fn then + Filename.concat (Sys.getcwd ()) fn + else + fn); + true + end else begin + registered + end) false alt in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) + if not registered then + warning + (f_ "Cannot find an existing alternative files among: %s") + (String.concat (s_ ", ") alt)) lst - let unregister t nm = + let unregister ~ctxt 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]) + (fun (e, d) -> BaseLog.unregister ~ctxt e d) + (BaseLog.filter ~ctxt [to_log_event_file t nm; to_log_event_done t nm]) - let fold t nm f acc = + let fold ~ctxt t nm f acc = List.fold_left (fun acc (_, fn) -> - if OASISFileUtil.file_exists_case fn then - begin - f acc fn - end - else - begin - warning - (f_ "File '%s' has been marked as built \ + 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) + 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]) + (BaseLog.filter ~ctxt [to_log_event_file t nm]) - let is_built t nm = + let is_built ~ctxt t nm = List.fold_left - (fun is_built (_, d) -> - (try - bool_of_string d - with _ -> - false)) + (fun _ (_, d) -> try bool_of_string d with _ -> false) false - (BaseLog.filter - [to_log_event_done t nm]) + (BaseLog.filter ~ctxt [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = @@ -4540,15 +4690,15 @@ module BaseBuilt = struct let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: - (match unix_dll_opt with - | Some fn -> - [BExecLib, cs.cs_name, [[ffn fn]]] - | None -> - []) + (match unix_dll_opt with + | Some fn -> + [BExecLib, cs.cs_name, [[ffn fn]]] + | None -> + []) in - evs, - unix_exec_is, - unix_dll_opt + evs, + unix_exec_is, + unix_dll_opt let of_library ffn (cs, bs, lib) = @@ -4556,7 +4706,7 @@ module BaseBuilt = struct OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix 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 ()) @@ -4568,7 +4718,7 @@ module BaseBuilt = struct cs.cs_name, List.map (List.map ffn) unix_lst] in - evs, unix_lst + evs, unix_lst let of_object ffn (cs, bs, obj) = @@ -4576,7 +4726,7 @@ module BaseBuilt = struct OASISObject.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) (cs, bs, obj) in @@ -4585,7 +4735,7 @@ module BaseBuilt = struct cs.cs_name, List.map (List.map ffn) unix_lst] in - evs, unix_lst + evs, unix_lst end @@ -4614,32 +4764,32 @@ module BaseCustom = struct | 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 -> - () + 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 + optional_command cstm.post_command; + res end module BaseDynVar = struct @@ -4652,41 +4802,38 @@ module BaseDynVar = struct open BaseBuilt - let init pkg = + let init ~ctxt pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function - | Executable (cs, bs, 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 _ -> - ()) + | Executable (cs, bs, _) -> + if var_choose bs.bs_build then + var_ignore + (var_redefine + (* We don't save this variable *) + ~dump:false + ~short_desc:(fun () -> + Printf.sprintf + (f_ "Filename of executable '%s'") + cs.cs_name) + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + let fn_opt = + fold ~ctxt BExec cs.cs_name (fun _ fn -> Some fn) None + in + match fn_opt with + | Some fn -> fn + | None -> + raise + (PropList.Not_set + (cs.cs_name, + Some (Printf.sprintf + (f_ "Executable '%s' not yet built.") + cs.cs_name))))) + + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + ()) pkg.sections end @@ -4697,53 +4844,48 @@ module BaseTest = struct open BaseEnv open BaseMessage open OASISTypes - open OASISExpr open OASISGettext - let test lst pkg extra_args = + let test ~ctxt lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose - ~name:(Printf.sprintf - (f_ "test %s run") - cs.cs_name) - ~printer:string_of_bool - test.test_run then + ~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 () = 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 + 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 () -> () + 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 + try + let failure_percent = + BaseCustom.hook + test.test_custom + (test_plugin ~ctxt pkg (cs, test)) + extra_args + in + back_cwd (); + (failure_percent +. failure, n + 1) + with e -> + begin + back_cwd (); + raise e + end end else begin @@ -4751,35 +4893,25 @@ module BaseTest = struct (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 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'" + 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 @@ -4792,74 +4924,79 @@ module BaseDoc = struct open OASISGettext - let doc lst pkg extra_args = + let doc ~ctxt lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") - cs.cs_name) - ~printer:string_of_bool - doc.doc_build then + ~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)) + (doc_plugin ~ctxt pkg (cs, doc)) extra_args end in - List.iter one_doc lst; - - if OASISFeatures.package_test OASISFeatures.flag_docs pkg && - not (bool_of_string (BaseStandardVar.docs ())) && - lst <> [] then - BaseMessage.warning - "Docs are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-docs'" + List.iter one_doc lst; + + if OASISFeatures.package_test OASISFeatures.flag_docs pkg && + not (bool_of_string (BaseStandardVar.docs ())) && + lst <> [] then + BaseMessage.warning + "Docs are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 22 "src/base/BaseSetup.ml" *) + open OASISContext open BaseEnv open BaseMessage open OASISTypes - open OASISSection open OASISGettext open OASISUtils type std_args_fun = - package -> string array -> unit + ctxt:OASISContext.t -> package -> string array -> unit type ('a, 'b) section_args_fun = - name * (package -> (common_section * 'a) -> string array -> 'b) + name * + (ctxt:OASISContext.t -> + package -> + (common_section * 'a) -> + string array -> + 'b) type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } + { + 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 *) @@ -4869,9 +5006,9 @@ module BaseSetup = struct (fun acc sct -> match filter_map sct with | Some e -> - e :: acc + e :: acc | None -> - acc) + acc) [] lst) @@ -4888,7 +5025,7 @@ module BaseSetup = struct action - let configure t args = + let configure ~ctxt t args = (* Run configure *) BaseCustom.hook t.package.conf_custom @@ -4897,154 +5034,137 @@ module BaseSetup = struct begin try unload (); - load (); + load ~ctxt (); with _ -> () end; (* Run plugin's configure *) - t.configure t.package args; + t.configure ~ctxt t.package args; (* Dump to allow postconf to change it *) - dump ()) + dump ~ctxt ()) (); (* Reload environment *) unload (); - load (); + load ~ctxt (); (* Save environment *) print (); (* Replace data in file *) - BaseFileAB.replace t.package.files_ab + BaseFileAB.replace ~ctxt t.package.files_ab - let build t args = + let build ~ctxt t args = BaseCustom.hook t.package.build_custom - (t.build t.package) + (t.build ~ctxt t.package) args - let doc t args = + let doc ~ctxt t args = BaseDoc.doc + ~ctxt (join_plugin_sections (function - | Doc (cs, e) -> - Some - (lookup_plugin_section - "documentation" - (s_ "build") - cs.cs_name - t.doc, - cs, - e) - | _ -> - None) + | 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 = + let test ~ctxt t args = BaseTest.test + ~ctxt (join_plugin_sections (function - | Test (cs, e) -> - Some - (lookup_plugin_section - "test" - (s_ "run") - cs.cs_name - t.test, - cs, - e) - | _ -> - None) + | 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") :: + let all ~ctxt t args = + let rno_doc = ref false in + let rno_test = ref false in + let arg_rest = ref [] in + Arg.parse_argv + ~current:(ref 0) + (Array.of_list + ((Sys.executable_name^" all") :: (Array.to_list args))) - [ - "-no-doc", - Arg.Set rno_doc, - s_ "Don't run doc target"; - - "-no-test", - Arg.Set rno_test, - s_ "Don't run test target"; + [ + "-no-doc", + Arg.Set rno_doc, + s_ "Don't run doc 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'")) - ""; + "-no-test", + Arg.Set rno_test, + s_ "Don't run test target"; - info "Running configure step"; - configure t (Array.of_list (List.rev !arg_rest)); + "--", + 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 build step"; - build t [||]; + info "Running configure step"; + configure ~ctxt t (Array.of_list (List.rev !arg_rest)); - (* Load setup.log dynamic variables *) - BaseDynVar.init t.package; + info "Running build step"; + build ~ctxt t [||]; - if not !rno_doc then - begin - info "Running doc step"; - doc t [||]; - end - else - begin - info "Skipping doc step" - end; + (* Load setup.log dynamic variables *) + BaseDynVar.init ~ctxt t.package; - if not !rno_test then - begin - info "Running test step"; - test t [||] - end - else - begin - info "Skipping test step" - end + if not !rno_doc then begin + info "Running doc step"; + doc ~ctxt t [||] + end else begin + info "Skipping doc step" + end; + if not !rno_test then begin + info "Running test step"; + test ~ctxt t [||] + end else begin + info "Skipping test step" + end - let install t args = - BaseCustom.hook - t.package.install_custom - (t.install t.package) - args + let install ~ctxt t args = + BaseCustom.hook t.package.install_custom (t.install ~ctxt t.package) args - let uninstall t args = - BaseCustom.hook - t.package.uninstall_custom - (t.uninstall t.package) - args + let uninstall ~ctxt t args = + BaseCustom.hook t.package.uninstall_custom (t.uninstall ~ctxt t.package) args - let reinstall t args = - uninstall t args; - install t args + let reinstall ~ctxt t args = + uninstall ~ctxt t args; + install ~ctxt t args let clean, distclean = @@ -5055,11 +5175,11 @@ module BaseSetup = struct warning (f_ "Action fail with error: %s") (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) + | Failure msg -> msg + | e -> Printexc.to_string e) in - let generic_clean t cstm mains docs tests args = + let generic_clean ~ctxt t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm @@ -5067,45 +5187,32 @@ module BaseSetup = struct (* 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 _ -> - ()) + | Test (cs, test) -> + let f = + try + List.assoc cs.cs_name tests + with Not_found -> + fun ~ctxt:_ _ _ _ -> () + in + failsafe (f ~ctxt t.package (cs, test)) args + | Doc (cs, doc) -> + let f = + try + List.assoc cs.cs_name docs + with Not_found -> + fun ~ctxt:_ _ _ _ -> () + in + failsafe (f ~ctxt t.package (cs, doc)) args + | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) - List.iter - (fun f -> - failsafe - (f t.package) - args) - mains) + List.iter (fun f -> failsafe (f ~ctxt t.package) args) mains) () in - let clean t args = + let clean ~ctxt t args = generic_clean + ~ctxt t t.package.clean_custom t.clean @@ -5114,12 +5221,13 @@ module BaseSetup = struct args in - let distclean t args = + let distclean ~ctxt t args = (* Call clean *) - clean t args; + clean ~ctxt t args; (* Call distclean code *) generic_clean + ~ctxt t t.package.distclean_custom t.distclean @@ -5127,36 +5235,31 @@ module BaseSetup = struct t.distclean_test args; - (* Remove generated file *) + (* Remove generated source files. *) 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)) + if ctxt.srcfs#file_exists fn then begin + info (f_ "Remove '%s'") (ctxt.srcfs#string_of_filename fn); + ctxt.srcfs#remove fn + end) + ([BaseEnv.default_filename; BaseLog.default_filename] + @ (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in - clean, distclean + clean, distclean - let version t _ = - print_endline t.oasis_version + let version ~ctxt:_ (t: t) _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in - b, - ("-no-update-setup-ml", - Arg.Clear b, - s_ " Don't try to update setup.ml, even if _oasis has changed.") - + b, + ("-no-update-setup-ml", + Arg.Clear b, + s_ " Don't try to update setup.ml, even if _oasis has changed.") + (* TODO: srcfs *) let default_oasis_fn = "_oasis" @@ -5177,16 +5280,16 @@ module BaseSetup = struct let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> - setup_ml, args + setup_ml, args | [] -> - failwith - (s_ "Expecting non-empty command line arguments.") + 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 @@ -5197,64 +5300,62 @@ module BaseSetup = struct 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) + (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 + if OASISVersion.comparator_apply + (OASISVersion.version_of_string oasis_exec_version) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string t.oasis_version)) then + begin + (* We have a version >= for the executable oasis, proceed with + * update. + *) + (* TODO: delegate this check to 'oasis setup'. *) + if Sys.os_type = "Win32" then + failwithf + (f_ "It is not possible to update the running script \ + setup.ml on Windows. Please update setup.ml by \ + running '%s'.") + (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) + else + begin + OASISExec.run + ~ctxt:!BaseContext.default + ~f_exit_code: + (fun n -> + if n <> 0 then + failwithf + (f_ "Unable to update setup.ml using '%s', \ + please fix the problem and retry.") + oasis_exec) + oasis_exec ("setup" :: t.oasis_setup_args); + OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) + end + end + else + failwithf + (f_ "The version of '%s' (v%s) doesn't match the version of \ + oasis used to generate the %s file. Please install at \ + least oasis v%s.") + oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then @@ -5271,7 +5372,7 @@ module BaseSetup = struct else false | None -> - false + false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ @@ -5285,158 +5386,287 @@ module BaseSetup = struct 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 + let catch_exn = ref true in + let act_ref = + ref (fun ~ctxt:_ _ -> + failwithf + (f_ "No action defined, run '%s %s -help'") + Sys.executable_name + Sys.argv.(0)) - 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."; - ] - @ + in + let extra_args_ref = ref [] in + let allow_empty_env_ref = ref false in + let arg_handle ?(allow_empty_env=false) act = + Arg.Tuple + [ + Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); + Arg.Unit + (fun () -> + allow_empty_env_ref := allow_empty_env; + act_ref := act); + ] + in + try + let () = + Arg.parse + (Arg.align + ([ + "-configure", + arg_handle ~allow_empty_env:true configure, + s_ "[options*] Configure the whole build process."; + + "-build", + arg_handle build, + s_ "[options*] Build executables and libraries."; + + "-doc", + arg_handle doc, + s_ "[options*] Build documents."; + + "-test", + arg_handle test, + s_ "[options*] Run tests."; + + "-all", + arg_handle ~allow_empty_env:true all, + s_ "[options*] Run configure, build, doc and test targets."; + + "-install", + arg_handle install, + s_ "[options*] Install libraries, data, executables \ + and documents."; + + "-uninstall", + arg_handle uninstall, + s_ "[options*] Uninstall libraries, data, executables \ + and documents."; + + "-reinstall", + arg_handle reinstall, + s_ "[options*] Uninstall and install libraries, data, \ + executables and documents."; + + "-clean", + arg_handle ~allow_empty_env:true clean, + s_ "[options*] Clean files generated by a build."; + + "-distclean", + arg_handle ~allow_empty_env:true distclean, + s_ "[options*] Clean files generated by a build and configure."; + + "-version", + arg_handle ~allow_empty_env:true version, + s_ " Display version of OASIS used to generate this setup.ml."; + + "-no-catch-exn", + Arg.Clear catch_exn, + s_ " Don't catch exception, useful for debugging."; + ] + @ (if t.setup_update then [no_update_setup_ml_cli] else []) - @ (BaseContext.args ()))) - (failwithf (f_ "Don't know what to do with '%s'")) - (s_ "Setup and run build process current package\n"); + @ (BaseContext.args ()))) + (failwithf (f_ "Don't know what to do with '%s'")) + (s_ "Setup and run build process current package\n") + in - (* Build initial environment *) - load ~allow_empty:!allow_empty_env_ref (); + (* Instantiate the context. *) + let ctxt = !BaseContext.default in - (** 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; + (* Build initial environment *) + load ~ctxt ~allow_empty:!allow_empty_env_ref (); + + (** Initialize flags *) + List.iter + (function + | Flag (cs, {flag_description = hlp; + flag_default = choices}) -> + begin + let apply ?short_desc () = + var_ignore + (var_define + ~cli:CLIEnable + ?short_desc + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + string_of_bool + (var_choose + ~name:(Printf.sprintf + (f_ "default value of flag %s") + cs.cs_name) + ~printer:string_of_bool + choices))) + in + match hlp with + | Some hlp -> apply ~short_desc:(fun () -> hlp) () + | None -> apply () + end + | _ -> + ()) + t.package.sections; - BaseStandardVar.init t.package; + BaseStandardVar.init t.package; - BaseDynVar.init t.package; + BaseDynVar.init ~ctxt t.package; - if t.setup_update && update_setup_ml t then - () - else - !act_ref t (Array.of_list (List.rev !extra_args_ref)) + if not (t.setup_update && update_setup_ml t) then + !act_ref ~ctxt t (Array.of_list (List.rev !extra_args_ref)) - with e when !catch_exn -> - error "%s" (Printexc.to_string e); - exit 1 + with e when !catch_exn -> + error "%s" (Printexc.to_string e); + exit 1 + + +end + +module BaseCompat = struct +(* # 22 "src/base/BaseCompat.ml" *) + + (** Compatibility layer to provide a stable API inside setup.ml. + This layer allows OASIS to change in between minor versions + (e.g. 0.4.6 -> 0.4.7) but still provides a stable API inside setup.ml. This + enables to write functions that manipulate setup_t inside setup.ml. See + deps.ml for an example. + The module opened by default will depend on the version of the _oasis. E.g. + if we have "OASISFormat: 0.3", the module Compat_0_3 will be opened and + the function Compat_0_3 will be called. If setup.ml is generated with the + -nocompat, no module will be opened. + + @author Sylvain Le Gall + *) + + module Compat_0_4 = + struct + let rctxt = ref !BaseContext.default + + module BaseSetup = + struct + module Original = BaseSetup + + open OASISTypes + + type std_args_fun = package -> string array -> unit + type ('a, 'b) section_args_fun = + name * (package -> (common_section * 'a) -> string array -> 'b) + type t = + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + oasis_fn: string option; + oasis_version: string; + oasis_digest: Digest.t option; + oasis_exec: string option; + oasis_setup_args: string list; + setup_update: bool; + } + + let setup t = + let mk_std_args_fun f = + fun ~ctxt pkg args -> rctxt := ctxt; f pkg args + in + let mk_section_args_fun l = + List.map + (fun (nm, f) -> + nm, + (fun ~ctxt pkg sct args -> + rctxt := ctxt; + f pkg sct args)) + l + in + let t' = + { + Original. + configure = mk_std_args_fun t.configure; + build = mk_std_args_fun t.build; + doc = mk_section_args_fun t.doc; + test = mk_section_args_fun t.test; + install = mk_std_args_fun t.install; + uninstall = mk_std_args_fun t.uninstall; + clean = List.map mk_std_args_fun t.clean; + clean_doc = mk_section_args_fun t.clean_doc; + clean_test = mk_section_args_fun t.clean_test; + distclean = List.map mk_std_args_fun t.distclean; + distclean_doc = mk_section_args_fun t.distclean_doc; + distclean_test = mk_section_args_fun t.distclean_test; + + package = t.package; + oasis_fn = t.oasis_fn; + oasis_version = t.oasis_version; + oasis_digest = t.oasis_digest; + oasis_exec = t.oasis_exec; + oasis_setup_args = t.oasis_setup_args; + setup_update = t.setup_update; + } + in + Original.setup t' + + end + + let adapt_setup_t setup_t = + let module O = BaseSetup.Original in + let mk_std_args_fun f = fun pkg args -> f ~ctxt:!rctxt pkg args in + let mk_section_args_fun l = + List.map + (fun (nm, f) -> nm, (fun pkg sct args -> f ~ctxt:!rctxt pkg sct args)) + l + in + { + BaseSetup. + configure = mk_std_args_fun setup_t.O.configure; + build = mk_std_args_fun setup_t.O.build; + doc = mk_section_args_fun setup_t.O.doc; + test = mk_section_args_fun setup_t.O.test; + install = mk_std_args_fun setup_t.O.install; + uninstall = mk_std_args_fun setup_t.O.uninstall; + clean = List.map mk_std_args_fun setup_t.O.clean; + clean_doc = mk_section_args_fun setup_t.O.clean_doc; + clean_test = mk_section_args_fun setup_t.O.clean_test; + distclean = List.map mk_std_args_fun setup_t.O.distclean; + distclean_doc = mk_section_args_fun setup_t.O.distclean_doc; + distclean_test = mk_section_args_fun setup_t.O.distclean_test; + + package = setup_t.O.package; + oasis_fn = setup_t.O.oasis_fn; + oasis_version = setup_t.O.oasis_version; + oasis_digest = setup_t.O.oasis_digest; + oasis_exec = setup_t.O.oasis_exec; + oasis_setup_args = setup_t.O.oasis_setup_args; + setup_update = setup_t.O.setup_update; + } + end + + + module Compat_0_3 = + struct + include Compat_0_4 + end end -# 5432 "setup.ml" +# 5662 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall - *) + *) open BaseEnv @@ -5447,9 +5677,9 @@ module InternalConfigurePlugin = struct (** Configure build using provided series of check to be done - * and then output corresponding file. - *) - let configure pkg argv = + and then output corresponding file. + *) + let configure ~ctxt:_ pkg argv = let var_ignore_eval var = let _s: string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in @@ -5471,29 +5701,29 @@ module InternalConfigurePlugin = struct 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) + | 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 @@ -5517,39 +5747,39 @@ module InternalConfigurePlugin = struct (* 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) + | 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 @@ -5561,50 +5791,50 @@ module InternalConfigurePlugin = struct 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 + 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 + 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 (BaseStandardVar.ocaml_version ())) (OASISVersion.version_of_string "4.0.0") >= 0 in if ocaml_ge4 then let findlib_lt132 = @@ -5629,37 +5859,37 @@ module InternalConfigurePlugin = struct (* 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 - | _ -> - ()) + | 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) - *) + 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) + | 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 + if has_cmxa then + var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) @@ -5688,6 +5918,8 @@ module InternalInstallPlugin = struct *) + (* TODO: rewrite this module with OASISFileSystem. *) + open BaseEnv open BaseStandardVar open BaseMessage @@ -5697,34 +5929,17 @@ module InternalInstallPlugin = struct 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 exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) + let lib_hook = ref (fun (cs, bs, dn, lib) -> cs, bs, dn, lib, []) + let obj_hook = ref (fun (cs, bs, dn, obj) -> cs, bs, dn, obj, []) + let doc_hook = ref (fun (cs, doc) -> cs, doc) - - let install_dir_ev = - "install-dir" - - - let install_findlib_ev = - "install-findlib" + let install_file_ev = "install-file" + let install_dir_ev = "install-dir" + let install_findlib_ev = "install-findlib" + (* TODO: this can be more generic and used elsewhere. *) let win32_max_command_line_length = 8000 @@ -5793,24 +6008,21 @@ module InternalInstallPlugin = struct ["install" :: findlib_name :: meta :: files] - let install pkg argv = + let install = - let in_destdir = + let in_destdir fn = try - let destdir = - destdir () - in - (* Practically speaking destdir is prepended - * at the beginning of the target filename - *) - fun fn -> destdir^fn + (* Practically speaking destdir is prepended at the beginning of the + target filename + *) + (destdir ())^fn with PropList.Not_set _ -> - fun fn -> fn + fn in - let install_file ?tgt_fn src_file envdir = + let install_file ~ctxt ?(prepend_destdir=true) ?tgt_fn src_file envdir = let tgt_dir = - in_destdir (envdir ()) + if prepend_destdir then in_destdir (envdir ()) else envdir () in let tgt_file = Filename.concat @@ -5823,20 +6035,48 @@ module InternalInstallPlugin = struct in (* Create target directory if needed *) OASISFileUtil.mkdir_parent - ~ctxt:!BaseContext.default + ~ctxt (fun dn -> info (f_ "Creating directory '%s'") dn; - BaseLog.register install_dir_ev dn) - tgt_dir; + BaseLog.register ~ctxt install_dir_ev dn) + (Filename.dirname tgt_file); (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; - BaseLog.register install_file_ev tgt_file + OASISFileUtil.cp ~ctxt src_file tgt_file; + BaseLog.register ~ctxt install_file_ev tgt_file + in + + (* Install the files for a library. *) + + let install_lib_files ~ctxt findlib_name files = + let findlib_dir = + let dn = + let findlib_destdir = + OASISExec.run_read_one_line ~ctxt (ocamlfind ()) + ["printconf" ; "destdir"] + in + Filename.concat findlib_destdir findlib_name + in + fun () -> dn + in + let () = + if not (OASISFileUtil.file_exists_case (findlib_dir ())) then + failwithf + (f_ "Directory '%s' doesn't exist for findlib library %s") + (findlib_dir ()) findlib_name + in + let f dir file = + let basename = Filename.basename file in + let tgt_fn = Filename.concat dir basename in + (* Destdir is already include in printconf. *) + install_file ~ctxt ~prepend_destdir:false ~tgt_fn file findlib_dir + in + List.iter (fun (dir, files) -> List.iter (f dir) files) files ; in (* Install data into defined directory *) - let install_data srcdir lst tgtdir = + let install_data ~ctxt srcdir lst tgtdir = let tgtdir = OASISHostPath.of_unix (var_expand tgtdir) in @@ -5853,7 +6093,7 @@ module InternalInstallPlugin = struct src; List.iter (fun fn -> - install_file + install_file ~ctxt fn (fun () -> match tgt_opt with @@ -5877,149 +6117,146 @@ module InternalInstallPlugin = struct 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 - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ acc - end - acc - lib.lib_modules - in + let install_libs ~ctxt pkg = - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in + let find_first_existing_files_in_path bs lst = + let path = OASISHostPath.of_unix bs.bs_path in + List.find + OASISFileUtil.file_exists_case + (List.map (Filename.concat path) lst) + in - let 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 + let files_of_modules new_files typ cs bs modules = + List.fold_left + (fun acc modul -> + begin + try + (* Add uncompiled header from the source tree *) + [find_first_existing_files_in_path + bs (make_fnames modul [".mli"; ".ml"])] + with Not_found -> + warning + (f_ "Cannot find source header for module %s \ + in %s %s") + typ modul cs.cs_name; + [] + end + @ + List.fold_left + (fun acc fn -> + try + find_first_existing_files_in_path bs [fn] :: acc + with Not_found -> + acc) + acc (make_fnames modul [".annot";".cmti";".cmt"])) + new_files + modules + in - (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 + let files_of_build_section (f_data, new_files) typ cs bs = + let extra_files = + List.map + (fun fn -> + try + find_first_existing_files_in_path bs [fn] + with Not_found -> + failwithf + (f_ "Cannot find extra findlib file %S in %s %s ") + fn + typ + cs.cs_name) + bs.bs_findlib_extra_files in - 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 - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ 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 library *) + install_data + ~ctxt + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + f_data, new_files @ extra_files + in - let 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 + let files_of_library (f_data, acc) data_lib = + let cs, bs, lib, dn, lib_extra = !lib_hook data_lib in + if var_choose bs.bs_install && + BaseBuilt.is_built ~ctxt BaseBuilt.BLib cs.cs_name then begin + (* Start with lib_extra *) + let new_files = lib_extra in + let new_files = + files_of_modules new_files "library" cs bs lib.lib_modules + in + let f_data, new_files = + files_of_build_section (f_data, new_files) "library" cs bs + in + let new_files = + (* Get generated files *) + BaseBuilt.fold + ~ctxt + BaseBuilt.BLib + cs.cs_name + (fun acc fn -> fn :: acc) + new_files + in + let acc = (dn, new_files) :: acc in + + let f_data () = + (* Install data associated with the library *) + install_data + ~ctxt + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in - (f_data, acc) - end - else - begin - (f_data, acc) - end + (f_data, acc) + end else begin + (f_data, acc) + end + and files_of_object (f_data, acc) data_obj = + let cs, bs, obj, dn, obj_extra = !obj_hook data_obj in + if var_choose bs.bs_install && + BaseBuilt.is_built ~ctxt BaseBuilt.BObj cs.cs_name then begin + (* Start with obj_extra *) + let new_files = obj_extra in + let new_files = + files_of_modules new_files "object" cs bs obj.obj_modules + in + let f_data, new_files = + files_of_build_section (f_data, new_files) "object" cs bs + in + let new_files = + (* Get generated files *) + BaseBuilt.fold + ~ctxt + BaseBuilt.BObj + cs.cs_name + (fun acc fn -> fn :: acc) + new_files + in + let acc = (dn, new_files) :: acc in + + let f_data () = + (* Install data associated with the object *) + install_data + ~ctxt + bs.bs_path + bs.bs_data_files + (Filename.concat (datarootdir ()) pkg.name); + f_data () + in + (f_data, acc) + end else begin + (f_data, acc) + end in (* Install one group of library *) @@ -6030,10 +6267,10 @@ module InternalInstallPlugin = struct 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 + | Package (_, cs, bs, `Library lib, dn, children) -> + files_of_library data_and_files (cs, bs, lib, dn), children + | Package (_, cs, bs, `Object obj, dn, children) -> + files_of_object data_and_files (cs, bs, obj, dn), children in List.fold_left install_group_lib_aux @@ -6042,264 +6279,196 @@ module InternalInstallPlugin = struct in (* Findlib name of the root library *) - let findlib_name = - findlib_of_group grp - in + let findlib_name = findlib_of_group grp in (* Determine root library *) - let root_lib = - root_of_group grp - in + 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 + 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 + if files = [] then begin + warning + (f_ "Nothing to install for findlib library '%s'") findlib_name + end else begin + let meta = + (* Search META file *) + let _, bs, _ = root_lib in + let res = Filename.concat bs.bs_path "META" in + if not (OASISFileUtil.file_exists_case res) then + failwithf + (f_ "Cannot find file '%s' for findlib library %s") + res + findlib_name; + res + in + let files = + (* Make filename shorter to avoid hitting command max line length + * too early, esp. on Windows. + *) + (* TODO: move to OASISHostPath as make_relative. *) + let remove_prefix p n = + let plen = String.length p in + let nlen = String.length n in + if plen <= nlen && String.sub n 0 plen = p then begin + let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in + let cutpoint = + plen + + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in - List.iter - (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) - commands; - BaseLog.register install_findlib_ev findlib_name - end; - - (* Install data files *) - f_data (); + String.sub n cutpoint (nlen - cutpoint) + end else begin + n + end + in + List.map + (fun (dir, fn) -> + (dir, List.map (remove_prefix (Sys.getcwd ())) fn)) + files + in + let ocamlfind = ocamlfind () in + let nodir_files, dir_files = + List.fold_left + (fun (nodir, dir) (dn, lst) -> + match dn with + | Some dn -> nodir, (dn, lst) :: dir + | None -> lst @ nodir, dir) + ([], []) + (List.rev files) + in + info (f_ "Installing findlib library '%s'") findlib_name; + List.iter + (OASISExec.run ~ctxt ocamlfind) + (split_install_command ocamlfind findlib_name meta nodir_files); + install_lib_files ~ctxt findlib_name dir_files; + BaseLog.register ~ctxt install_findlib_ev findlib_name + end; + (* Install data files *) + f_data (); in - let group_libs, _, _ = - findlib_mapping pkg - in + 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_execs ~ctxt 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 + let cs, bs, _ = !exec_hook data_exec in + if var_choose bs.bs_install && + BaseBuilt.is_built ~ctxt BaseBuilt.BExec cs.cs_name then begin + let exec_libdir () = Filename.concat (libdir ()) pkg.name in + BaseBuilt.fold + ~ctxt + BaseBuilt.BExec + cs.cs_name + (fun () fn -> + install_file ~ctxt + ~tgt_fn:(cs.cs_name ^ ext_program ()) + fn + bindir) + (); + BaseBuilt.fold + ~ctxt + BaseBuilt.BExecLib + cs.cs_name + (fun () fn -> install_file ~ctxt fn exec_libdir) + (); + install_data ~ctxt + bs.bs_path + bs.bs_data_files + (Filename.concat (datarootdir ()) pkg.name) + end in - List.iter - (function - | Executable (cs, bs, exec)-> - install_exec (cs, bs, exec) - | _ -> - ()) + List.iter + (function + | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) + | _ -> ()) pkg.sections in - let install_docs pkg = + let install_docs ~ctxt pkg = let install_doc data = - let cs, doc = - !doc_hook data - in - if var_choose doc.doc_install && - BaseBuilt.is_built 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 + let cs, doc = !doc_hook data in + if var_choose doc.doc_install && + BaseBuilt.is_built ~ctxt BaseBuilt.BDoc cs.cs_name then begin + let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in + BaseBuilt.fold + ~ctxt + BaseBuilt.BDoc + cs.cs_name + (fun () fn -> install_file ~ctxt fn (fun () -> tgt_dir)) + (); + install_data ~ctxt + Filename.current_dir_name + doc.doc_data_files + doc.doc_install_dir + end in - List.iter - (function - | Doc (cs, doc) -> - install_doc (cs, doc) - | _ -> - ()) - pkg.sections + List.iter + (function + | Doc (cs, doc) -> install_doc (cs, doc) + | _ -> ()) + pkg.sections in - - install_libs pkg; - install_execs pkg; - install_docs pkg + fun ~ctxt pkg _ -> + install_libs ~ctxt pkg; + install_execs ~ctxt pkg; + install_docs ~ctxt 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 *) + let uninstall ~ctxt _ _ = + let uninstall_aux (ev, data) = + if ev = install_file_ev then begin + if OASISFileUtil.file_exists_case data then begin + info (f_ "Removing file '%s'") data; + Sys.remove data + end else begin + warning (f_ "File '%s' doesn't exist anymore") data + end + end else if ev = install_dir_ev then begin + if Sys.file_exists data && Sys.is_directory data then begin + if Sys.readdir data = [||] then begin + info (f_ "Removing directory '%s'") data; + OASISFileUtil.rmdir ~ctxt data + end else begin + warning + (f_ "Directory '%s' is not empty (%s)") + data + (String.concat ", " (Array.to_list (Sys.readdir data))) + end + end else begin + warning (f_ "Directory '%s' doesn't exist anymore") data + end + end else if ev = install_findlib_ev then begin + info (f_ "Removing findlib library '%s'") data; + OASISExec.run ~ctxt (ocamlfind ()) ["remove"; data] + end else begin + failwithf (f_ "Unknown log event '%s'") ev; + end; + BaseLog.unregister ~ctxt ev data + in + (* We process event in reverse order *) + List.iter uninstall_aux (List.rev - (BaseLog.filter - [install_file_ev; - install_dir_ev; - install_findlib_ev])) - + (BaseLog.filter ~ctxt [install_file_ev; install_dir_ev])); + List.iter uninstall_aux + (List.rev (BaseLog.filter ~ctxt [install_findlib_ev])) end -# 6296 "setup.ml" +# 6465 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin - *) + *) open OASISGettext @@ -6308,8 +6477,6 @@ module OCamlbuildCommon = struct open OASISTypes - - type extra_args = string list @@ -6332,6 +6499,14 @@ module OCamlbuildCommon = struct "-classic-display"; "-no-log"; "-no-links"; + ] + else + []; + + if OASISVersion.comparator_apply + (OASISVersion.version_of_string (ocaml_version ())) + (OASISVersion.VLesser (OASISVersion.version_of_string "3.11.1")) then + [ "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") ] @@ -6368,35 +6543,32 @@ module OCamlbuildCommon = struct (** Run 'ocamlbuild -clean' if not already done *) - let run_clean extra_argv = + let run_clean ~ctxt extra_argv = let extra_cli = String.concat " " (Array.to_list extra_argv) in - (* Run if never called with these args *) - if not (BaseLog.exists 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 if never called with these args *) + if not (BaseLog.exists ~ctxt ocamlbuild_clean_ev extra_cli) then + begin + OASISExec.run ~ctxt (ocamlbuild ()) (fix_args ["-clean"] extra_argv); + BaseLog.register ~ctxt ocamlbuild_clean_ev extra_cli; + at_exit + (fun () -> + try + BaseLog.unregister ~ctxt ocamlbuild_clean_ev extra_cli + with _ -> ()) + end (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild args extra_argv = + let run_ocamlbuild ~ctxt args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args args extra_argv); + *) + OASISExec.run ~ctxt (ocamlbuild ()) (fix_args args extra_argv); (* Remove any clean event, we must run it again *) List.iter - (fun (e, d) -> BaseLog.unregister e d) - (BaseLog.filter [ocamlbuild_clean_ev]) + (fun (e, d) -> BaseLog.unregister ~ctxt e d) + (BaseLog.filter ~ctxt [ocamlbuild_clean_ev]) (** Determine real build directory *) @@ -6404,13 +6576,13 @@ module OCamlbuildCommon = struct let rec search_args dir = function | "-build-dir" :: dir :: tl -> - search_args dir tl + search_args dir tl | _ :: tl -> - search_args dir tl + search_args dir tl | [] -> - dir + dir in - search_args "_build" (fix_args [] extra_argv) + search_args "_build" (fix_args [] extra_argv) end @@ -6431,17 +6603,12 @@ module OCamlbuildPlugin = struct open BaseEnv open OCamlbuildCommon open BaseStandardVar - open BaseMessage - - - - let cond_targets_hook = - ref (fun lst -> lst) + let cond_targets_hook = ref (fun lst -> lst) - let build extra_args pkg argv = + let build ~ctxt extra_args pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat @@ -6505,8 +6672,8 @@ module OCamlbuildPlugin = struct (List.map (List.filter (fun fn -> - ends_with ".cmo" fn - || ends_with ".cmx" fn)) + ends_with ~what:".cmo" fn + || ends_with ~what:".cmx" fn)) unix_files)) in @@ -6521,10 +6688,8 @@ module OCamlbuildPlugin = struct | 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) + let evs, _, _ = + BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) in let target ext = @@ -6538,7 +6703,7 @@ module OCamlbuildPlugin = struct (* 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, _ when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> @@ -6582,27 +6747,30 @@ module OCamlbuildPlugin = struct (List.length fns)) (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; - (BaseBuilt.register bt bnm lst) + (BaseBuilt.register ~ctxt bt bnm lst) in (* Run the hook *) let cond_targets = !cond_targets_hook cond_targets in (* Run a list of target... *) - run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; + run_ocamlbuild + ~ctxt + (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; + let clean ~ctxt pkg extra_args = + run_clean ~ctxt extra_args; List.iter (function | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections @@ -6616,16 +6784,12 @@ module OCamlbuildDocPlugin = struct (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall - *) + *) open OASISTypes open OASISGettext - open OASISMessage open OCamlbuildCommon - open BaseStandardVar - - type run_t = @@ -6635,7 +6799,7 @@ module OCamlbuildDocPlugin = struct } - let doc_build run pkg (cs, doc) argv = + let doc_build ~ctxt run _ (cs, _) argv = let index_html = OASISUnixPath.make [ @@ -6652,139 +6816,125 @@ module OCamlbuildDocPlugin = struct 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"] + run_ocamlbuild ~ctxt (index_html :: run.extra_args) argv; + List.iter + (fun glb -> + match OASISFileUtil.glob ~ctxt (Filename.concat tgt_dir glb) with + | (_ :: _) as filenames -> + BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [filenames] + | [] -> ()) + ["*.html"; "*.css"] - let doc_clean run pkg (cs, doc) argv = - run_clean argv; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + let doc_clean ~ctxt _ _ (cs, _) argv = + run_clean ~ctxt argv; + BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name end -# 6674 "setup.ml" +# 6837 "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; - } + { + 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 main ~ctxt:_ t _ extra_args = + let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in + run cmd args extra_args - let clean t pkg extra_args = + let clean ~ctxt:_ t _ extra_args = match var_choose t.cmd_clean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () + | Some (cmd, args) -> run cmd args extra_args + | _ -> () - let distclean t pkg extra_args = + let distclean ~ctxt:_ t _ extra_args = match var_choose t.cmd_distclean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () + | Some (cmd, args) -> run cmd args extra_args + | _ -> () module Build = struct - let main t pkg extra_args = - main t pkg extra_args; + let main ~ctxt t pkg extra_args = + main ~ctxt t pkg extra_args; List.iter (fun sct -> let evs = match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, _ = - BaseBuilt.of_library - OASISHostPath.of_unix - (cs, bs, lib) - in - evs - end + 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 + 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) + List.iter + (fun (bt, bnm, lst) -> BaseBuilt.register ~ctxt bt bnm lst) + evs) pkg.sections - let clean t pkg extra_args = - clean t pkg extra_args; + let clean ~ctxt t pkg extra_args = + clean ~ctxt t pkg extra_args; (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild * considering moving this to BaseSetup? *) List.iter (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) + | Library (cs, _, _) -> + BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) pkg.sections - let distclean t pkg extra_args = - distclean t pkg extra_args + let distclean ~ctxt t pkg extra_args = distclean ~ctxt t pkg extra_args end module Test = struct - let main t pkg (cs, test) extra_args = + let main ~ctxt t pkg (cs, _) extra_args = try - main t pkg extra_args; + main ~ctxt t pkg extra_args; 0.0 with Failure s -> BaseMessage.warning @@ -6793,33 +6943,30 @@ module CustomPlugin = struct s; 1.0 - let clean t pkg (cs, test) extra_args = - clean t pkg extra_args + let clean ~ctxt t pkg _ extra_args = clean ~ctxt t pkg extra_args - let distclean t pkg (cs, test) extra_args = - distclean t pkg extra_args + let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt 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 main ~ctxt t pkg (cs, _) extra_args = + main ~ctxt t pkg extra_args; + BaseBuilt.register ~ctxt 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 clean ~ctxt t pkg (cs, _) extra_args = + clean ~ctxt t pkg extra_args; + BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name - let distclean t pkg (cs, _) extra_args = - distclean t pkg extra_args + let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args end end -# 6822 "setup.ml" +# 6969 "setup.ml" open OASISTypes;; let setup_t = @@ -6904,11 +7051,7 @@ let setup_t = { oasis_version = "0.3"; ocaml_version = None; - findlib_version = None; - alpha_features = []; - beta_features = []; - name = "cryptokit"; - version = "1.11"; + version = "1.13"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6917,11 +7060,16 @@ let setup_t = excption = Some "OCaml linking"; version = OASISLicense.Version "2" }); + findlib_version = None; + alpha_features = []; + beta_features = []; + name = "cryptokit"; license_file = None; copyrights = []; maintainers = []; authors = ["Xavier Leroy"]; homepage = None; + bugreports = None; synopsis = "Cryptographic primitives"; description = Some @@ -6929,7 +7077,7 @@ let setup_t = OASISText.Para "This library provides a variety of cryptographic primitives that can be used to implement cryptographic protocols in security-sensitive applications. The primitives provided include:"; OASISText.Para - "- Symmetric-key ciphers: AES, DES, Triple-DES, ARCfour,"; + "- Symmetric-key ciphers: AES, Chacha20, Blowfish, DES, Triple-DES, ARCfour,"; OASISText.Verbatim " in ECB, CBC, CFB, OFB and counter modes."; OASISText.Para @@ -6940,40 +7088,8 @@ let setup_t = OASISText.Para "Additional ciphers and hashes can easily be used in conjunction with the library. In particular, basic mechanisms such as chaining modes, output buffering, and padding are provided by generic classes that can easily be composed with user-provided ciphers. More generally, the library promotes a \"Lego\"-like style of constructing and composing transformations over character streams." ]; + tags = []; 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 = [ @@ -7002,7 +7118,7 @@ let setup_t = { flag_description = Some - "Enable hardware support for AES (needs GCC or Clang)"; + "Enable hardware support for AES and GCM (needs GCC or Clang)"; flag_default = [ (OASISExpr.EBool true, false); @@ -7033,6 +7149,116 @@ let setup_t = ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; + bs_interface_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${capitalize_file module}.mli" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${uncapitalize_file module}.mli" + } + ]; + bs_implementation_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${capitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${uncapitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${capitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${uncapitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${capitalize_file module}.mly" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${uncapitalize_file module}.mly" + } + ]; bs_c_sources = [ "aesni.c"; @@ -7067,9 +7293,13 @@ let setup_t = "stubs-zlib.c"; "keccak.h"; "keccak.c"; - "stubs-sha3.c" + "stubs-sha3.c"; + "chacha20.h"; + "chacha20.c"; + "stubs-chacha20.c" ]; bs_data_files = []; + bs_findlib_extra_files = []; bs_ccopt = [ (OASISExpr.EBool true, []); @@ -7227,6 +7457,7 @@ let setup_t = lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; + lib_findlib_directory = None; lib_findlib_containers = [] }); Executable @@ -7247,8 +7478,119 @@ let setup_t = bs_build_depends = [InternalLibrary "cryptokit"]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; + bs_interface_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${capitalize_file module}.mli" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${uncapitalize_file module}.mli" + } + ]; + bs_implementation_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${capitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${uncapitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${capitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${uncapitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${capitalize_file module}.mly" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${uncapitalize_file module}.mly" + } + ]; bs_c_sources = []; bs_data_files = []; + bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; @@ -7257,6 +7599,145 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "test.ml"}); + Executable + ({ + cs_name = "prngtest"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "tests", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "test"; + bs_compiled_object = Native; + bs_build_depends = [InternalLibrary "cryptokit"]; + bs_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; + bs_interface_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${capitalize_file module}.mli" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${uncapitalize_file module}.mli" + } + ]; + bs_implementation_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${capitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${uncapitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${capitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${uncapitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${capitalize_file module}.mly" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${uncapitalize_file module}.mly" + } + ]; + bs_c_sources = []; + bs_data_files = []; + bs_findlib_extra_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "prngtest.ml"}); Test ({ cs_name = "main"; @@ -7312,8 +7793,119 @@ let setup_t = bs_build_depends = [InternalLibrary "cryptokit"]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; + bs_interface_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${capitalize_file module}.mli" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${uncapitalize_file module}.mli" + } + ]; + bs_implementation_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${capitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${uncapitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${capitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${uncapitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${capitalize_file module}.mly" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${uncapitalize_file module}.mly" + } + ]; bs_c_sources = []; bs_data_files = []; + bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; @@ -7393,12 +7985,11 @@ let setup_t = cs_plugin_data = [] }, { - src_repo_type = Svn; + src_repo_type = Git; src_repo_location = - "http://scm.ocamlcore.org/svnroot/cryptokit/trunk"; + "https://github.com/xavierleroy/cryptokit"; src_repo_browser = - Some - "https://forge.ocamlcore.org/scm/browser.php?group_id=133"; + Some "https://github.com/xavierleroy/cryptokit"; src_repo_module = None; src_repo_branch = None; src_repo_tag = None; @@ -7411,32 +8002,65 @@ let setup_t = cs_plugin_data = [] }, { - src_repo_type = Svn; + src_repo_type = Git; src_repo_location = - "http://scm.ocamlcore.org/svnroot/tags/release18"; + "https://github.com/xavierleroy/cryptokit/releases/tag/release113"; src_repo_browser = Some - "https://forge.ocamlcore.org/scm/browser.php?group_id=133"; + "https://github.com/xavierleroy/cryptokit/releases/tag/release113"; src_repo_module = None; src_repo_branch = None; src_repo_tag = None; src_repo_subdir = None }) ]; + disable_oasis_section = []; + conf_type = (`Configure, "internal", Some "0.4"); + conf_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + build_type = (`Build, "ocamlbuild", Some "0.4"); + build_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + install_type = (`Install, "internal", Some "0.4"); + install_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + uninstall_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + clean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + distclean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; plugins = [ (`Extra, "META", Some "0.3"); (`Extra, "DevFiles", Some "0.3"); (`Extra, "StdFiles", Some "0.3") ]; - disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.6"; + oasis_version = "0.4.10"; oasis_digest = - Some "i\161\218\208)\219\191\128\028\029\023U\232\201\186\202"; + Some "\212\1377\231\145\135\191\200=\177\220\134\230\157\203\214"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7444,6 +8068,8 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7448 "setup.ml" +# 8072 "setup.ml" +let setup_t = BaseCompat.Compat_0_3.adapt_setup_t setup_t +open BaseCompat.Compat_0_3 (* OASIS_STOP *) let () = setup ();; diff --git a/src/.depend b/src/.depend deleted file mode 100644 index 0db49da..0000000 --- a/src/.depend +++ /dev/null @@ -1,21 +0,0 @@ -arcfour.o: arcfour.c arcfour.h -blowfish.o: blowfish.c blowfish.h -d3des.o: d3des.c d3des.h -rijndael-alg-fst.o: rijndael-alg-fst.c rijndael-alg-fst.h -ripemd160.o: ripemd160.c ripemd160.h -sha1.o: sha1.c sha1.h -sha256.o: sha256.c sha256.h -stubs-aes.o: stubs-aes.c rijndael-alg-fst.h -stubs-arcfour.o: stubs-arcfour.c arcfour.h -stubs-blowfish.o: stubs-blowfish.c blowfish.h -stubs-des.o: stubs-des.c d3des.h -stubs-md5.o: stubs-md5.c -stubs-misc.o: stubs-misc.c -stubs-ripemd160.o: stubs-ripemd160.c ripemd160.h -stubs-rng.o: stubs-rng.c -stubs-sha1.o: stubs-sha1.c sha1.h -stubs-sha256.o: stubs-sha256.c sha256.h -stubs-zlib.o: stubs-zlib.c -cryptokit.cmi: -cryptokit.cmo: cryptokit.cmi -cryptokit.cmx: cryptokit.cmi @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 50ed06596b6c30f4761d9ed7f75fb433) -version = "1.11" +# DO NOT EDIT (digest: 7cb4f4b2e0b5e77bb7a0ee261fd36f90) +version = "1.13" description = "Cryptographic primitives" requires = "unix zarith" archive(byte) = "cryptokit.cma" diff --git a/src/aesni.c b/src/aesni.c index 57a8ae7..4013657 100644 --- a/src/aesni.c +++ b/src/aesni.c @@ -18,16 +18,20 @@ #ifdef __AES__ #include <wmmintrin.h> +#include <cpuid.h> +#include <stdint.h> int aesni_available = -1; int aesni_check_available(void) { - unsigned int ax, bx, cx, dx; - __asm__ __volatile__ ("cpuid" - : "=a" (ax), "=b" (bx), "=c" (cx), "=d" (dx) - : "a" (1)); - return (aesni_available = (cx & 0x2000000) != 0); + unsigned int eax, ebx, ecx, edx; + if(__get_cpuid(1, &eax, &ebx, &ecx, &edx)) { + aesni_available = (ecx & 0x2000000) != 0; + } else { + aesni_available = 0; + } + return aesni_available; } static inline __m128i aesni_128_assist(__m128i t1, __m128i t2) @@ -213,11 +217,19 @@ static int aesni_key_expansion(const unsigned char * userkey, } } +static void * align16(void * p) +{ + uintptr_t n = (uintptr_t) p; + n = (n + 15) & -16; + return (void *) n; +} + int aesniKeySetupEnc(unsigned char * ckey, const unsigned char * key, int keylength) { - __m128i key_schedule[15]; + __m128i unaligned_key_schedule[15 + 1]; /* + 1 to leave space for alignment */ + __m128i *key_schedule = align16(unaligned_key_schedule); int nrounds, i; nrounds = aesni_key_expansion(key, keylength, key_schedule); @@ -231,7 +243,8 @@ int aesniKeySetupDec(unsigned char * ckey, const unsigned char * key, int keylength) { - __m128i key_schedule[15]; + __m128i unaligned_key_schedule[15 + 1]; /* + 1 to leave space for alignment */ + __m128i *key_schedule = align16(unaligned_key_schedule); int nrounds, i; nrounds = aesni_key_expansion(key, keylength, key_schedule); diff --git a/src/chacha20.c b/src/chacha20.c new file mode 100644 index 0000000..de56811 --- /dev/null +++ b/src/chacha20.c @@ -0,0 +1,162 @@ +/* Based on D. J. Bernstein's chacha-regs.c version 200801118, + https://cr.yp.to/streamciphers/timings/estreambench/submissions/salsa20/chacha8/regs/chacha.c + The initial code is in the public domain */ + +#include <assert.h> +#include <stddef.h> +#include <stdint.h> +#include <string.h> +#include <caml/config.h> +#include "chacha20.h" + +static inline void U32TO8_LITTLE(uint8_t * dst, uint32_t val) +{ +#ifdef ARCH_BIG_ENDIAN + dst[0] = val; + dst[1] = val >> 8; + dst[2] = val >> 16; + dst[3] = val >> 24; +#else + *((uint32_t *) dst) = val; +#endif +} + +static inline uint32_t U8TO32_LITTLE(const uint8_t * src) +{ + return (uint32_t) src[0] + + ((uint32_t) src[1] << 8) + + ((uint32_t) src[2] << 16) + + ((uint32_t) src[3] << 24); +} + +#define ROTATE(v,c) ((v) << (c) | (v) >> (32 - (c))) +#define XOR(v,w) ((v) ^ (w)) +#define PLUS(v,w) ((v) + (w)) +#define PLUSONE(v) ((v) + 1) + +#define QUARTERROUND(a,b,c,d) \ + a = PLUS(a,b); d = ROTATE(XOR(d,a),16); \ + c = PLUS(c,d); b = ROTATE(XOR(b,c),12); \ + a = PLUS(a,b); d = ROTATE(XOR(d,a), 8); \ + c = PLUS(c,d); b = ROTATE(XOR(b,c), 7); + +static void chacha20_block(chacha20_ctx * ctx) +{ + uint32_t x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15; + int i; + + x0 = ctx->input[0]; + x1 = ctx->input[1]; + x2 = ctx->input[2]; + x3 = ctx->input[3]; + x4 = ctx->input[4]; + x5 = ctx->input[5]; + x6 = ctx->input[6]; + x7 = ctx->input[7]; + x8 = ctx->input[8]; + x9 = ctx->input[9]; + x10 = ctx->input[10]; + x11 = ctx->input[11]; + x12 = ctx->input[12]; + x13 = ctx->input[13]; + x14 = ctx->input[14]; + x15 = ctx->input[15]; + for (i = 10; i > 0; i --) { + QUARTERROUND( x0, x4, x8,x12) + QUARTERROUND( x1, x5, x9,x13) + QUARTERROUND( x2, x6,x10,x14) + QUARTERROUND( x3, x7,x11,x15) + QUARTERROUND( x0, x5,x10,x15) + QUARTERROUND( x1, x6,x11,x12) + QUARTERROUND( x2, x7, x8,x13) + QUARTERROUND( x3, x4, x9,x14) + } + x0 = PLUS(x0,ctx->input[0]); + x1 = PLUS(x1,ctx->input[1]); + x2 = PLUS(x2,ctx->input[2]); + x3 = PLUS(x3,ctx->input[3]); + x4 = PLUS(x4,ctx->input[4]); + x5 = PLUS(x5,ctx->input[5]); + x6 = PLUS(x6,ctx->input[6]); + x7 = PLUS(x7,ctx->input[7]); + x8 = PLUS(x8,ctx->input[8]); + x9 = PLUS(x9,ctx->input[9]); + x10 = PLUS(x10,ctx->input[10]); + x11 = PLUS(x11,ctx->input[11]); + x12 = PLUS(x12,ctx->input[12]); + x13 = PLUS(x13,ctx->input[13]); + x14 = PLUS(x14,ctx->input[14]); + x15 = PLUS(x15,ctx->input[15]); + U32TO8_LITTLE(ctx->output + 0,x0); + U32TO8_LITTLE(ctx->output + 4,x1); + U32TO8_LITTLE(ctx->output + 8,x2); + U32TO8_LITTLE(ctx->output + 12,x3); + U32TO8_LITTLE(ctx->output + 16,x4); + U32TO8_LITTLE(ctx->output + 20,x5); + U32TO8_LITTLE(ctx->output + 24,x6); + U32TO8_LITTLE(ctx->output + 28,x7); + U32TO8_LITTLE(ctx->output + 32,x8); + U32TO8_LITTLE(ctx->output + 36,x9); + U32TO8_LITTLE(ctx->output + 40,x10); + U32TO8_LITTLE(ctx->output + 44,x11); + U32TO8_LITTLE(ctx->output + 48,x12); + U32TO8_LITTLE(ctx->output + 52,x13); + U32TO8_LITTLE(ctx->output + 56,x14); + U32TO8_LITTLE(ctx->output + 60,x15); + /* Increment the 64-bit counter and, on overflow, the 64-bit nonce */ + /* (Incrementing the nonce is not standard but a reasonable default.) */ + if (++ ctx->input[12] == 0) + if (++ ctx->input[13] == 0) + if (++ ctx->input[14] == 0) + ++ ctx->input[15]; +} + +void chacha20_transform(chacha20_ctx * ctx, + const uint8_t * in, uint8_t * out, size_t len) +{ + int n = ctx->next; + for (/*nothing*/; len > 0; len--) { + if (n >= 64) { chacha20_block(ctx); n = 0; } + *out++ = *in++ ^ ctx->output[n++]; + } + ctx->next = n; +} + +void chacha20_extract(chacha20_ctx * ctx, + uint8_t * out, size_t len) +{ + int n = ctx->next; + for (/*nothing*/; len > 0; len--) { + if (n >= 64) { chacha20_block(ctx); n = 0; } + *out++ = ctx->output[n++]; + } + ctx->next = n; +} + +void chacha20_init(chacha20_ctx * ctx, + const uint8_t * key, size_t key_length, + const uint8_t iv[8], + uint64_t counter) +{ + const uint8_t *constants = + (uint8_t *) (key_length == 32 ? "expand 32-byte k" : "expand 16-byte k"); + assert (key_length == 16 || key_length == 32); + ctx->input[0] = U8TO32_LITTLE(constants + 0); + ctx->input[1] = U8TO32_LITTLE(constants + 4); + ctx->input[2] = U8TO32_LITTLE(constants + 8); + ctx->input[3] = U8TO32_LITTLE(constants + 12); + ctx->input[4] = U8TO32_LITTLE(key + 0); + ctx->input[5] = U8TO32_LITTLE(key + 4); + ctx->input[6] = U8TO32_LITTLE(key + 8); + ctx->input[7] = U8TO32_LITTLE(key + 12); + if (key_length == 32) key += 16; + ctx->input[8] = U8TO32_LITTLE(key + 0); + ctx->input[9] = U8TO32_LITTLE(key + 4); + ctx->input[10] = U8TO32_LITTLE(key + 8); + ctx->input[11] = U8TO32_LITTLE(key + 12); + ctx->input[12] = (uint32_t) counter; + ctx->input[13] = (uint32_t) (counter >> 32); + ctx->input[14] = U8TO32_LITTLE(iv + 0); + ctx->input[15] = U8TO32_LITTLE(iv + 4); + ctx->next = 64; +} diff --git a/src/chacha20.h b/src/chacha20.h new file mode 100644 index 0000000..26ba1fd --- /dev/null +++ b/src/chacha20.h @@ -0,0 +1,23 @@ +/* Based on D. J. Bernstein's chacha-regs.c version 200801118, + https://cr.yp.to/streamciphers/timings/estreambench/submissions/salsa20/chacha8/regs/chacha.c + The initial code is in the public domain */ + +#include <stddef.h> +#include <stdint.h> + +typedef struct { + uint32_t input[16]; /* The current state */ + uint8_t output[64]; /* Output data for the current state */ + int next; /* Index of next unused byte in output */ +} chacha20_ctx; + +void chacha20_init(chacha20_ctx * ctx, + const uint8_t * key, size_t key_length, + const uint8_t iv[8], + uint64_t ctr); + +void chacha20_extract(chacha20_ctx * ctx, + uint8_t * out, size_t len); + +void chacha20_transform(chacha20_ctx * ctx, + const uint8_t * in, uint8_t * out, size_t len); diff --git a/src/cryptokit.ml b/src/cryptokit.ml index 0cda7a7..597139a 100644 --- a/src/cryptokit.ml +++ b/src/cryptokit.ml @@ -16,6 +16,15 @@ let wipe_bytes s = Bytes.fill s 0 (Bytes.length s) '\000' let wipe_string s = wipe_bytes (Bytes.unsafe_of_string s) +let shl1_bytes src soff dst doff len = + let rec shl1 carry i = + if i >= 0 then begin + let n = Char.code (Bytes.get src (soff + i)) in + Bytes.set dst (doff + i) (Char.unsafe_chr ((n lsl 1) lor carry)); + shl1 (n lsr 7) (i - 1) + end + in shl1 0 (len - 1) + type error = | Wrong_key_size | Wrong_IV_size @@ -53,6 +62,9 @@ external des_cook_key : string -> int -> dir -> bytes = "caml_des_cook_key" external des_transform : bytes -> bytes -> int -> bytes -> int -> unit = "caml_des_transform" external arcfour_cook_key : string -> bytes = "caml_arcfour_cook_key" external arcfour_transform : bytes -> bytes -> int -> bytes -> int -> int -> unit = "caml_arcfour_transform_bytecode" "caml_arcfour_transform" +external chacha20_cook_key : string -> bytes -> int64 -> bytes = "caml_chacha20_cook_key" +external chacha20_transform : bytes -> bytes -> int -> bytes -> int -> int -> unit = "caml_chacha20_transform_bytecode" "caml_chacha20_transform" +external chacha20_extract : bytes -> bytes -> int -> int -> unit = "caml_chacha20_extract" external sha1_init: unit -> bytes = "caml_sha1_init" external sha1_update: bytes -> bytes -> int -> int -> unit = "caml_sha1_update" @@ -70,7 +82,7 @@ external sha384_final: bytes -> string = "caml_sha384_final" type sha3_context external sha3_init: int -> sha3_context = "caml_sha3_init" external sha3_absorb: sha3_context -> bytes -> int -> int -> unit = "caml_sha3_absorb" -external sha3_extract: sha3_context -> string = "caml_sha3_extract" +external sha3_extract: bool -> sha3_context -> string = "caml_sha3_extract" external sha3_wipe: sha3_context -> unit = "caml_sha3_wipe" external ripemd160_init: unit -> bytes = "caml_ripemd160_init" external ripemd160_update: bytes -> bytes -> int -> int -> unit = "caml_ripemd160_update" @@ -697,7 +709,7 @@ class cipher_padded_decrypt (padding : Padding.scheme) oend <- oend + valid end -(* Wrapping of a block cipher as a MAC *) +(* Wrapping of a block cipher as a MAC, using CBC mode *) class mac ?iv:iv_init ?(pad: Padding.scheme option) (cipher : block_cipher) = let blocksize = cipher#blocksize in @@ -784,6 +796,27 @@ class mac_final_triple ?iv ?pad (cipher1 : block_cipher) super#wipe; cipher2#wipe; cipher3#wipe end +(* Wrapping of a block ciper as a MAC, in CMAC mode (a.k.a. OMAC1) *) + +class cmac ?iv:iv_init (cipher : block_cipher) k1 k2 = + object (self) + inherit mac ?iv:iv_init cipher as super + + method result = + let blocksize = cipher#blocksize in + let k' = + if used = blocksize then k1 else (Padding._8000#pad buffer used; k2) in + xor_bytes iv 0 buffer 0 blocksize; + xor_bytes k' 0 buffer 0 blocksize; + cipher#transform buffer 0 iv 0; + used <- 0; (* really useful? *) + Bytes.to_string iv + + method wipe = + super#wipe; + wipe_bytes k1; + wipe_bytes k2 + end end (* Stream ciphers *) @@ -812,6 +845,23 @@ class arcfour key = wipe_bytes ckey end +class chacha20 ?iv ?(ctr = 0L) key = + object + val ckey = + let iv = Block.make_initial_iv 8 iv in + if String.length key = 16 || String.length key = 32 + then chacha20_cook_key key iv ctr + else raise(Error Wrong_key_size) + method transform src src_ofs dst dst_ofs len = + if len < 0 + || src_ofs < 0 || src_ofs > Bytes.length src - len + || dst_ofs < 0 || dst_ofs > Bytes.length dst - len + then invalid_arg "chacha20#transform"; + chacha20_transform ckey src src_ofs dst dst_ofs len + method wipe = + wipe_bytes ckey + end + (* Wrapping of a stream cipher as a cipher *) class cipher (cipher : stream_cipher) = @@ -972,7 +1022,7 @@ let sha2 sz = | 512 -> new sha512 | _ -> raise (Error Wrong_key_size) -class sha3 sz = +class sha3 sz official = object(self) val context = if sz = 224 || sz = 256 || sz = 384 || sz = 512 @@ -981,7 +1031,7 @@ class sha3 sz = method hash_size = sz / 8 method add_substring src ofs len = if ofs < 0 || len < 0 || ofs > Bytes.length src - len - then invalid_arg "sha3#add_substring"; + then invalid_arg ((if official then "sha3" else "keccak")^"#add_substring"); sha3_absorb context src ofs len method add_string src = sha3_absorb context (Bytes.unsafe_of_string src) 0 (String.length src) @@ -989,13 +1039,14 @@ class sha3 sz = self#add_string (String.make 1 c) method add_byte b = self#add_char (Char.unsafe_chr b) - method result = - sha3_extract context + method result = sha3_extract official context method wipe = sha3_wipe context end -let sha3 sz = new sha3 sz +let sha3 sz = new sha3 sz true + +let keccak sz = new sha3 sz false class ripemd160 = object(self) @@ -1104,6 +1155,9 @@ let triple_des ?mode ?pad ?iv key dir = let arcfour key dir = new Stream.cipher (new Stream.arcfour key) +let chacha20 ?iv ?ctr key dir = + new Stream.cipher (new Stream.chacha20 key ?iv ?ctr) + end (* The hmac construction *) @@ -1176,6 +1230,20 @@ let des_final_triple_des ?iv ?pad key = wipe_string k1; wipe_string k2; wipe_string k3; new Block.mac_final_triple ?iv ?pad c1 c2 c3 +let aes_cmac ?iv key = + let cipher = new Block.aes_encrypt key in + let b = Bytes.make 16 '\000' in + let l = Bytes.create 16 in + cipher#transform b 0 l 0; (* l = AES-128(K, 000...000 *) + Bytes.set b 15 '\x87'; (* b = the Rb constant *) + let k1 = Bytes.create 16 in + shl1_bytes l 0 k1 0 16; + if Char.code (Bytes.get l 0) land 0x80 > 0 then xor_bytes b 0 k1 0 16; + let k2 = Bytes.create 16 in + shl1_bytes k1 0 k2 0 16; + if Char.code (Bytes.get k1 0) land 0x80 > 0 then xor_bytes b 0 k2 0 16; + wipe_bytes l; + new Block.cmac ?iv cipher k1 k2 end (* Random number generation *) @@ -1314,28 +1382,38 @@ let secure_rng = class pseudo_rng seed = let _ = if String.length seed < 16 then raise (Error Seed_too_short) in object (self) - val cipher = - new Block.cbc_encrypt (new Block.aes_encrypt (String.sub seed 0 16)) - val state = - let s = Bytes.make 71 '\001' in - String.blit seed 0 s 0 (min 55 (String.length seed)); - s + val ckey = + let l = String.length seed in + chacha20_cook_key + (if l >= 32 then String.sub seed 0 32 + else if l > 16 then seed ^ String.make (32 - l) '\000' + else seed) + (Bytes.make 8 '\000') 0L + method random_bytes buf ofs len = + if len < 0 || ofs < 0 || ofs > Bytes.length buf - len + then invalid_arg "pseudo_rng#random_bytes" + else chacha20_extract ckey buf ofs len + method wipe = + wipe_bytes ckey; wipe_string seed +end + +let pseudo_rng seed = new pseudo_rng seed + +class pseudo_rng_aes_ctr seed = + let _ = if String.length seed < 16 then raise (Error Seed_too_short) in + object (self) + val cipher = new Block.aes_encrypt (String.sub seed 0 16) + val ctr = Bytes.make 16 '\000' val obuf = Bytes.create 16 val mutable opos = 16 method random_bytes buf ofs len = if len > 0 then begin if opos >= 16 then begin - (* Clock the lagged Fibonacci generator 16 times *) - for i = 55 to 70 do - Bytes.set state i - (Char.unsafe_chr(Char.code (Bytes.get state (i-55)) + - Char.code (Bytes.get state (i-24)))) - done; - (* Encrypt resulting 16 bytes *) - cipher#transform state 55 obuf 0; - (* Shift Fibonacci generator by 16 bytes *) - Bytes.blit state 16 state 0 55; + (* Encrypt the counter *) + cipher#transform ctr 0 obuf 0; + (* Increment the counter *) + Block.increment_counter ctr 0 15; (* We have 16 fresh bytes of pseudo-random data *) opos <- 0 end; @@ -1349,7 +1427,7 @@ class pseudo_rng seed = wipe_bytes obuf; wipe_string seed end - let pseudo_rng seed = new pseudo_rng seed +let pseudo_rng_aes_ctr seed = new pseudo_rng_aes_ctr seed end diff --git a/src/cryptokit.mli b/src/cryptokit.mli index ebf2f8e..49d42de 100644 --- a/src/cryptokit.mli +++ b/src/cryptokit.mli @@ -30,7 +30,7 @@ [ocamlopt unix.cmxa nums.cmxa cryptokit.cmxa]. *) -(** {6 General-purpose abstract interfaces} *) +(** {1 General-purpose abstract interfaces} *) (** A <I>transform</I> is an arbitrary mapping from sequences of characters to sequences of characters. Examples of transforms include @@ -207,7 +207,7 @@ val hash_channel: hash -> ?len:int -> in_channel -> string The hash [h] is wiped before returning, hence can no longer be used for further hash computations. *) -(** {6 Utilities: random numbers and padding schemes} *) +(** {1 Utilities: random numbers and padding schemes} *) (** The [Random] module provides random and pseudo-random number generators suitable for generating cryptographic keys, nonces, or challenges. *) @@ -274,19 +274,30 @@ module Random : sig (** [pseudo_rng seed] returns a pseudo-random number generator seeded by the string [seed]. [seed] must contain at least 16 characters, and can be arbitrarily longer than this, - except that only the first 55 characters are used. - Technically, the first 16 characters of [seed] are used as - a key for the AES cipher in CBC mode, which encrypts the output - of a lagged Fibonacci generator [X(i) = (X(i-24) + X(i-55)) mod 256] - seeded with the first 55 characters of [seed]. - While this generator is believed to have good statistical properties, - it still does not generate ``true'' randomness: the entropy of - the strings it creates cannot exceed the entropy contained in - the seed. As a typical use, + except that only the first 32 characters are used. + The seed is used as a key for the Chacha20 stream cipher. + The generated pseudo-random data is the result of encrypting + the all-zero input with Chacha20. + While this generator is believed to have very good statistical + properties, it still does not generate ``true'' randomness: + the entropy of the byte strings it produces cannot exceed the + entropy contained in the seed. As a typical use, [Random.pseudo_rng (Random.string Random.secure_rng 20)] returns a generator that can generate arbitrarily long strings of pseudo-random data without delays, and with a total entropy of approximately 160 bits. *) + + val pseudo_rng_aes_ctr: string -> rng + (** This is another pseudo-random number generator, based on the AES + block cipher in counter mode. It is slightly slower than [pseudo_rng] + while having similar randomness characteristics. + The only reason to use it instead of [pseudo_rng] is that AES + has been cryptanalyzed even more than Chacha20. + The [seed] argument must contain at least 16 characters. Only the + first 16 characters are used, as an AES key. The generated + pseudo-random data is the result of encrypting the 128-bit integers + [0, 1, 2, ...] with this key. *) + end (** The [Padding] module defines a generic interface @@ -327,7 +338,7 @@ module Padding : sig by as many [0] bytes as needed to fill the block. *) end -(** {6 Cryptographic primitives (simplified interface)} *) +(** {1 Cryptographic primitives (simplified interface)} *) (** The [Cipher] module implements the AES, DES, Triple-DES, ARCfour and Blowfish symmetric ciphers. Symmetric ciphers are presented @@ -372,6 +383,8 @@ module Cipher : sig [n] must be between [1] and [blocksize] included. [CTR] is equivalent to [CTR_N blocksize]. *) +(** {2 Recommended ciphers} *) + val aes: ?mode:chaining_mode -> ?pad:Padding.scheme -> ?iv:string -> string -> direction -> transform (** AES is the Advanced Encryption Standard, also known as Rijndael. @@ -399,6 +412,34 @@ module Cipher : sig The [aes] function returns a transform that performs encryption or decryption, depending on the direction argument. *) + val chacha20: ?iv:string -> ?ctr:int64 -> string -> direction -> transform + (** Chacha20 is a stream cipher proposed by D. J. Bernstein in 2008. + + The Chacha20 cipher is a stream cipher, not a block cipher. + Hence, its natural block size is 1, and no padding is + required. Chaining modes do not apply. A feature of stream + ciphers is that the xor of two ciphertexts obtained with the + same key is the xor of the corresponding plaintexts, which + allows various attacks. Hence, the same key must never be + reused. + + The string argument is the key; its length must be either 16 + or (better) 32. + + The optional [iv] argument is the initialization vector (also + called nonce) that can be used to diversify the key. If present, + it must be 8 characters long. If absent, it is taken to be + eight zero bytes. + + The optional [ctr] argument is the initial value of the internal + counter. If absent, it defaults to 0. + + The direction argument is present for consistency with the + other ciphers only, and is actually ignored: for all stream + ciphers, decryption is the same function as encryption. *) + +(** {2 Weaker, older ciphers, not recommended for new applications} *) + val des: ?mode:chaining_mode -> ?pad:Padding.scheme -> ?iv:string -> string -> direction -> transform (** DES is the Data Encryption Standard. Very popular in the past, @@ -421,7 +462,10 @@ module Cipher : sig This results in a 112-bit or 168-bit key length that resists brute-force attacks. However, the three encryptions required on each block make this cipher quite slow (4 times slower than - AES). The arguments to the [triple_des] function have the + AES). Moreover, the small block size (64 bits) opens the way + to collision-based attacks. Triple DES should therefore be + considered as relatively weak encryption. + The arguments to the [triple_des] function have the same meaning as for the {!Cryptokit.Cipher.aes} function. The key argument is a string of length 16 or 24, representing the concatenation of the key parts [k1], [k2], and optionally @@ -436,7 +480,10 @@ module Cipher : sig not to use ARCfour in a commercial product. ARCfour is popular for its speed: approximately 2 times faster - than AES. It accepts any key length up to 2048 bits. + than AES. It accepts any key length up to 2048 bits. However, + the security of ARCfour is being questioned owing to several + statistical biases in its output. It should not be used for + new applications. The ARCfour cipher is a stream cipher, not a block cipher. Hence, its natural block size is 1, and no padding is @@ -457,8 +504,14 @@ module Cipher : sig (** Blowfish is a fast block cipher proposed by B.Schneier in 1994. It processes data by blocks of 64 bits (8 bytes), and supports keys of 32 to 448 bits. + + The small block size (64 bits) of Blowfish opens the way to + some collision-based attacks. Depending on the application, + ciphers with larger block size should be preferred. + The string argument is the key; its length must be between 4 and 56. + The direction argument specifies whether encryption or decryption is to be performed. @@ -491,20 +544,23 @@ end hash of a text can be used as a compact replacement for this text for the purposes of ensuring integrity of the text. *) module Hash : sig - val sha1: unit -> hash - (** SHA-1 is the Secure Hash Algorithm revision 1. It is a NIST - standard, is widely used, and produces 160-bit hashes (20 bytes). - Recent results suggest that it may not be collision-resistant. *) - val sha2: int -> hash - (** SHA-2, another NIST standard for cryptographic hashing, produces - hashes of 224, 256, 384, or 512 bits (24, 32, 48 or 64 bytes). - The parameter is the desired size of the hash, in - bits. It must be one of 224, 256, 384 or 512. *) + +(** {2 Recommended hashes} *) + val sha3: int -> hash (** SHA-3, the latest NIST standard for cryptographic hashing, produces hashes of 224, 256, 384 or 512 bits (24, 32, 48 or 64 bytes). The parameter is the desired size of the hash, in bits. It must be one of 224, 256, 384 or 512. *) + val keccak: int -> hash + (** The Keccak submission for the SHA-3 is very similar to [sha3] but + uses a slightly different padding. The parameter is the same as + that of [sha3]. *) + val sha2: int -> hash + (** SHA-2, another NIST standard for cryptographic hashing, produces + hashes of 224, 256, 384, or 512 bits (24, 32, 48 or 64 bytes). + The parameter is the desired size of the hash, in + bits. It must be one of 224, 256, 384 or 512. *) val sha224: unit -> hash (** SHA-224 is SHA-2 specialized to 224 bit hashes (24 bytes). *) val sha256: unit -> hash @@ -514,12 +570,19 @@ module Hash : sig val sha512: unit -> hash (** SHA-512 is SHA-2 specialized to 512 bit hashes (64 bytes). *) val ripemd160: unit -> hash - (** RIPEMD-160 produces 160-bit hashes (20 bytes). *) + (** RIPEMD-160 produces 160-bit hashes (20 bytes). *) + +(** {2 Weak hashes, not recommended for new applications} *) + + val sha1: unit -> hash + (** SHA-1 is the Secure Hash Algorithm revision 1. It is a NIST + standard, is widely used, and produces 160-bit hashes (20 bytes). + While popular in many legacy applications, it is now known + to be insecure. In particular, it is not collision-resistant. *) val md5: unit -> hash (** MD5 is an older hash function, producing 128-bit hashes (16 bytes). While popular in many legacy applications, it is now known - to be insecure. In particular, it is not - collision-resistant. *) + to be insecure. In particular, it is not collision-resistant. *) end (** The [MAC] module implements message authentication codes, also @@ -534,7 +597,7 @@ end the text was authentified by someone who possesses the secret key. The module [MAC] provides five MAC functions based on the hashes - SHA-1, SHA256, SHA512, RIPEMD160 and MD5, and four MAC functions based on + SHA-1, SHA256, SHA512, RIPEMD160 and MD5, and five MAC functions based on the block ciphers AES, DES, and Triple-DES. *) module MAC: sig val hmac_sha1: string -> hash @@ -565,13 +628,25 @@ module MAC: sig applied to MD5. The returned hash values are 128 bits (16 bytes) long. The [key] argument is the MAC key; it can have any length, but a minimal length of 16 bytes is recommended. *) + val aes_cmac: ?iv:string -> string -> hash + (** [aes_cmac key] returns a MAC based on AES encryption in CMAC mode, + also known as OMAC1 mode. The input data is encrypted using + AES in CBC mode, with a special treatment of the final block + that makes this MAC suitable for input data of variable length. + The final value of the initialization vector is the MAC value. + Thus, the returned hash values are 128 bit (16 bytes) long. + The [key] argument is the MAC key; it must have length 16, 24, + or 32. The optional [iv] argument is the first value of the + initialization vector, and defaults to 0. *) val aes: ?iv:string -> ?pad:Padding.scheme -> string -> hash (** [aes key] returns a MAC based on AES encryption in CBC mode. - The ciphertext is discarded, and the final value of the - initialization vector is the MAC value. Thus, the returned - hash values are 128 bit (16 bytes) long. The [key] argument - is the MAC key; it must have length 16, 24, or 32. The - optional [iv] argument is the first value of the + Unlike [aes_cmac], there is no special treatment for the final + block, except padding it as per the optional [pad] argument. + This makes this MAC weak when used with input data of variable + length. (It is fine for data of fixed length, though.) + The returned hash values are 128 bit (16 bytes) long. The + [key] argument is the MAC key; it must have length 16, 24, or + 32. The optional [iv] argument is the first value of the initialization vector, and defaults to 0. The optional [pad] argument specifies a padding scheme to pad input to an integral number of 16-byte blocks. *) @@ -580,7 +655,7 @@ module MAC: sig The construction is identical to that used for the [aes] MAC. The key size is 64 bits (8 bytes), of which only 56 are used. The returned hash value has length 8 bytes. - Due to the small hash size and key size, this MAC is rather weak. *) + Due to the small hash size and key size, this MAC is weak. *) val triple_des: ?iv:string -> ?pad:Padding.scheme -> string -> hash (** [des key] returns a MAC based on triple DES encryption in CBC mode. The construction is identical to that used for the [aes] MAC. @@ -769,7 +844,7 @@ module DH: sig counter until [numbytes] bytes have been obtained. *) end -(** {6 Advanced, compositional interface to block ciphers +(** {1 Advanced, compositional interface to block ciphers and stream ciphers} *) (** The [Block] module provides classes that implements @@ -795,7 +870,7 @@ module Block : sig end (** Abstract interface for a block cipher. *) - (** {6 Deriving transforms and hashes from block ciphers} *) + (** {1 Deriving transforms and hashes from block ciphers} *) class cipher: block_cipher -> transform (** Wraps a block cipher as a general transform. The transform @@ -835,7 +910,7 @@ module Block : sig because of the additional final encryption through [c2] and [c3]. *) - (** {6 Some block ciphers: AES, DES, triple DES, Blowfish} *) + (** {1 Some block ciphers: AES, DES, triple DES, Blowfish} *) class aes_encrypt: string -> block_cipher (** The AES block cipher, in encryption mode. The string argument @@ -861,7 +936,7 @@ module Block : sig class blowfish_decrypt: string -> block_cipher (** The Blowfish block cipher, in decryption mode. *) - (** {6 Chaining modes} *) + (** {1 Chaining modes} *) class cbc_encrypt: ?iv: string -> block_cipher -> block_cipher (** Add Cipher Block Chaining (CBC) to the given block cipher @@ -938,9 +1013,21 @@ module Stream : sig This stream cipher works by xor-ing the input with the output of a key-dependent pseudo random number generator. Thus, decryption is the same function as encryption. *) + + class chacha20: ?iv:string -> ?ctr:int64 -> string -> stream_cipher + (** The Chacha20 strea cipher. + The string argument is the key, and must be of length 16 or 32. + The optional [iv] argument is the initialization vector + (also known as the nonce). If present, it must be 8 bytes long. + If absent, it is taken to be eight zero bytes. + The optional [ctr] argument is the initial value of the internal + counter. If absent, it is taken to be 0. + This stream cipher works by xor-ing the input with the + output of a key-dependent pseudo random number generator. + Thus, decryption is the same function as encryption. *) end -(** {6 Encoding and compression of data} *) +(** {1 Encoding and compression of data} *) (** The [Base64] module supports the encoding and decoding of binary data in base 64 format, using only alphanumeric @@ -1001,7 +1088,7 @@ module Zlib: sig (** Return a transform that decompresses its input. *) end -(** {6 Error reporting} *) +(** {1 Error reporting} *) (** Error codes for this library. *) type error = @@ -1046,7 +1133,7 @@ exception Error of error (** Exception raised by functions in this library to report error conditions. *) -(** {6 Miscellaneous utilities} *) +(** {1 Miscellaneous utilities} *) val wipe_bytes : bytes -> unit (** [wipe_bytes s] overwrites [s] with zeroes. Can be used diff --git a/src/keccak.c b/src/keccak.c index ef0ae5e..c710d68 100644 --- a/src/keccak.c +++ b/src/keccak.c @@ -153,14 +153,15 @@ void SHA3_absorb(struct SHA3Context * ctx, ctx->numbytes = len; } -void SHA3_extract(struct SHA3Context * ctx, +void SHA3_extract(unsigned char padding, + struct SHA3Context * ctx, unsigned char * output) { int i, j, n; /* Apply final padding */ n = ctx->numbytes; - ctx->buffer[n] = 0x06; + ctx->buffer[n] = padding; n++; memset(ctx->buffer + n, 0, ctx->rsiz - n); ctx->buffer[ctx->rsiz - 1] |= 0x80; diff --git a/src/keccak.h b/src/keccak.h index 98ac150..790d82a 100644 --- a/src/keccak.h +++ b/src/keccak.h @@ -16,5 +16,6 @@ extern void SHA3_absorb(struct SHA3Context * ctx, unsigned char * data, unsigned long len); -extern void SHA3_extract(struct SHA3Context * ctx, +extern void SHA3_extract(unsigned char padding, + struct SHA3Context * ctx, unsigned char * output); diff --git a/src/libcryptokit_stubs.clib b/src/libcryptokit_stubs.clib index 6fd5022..94cc08d 100644 --- a/src/libcryptokit_stubs.clib +++ b/src/libcryptokit_stubs.clib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 8925748b522861580cf6f17b03f49c4b) +# DO NOT EDIT (digest: c7ac7a160eaa5e93a581a4efbe9317de) aesni.o arcfour.o stubs-arcfour.o @@ -23,4 +23,6 @@ stubs-rng.o stubs-zlib.o keccak.o stubs-sha3.o +chacha20.o +stubs-chacha20.o # OASIS_STOP diff --git a/src/stubs-chacha20.c b/src/stubs-chacha20.c new file mode 100644 index 0000000..2d062aa --- /dev/null +++ b/src/stubs-chacha20.c @@ -0,0 +1,58 @@ +/***********************************************************************/ +/* */ +/* The Cryptokit library */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file LICENSE. */ +/* */ +/***********************************************************************/ + +/* Stub code for Chacha20 */ + +#include "chacha20.h" +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> + +#define Cooked_key_size (sizeof(chacha20_ctx)) +#define Key_val(v) ((chacha20_ctx *) String_val(v)) + +CAMLprim value caml_chacha20_cook_key(value key, value iv, value counter) +{ + CAMLparam2(key, iv); + value ckey = alloc_string(Cooked_key_size); + chacha20_init(Key_val(ckey), + (unsigned char *) String_val(key), caml_string_length(key), + (unsigned char *) String_val(iv), Int64_val(counter)); + CAMLreturn(ckey); +} + +CAMLprim value caml_chacha20_transform(value ckey, value src, value src_ofs, + value dst, value dst_ofs, value len) +{ + chacha20_transform(Key_val(ckey), + &Byte_u(src, Long_val(src_ofs)), + &Byte_u(dst, Long_val(dst_ofs)), + Long_val(len)); + return Val_unit; +} + +CAMLprim value caml_chacha20_transform_bytecode(value * argv, int argc) +{ + return caml_chacha20_transform(argv[0], argv[1], argv[2], + argv[3], argv[4], argv[5]); +} + +CAMLprim value caml_chacha20_extract(value ckey, + value dst, value dst_ofs, value len) +{ + chacha20_extract(Key_val(ckey), + &Byte_u(dst, Long_val(dst_ofs)), + Long_val(len)); + return Val_unit; +} + diff --git a/src/stubs-sha3.c b/src/stubs-sha3.c index df8ac30..b496f73 100644 --- a/src/stubs-sha3.c +++ b/src/stubs-sha3.c @@ -58,13 +58,23 @@ CAMLprim value caml_sha3_absorb(value ctx, return Val_unit; } -CAMLprim value caml_sha3_extract(value ctx) + +/* On page 9 of Keccak Implementation Overview (Version 3.2) + http://keccak.noekeon.org/Keccak-implementation-3.2.pdf, + there is a figure `0x01` as the padding byte. */ +static const unsigned keccak_padding = 0x01; + +/* In a similar, updated description at http://keccak.noekeon.org/specs_summary.html, + on Table 3, `0x06` is shown as the relevant padding byte. */ +static const unsigned sha3_padding = 0x06; + +CAMLprim value caml_sha3_extract(value official, value ctx) { - CAMLparam1(ctx); + CAMLparam2(official, ctx); CAMLlocal1(res); res = alloc_string(Context_val(ctx)->hsiz); - SHA3_extract(Context_val(ctx), &Byte_u(res, 0)); + SHA3_extract(Bool_val(official) ? sha3_padding : keccak_padding, Context_val(ctx), &Byte_u(res, 0)); CAMLreturn(res); } diff --git a/test/.depend b/test/.depend deleted file mode 100644 index e69de29..0000000 --- a/test/.depend +++ /dev/null diff --git a/test/prngtest.ml b/test/prngtest.ml new file mode 100644 index 0000000..b6fb6a3 --- /dev/null +++ b/test/prngtest.ml @@ -0,0 +1,49 @@ +(***********************************************************************) +(* *) +(* The Cryptokit library *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Paris *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file LICENSE. *) +(* *) +(***********************************************************************) + +(* Generate pseudorandom data on stdout, for testing with "dieharder" *) + +open Cryptokit + +let output_pr_data rng = + let b = Bytes.create 64 in + while true do + rng#random_bytes b 0 64; + output stdout b 0 64 + done + +let usage() = + prerr_string {|Usage: + ./prngtest.native aes-ctr | dieharder -a -g 200 + ./prngtest.native chacha20 | dieharder -a -g 200 + ./prngtest.native hardware | dieharder -a -g 200 +Warning: each dieharder run takes a long time. +|}; + exit 2 + +let _ = + let seed = + if Array.length Sys.argv > 2 + then Sys.argv.(2) + else "Supercalifragilistusexpialidolcius" in + let rng = + if Array.length Sys.argv > 1 then begin + match Sys.argv.(1) with + | "aes-ctr" -> Random.pseudo_rng_aes_ctr seed + | "chacha20" -> Random.pseudo_rng seed + | "hardware" -> Random.hardware_rng () + | _ -> usage() + end else usage() in + output_pr_data rng + + diff --git a/test/speedtest.ml b/test/speedtest.ml index 64555a4..0552d90 100644 --- a/test/speedtest.ml +++ b/test/speedtest.ml @@ -74,6 +74,10 @@ let _ = (raw_stream_cipher (new Stream.arcfour "0123456789ABCDEF") 4000000 16); time_fn "Raw ARCfour, 64_000_000 bytes, 64-byte chunks" (raw_stream_cipher (new Stream.arcfour "0123456789ABCDEF") 1000000 64); + time_fn "Raw Chacha20, 64_000_000 bytes, 16-byte chunks" + (raw_stream_cipher (new Stream.arcfour "0123456789ABCDEF") 4000000 16); + time_fn "Raw Chacha20, 64_000_000 bytes, 64-byte chunks" + (raw_stream_cipher (new Stream.arcfour "0123456789ABCDEF") 1000000 64); time_fn "Raw Blowfish 128, 64_000_000 bytes" (raw_block_cipher (new Block.blowfish_encrypt "0123456789ABCDEF") 8000000); time_fn "Wrapped AES 128 CBC, 64_000_000 bytes" @@ -88,6 +92,8 @@ let _ = (transform (Cipher.triple_des "0123456789ABCDEF" Cipher.Encrypt) 1000000 16); time_fn "Wrapped ARCfour, 64_000_000 bytes" (transform (Cipher.arcfour "0123456789ABCDEF" Cipher.Encrypt) 4000000 16); + time_fn "Wrapped Chacha20, 64_000_000 bytes" + (transform (Cipher.chacha20 "0123456789ABCDEF" Cipher.Encrypt) 4000000 16); time_fn "Wrapped Blowfish 128 CBC, 64_000_000 bytes" (transform (Cipher.blowfish "0123456789ABCDEF" Cipher.Encrypt) 4000000 16); time_fn "SHA-1, 64_000_000 bytes, 16-byte chunks" @@ -106,8 +112,10 @@ let _ = (hash (Hash.sha256()) 4000000 16); time_fn "MD5, 64_000_000 bytes, 16-byte chunks" (hash (Hash.md5()) 4000000 16); - time_fn "AES MAC, 64_000_000 bytes, 16-byte chunks" - (hash (MAC.aes "0123456789ABCDEF") 4000000 16); + time_fn "AES CMAC, 64_000_000 bytes, 16-byte chunks" + (hash (MAC.aes_cmac "0123456789ABCDEF") 4000000 16); + time_fn "HMAC-SHA1, 64_000_000 bytes, 16-byte chunks" + (hash (MAC.hmac_sha1 "0123456789ABCDEF") 4000000 16); let prng = Random.pseudo_rng "supercalifragilistusexpialidolcius" in let key = time_fn "RSA key generation (2048 bits) x 10" @@ -122,6 +130,8 @@ let _ = (repeat 100 (fun () -> ignore(RSA.decrypt_CRT key ciphertext))); time_fn "PRNG, 64_000_000 bytes" (rng prng 1000000 64); + time_fn "PRNG AES CTR, 64_000_000 bytes" + (rng (Random.pseudo_rng_aes_ctr "supercalifragilistusexpialidolcius") 1000000 64); begin try let hr = Random.hardware_rng () in time_fn "Hardware RNG, 64_000_000 bytes" diff --git a/test/test.ml b/test/test.ml index 6c466a5..8e3eba6 100644 --- a/test/test.ml +++ b/test/test.ml @@ -205,6 +205,41 @@ let _ = c2#put_string (String.make 1024 'x'); test 9 c2#available_output 1024 +(* Chacha20 *) + +let _ = + testing_function "Chacha20"; + let do_test n1 n2 key nonce plain cipher counter = + let key = hex key + and nonce = hex nonce + and plain = hexbytes plain + and cipher = hexbytes cipher in + let c = new Stream.chacha20 ~iv:nonce ~ctr:counter key in + let d = new Stream.chacha20 ~iv:nonce ~ctr:counter key in + let res = Bytes.create (Bytes.length plain) in + c#transform plain 0 res 0 (Bytes.length plain); + test n1 res cipher; + d#transform cipher 0 res 0 (Bytes.length cipher); + test n2 res plain in + do_test 1 2 + "0000000000000000000000000000000000000000000000000000000000000000" + "0000000000000000" + "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" + "76b8e0ada0f13d90405d6ae55386bd28bdd219b8a08ded1aa836efcc8b770dc7da41597c5157488d7724e03fb8d84a376a43b8f41518a11cc387b669b2ee6586" + 0L; + do_test 3 4 + "0000000000000000000000000000000000000000000000000000000000000001" + "0000000000000002" + "416e79207375626d697373696f6e20746f20746865204945544620696e74656e6465642062792074686520436f6e7472696275746f7220666f72207075626c69636174696f6e20617320616c6c206f722070617274206f6620616e204945544620496e7465726e65742d4472616674206f722052464320616e6420616e792073746174656d656e74206d6164652077697468696e2074686520636f6e74657874206f6620616e204945544620616374697669747920697320636f6e7369646572656420616e20224945544620436f6e747269627574696f6e222e20537563682073746174656d656e747320696e636c756465206f72616c2073746174656d656e747320696e20494554462073657373696f6e732c2061732077656c6c206173207772697474656e20616e6420656c656374726f6e696320636f6d6d756e69636174696f6e73206d61646520617420616e792074696d65206f7220706c6163652c207768696368206172652061646472657373656420746f" + "a3fbf07df3fa2fde4f376ca23e82737041605d9f4f4f57bd8cff2c1d4b7955ec2a97948bd3722915c8f3d337f7d370050e9e96d647b7c39f56e031ca5eb6250d4042e02785ececfa4b4bb5e8ead0440e20b6e8db09d881a7c6132f420e52795042bdfa7773d8a9051447b3291ce1411c680465552aa6c405b7764d5e87bea85ad00f8449ed8f72d0d662ab052691ca66424bc86d2df80ea41f43abf937d3259dc4b2d0dfb48a6c9139ddd7f76966e928e635553ba76c5c879d7b35d49eb2e62b0871cdac638939e25e8a1e0ef9d5280fa8ca328b351c3c765989cbcf3daa8b6ccc3aaf9f3979c92b3720fc88dc95ed84a1be059c6499b9fda236e7e818b04b0bc39c1e876b193bfe5569753f88128cc08aaa9b63d1a16f80ef2554d7189c411f5869ca52c5b83fa36ff216b9c1d30062bebcfd2dc5bce0911934fda79a86f6e698ced759c3ff9b6477338f3da4f9cd8514ea9982ccafb341b2384dd902f3d1ab7ac61dd29c6f21ba5b862f3730e37cfdc4fd806c22f221" + 1L; + do_test 5 6 + "1c9240a5eb55d38af333888604f6b5f0473917c1402b80099dca5cbc207075c0" + "0000000000000002" + "2754776173206272696c6c69672c20616e642074686520736c6974687920746f7665730a446964206779726520616e642067696d626c6520696e2074686520776162653a0a416c6c206d696d737920776572652074686520626f726f676f7665732c0a416e6420746865206d6f6d65207261746873206f757467726162652e" + "62e6347f95ed87a45ffae7426f27a1df5fb69110044c0d73118effa95b01e5cf166d3df2d721caf9b21e5fb14c616871fd84c54f9d65b283196c7fe4f60553ebf39c6402c42234e32a356b3e764312a61a5532055716ead6962568f87d3f3f7704c6a8d1bcd1bf4d50d6154b6da731b187b58dfd728afa36757a797ac188d1" + 42L + (* Blowfish *) let _ = @@ -395,6 +430,60 @@ let _ = test 99 (hash_extremely_long (Hash.sha3 512)) (hex "235ffd53504ef836 a1342b488f483b39 6eabbfe642cf78ee 0d31feec788b23d0 d18d5c339550dd59 58a500d4b95363da 1b5fa18affc1bab2 292dc63b7d85097c") +(* Keccak *) +(* The test cases are taken from commit dec7e6dd8e5bbfe4534f7dd4c3fb4429575b23f8 *) +let _ = + testing_function "Keccak"; + let hash n s = hash_string (Hash.keccak n) s in + let s = "abc" in + test 1 (hash 224 s) + (hex "c30411768506ebe1 c2871b1ee2e87d38 df342317300a9b97 a95ec6a8"); + test 2 (hash 256 s) + (hex "4e03657aea45a94f c7d47ba826c8d667 c0d1e6e33a64a036 ec44f58fa12d6c45"); + test 3 (hash 384 s) + (hex "f7df1165f033337b e098e7d288ad6a2f 74409d7a60b49c36 642218de161b1f99 f8c681e4afaf31a3 4db29fb763e3c28e"); + test 4 (hash 512 s) + (hex "18587dc2ea106b9a 1563e32b3312421c a164c7f1f07bc922 a9c83d77cea3a1e5 d0c6991073902537 2dc14ac964262937 9540c17e2a65b19d 77aa511a9d00bb96"); + let s = "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" in + test 5 (hash 224 s) + (hex "e51faa2b4655150b 931ee8d700dc202f 763ca5f962c529ea e55012b6"); + test 6 (hash 256 s) + (hex "45d3b367a6904e6e 8d502ee04999a7c2 7647f91fa845d456 525fd352ae3d7371"); + test 7 (hash 384 s) + (hex "b41e8896428f1bcb b51e17abd6acc980 52a3502e0d5bf7fa 1af949b4d3c855e7 c4dc2c390326b3f3 e74c7b1e2b9a3657"); + test 8 (hash 512 s) + (hex "6aa6d3669597df6d 5a007b00d09c2079 5b5c4218234e1698 a944757a488ecdc0 9965435d97ca32c3 cfed7201ff30e070 cd947f1fc12b9d92 14c467d342bcba5d"); + let s = "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" in + test 9 (hash 224 s) + (hex "344298994b1b0687 3eae2ce739c425c4 7291a2e24189e01b 524f88dc"); + test 10 (hash 256 s) + (hex "f519747ed599024f 3882238e5ab43960 132572b7345fbeb9 a90769dafd21ad67"); + test 11 (hash 384 s) + (hex "cc063f3468513536 8b34f7449108f6d1 0fa727b09d696ec5 331771da46a923b6 c34dbd1d4f77e595 689c1f3800681c28"); + test 12 (hash 512 s) + (hex "ac2fb35251825d3a a48468a9948c0a91 b8256f6d97d8fa41 60faff2dd9dfcc24 f3f1db7a983dad13 d53439ccac0b37e2 4037e7b95f80f59f 37a2f683c4ba4682"); + test 13 (hash_million_a (Hash.keccak 224)) + (hex "19f9167be2a04c43 abd0ed554788101b 9c339031acc8e146 8531303f"); + test 14 (hash_million_a (Hash.keccak 256)) + (hex "fadae6b49f129bbb 812be8407b7b2894 f34aecf6dbd1f9b0 f0c7e9853098fc96"); + test 15 (hash_million_a (Hash.keccak 384)) + (hex "0c8324e1ebc18282 2c5e2a086cac07c2 fe00e3bce61d01ba 8ad6b71780e2dec5 fb89e5ae90cb593e 57bc6258fdd94e17"); + test 16 (hash_million_a (Hash.keccak 512)) + (hex "5cf53f2e556be5a6 24425ede23d0e8b2 c7814b4ba0e4e09c bbf3c2fac7056f61 e048fc341262875e bc58a5183fea6514 47124370c1ebf4d6 c89bc9a7731063bb"); + let s = "" in + test 17 (hash 224 s) + (hex "f71837502ba8e108 37bdd8d365adb855 91895602fc552b48 b7390abd"); + test 18 (hash 256 s) + (hex "c5d2460186f7233c 927e7db2dcc703c0 e500b653ca82273b 7bfad8045d85a470"); + test 19 (hash 384 s) + (hex "2c23146a63a29acf 99e73b88f8c24eaa 7dc60aa771780ccc 006afbfa8fe2479b 2dd2b21362337441 ac12b515911957ff"); + test 20 (hash 512 s) + (hex "0eab42de4c3ceb92 35fc91acffe746b2 9c29a8c366b7c60e 4e67c466f36a4304 c00fa9caf9d87976 ba469bcbe06713b4 35f091ef2769fb16 0cdab33d3670680e"); + test 98 (hash_extremely_long (Hash.keccak 256)) + (hex "5f313c39963dcf79 2b5470d4ade9f3a3 56a3e4021748690a 958372e2b06f82a4"); + test 99 (hash_extremely_long (Hash.keccak 512)) + (hex "3e122edaf3739823 1cfaca4c7c216c9d 66d5b899ec1d7ac6 17c40c7261906a45 fc01617a021e5da3 bd8d4182695b5cb7 85a28237cbb16759 0e34718e56d8aab8") + (* RIPEMD-160 *) let _ = testing_function "RIPEMD-160"; @@ -605,6 +694,32 @@ let _ = (String.make 50 '\221')) (hex "56be34521d144c88dbb8c733f0e8b3f6") +(* AES-CMAC (from RFC4493) *) + +let _ = + testing_function "AES-CMAC"; + let key = hex "2b7e1516 28aed2a6 abf71588 09cf4f3c" in + let msg = hex "6bc1bee2 2e409f96 e93d7e11 7393172a \ + ae2d8a57 1e03ac9c 9eb76fac 45af8e51 \ + 30c81c46 a35ce411 e5fbc119 1a0a52ef \ + f69f2445 df4f9b17 ad2b417b e66c3710" in + test 1 + (hash_string (MAC.aes_cmac key) + "") + (hex "bb1d6929 e9593728 7fa37d12 9b756746"); + test 2 + (hash_string (MAC.aes_cmac key) + (String.sub msg 0 16)) + (hex "070a16b4 6b4d4144 f79bdd9d d04a287c"); + test 3 + (hash_string (MAC.aes_cmac key) + (String.sub msg 0 40)) + (hex "dfa66747 de9ae630 30ca3261 1497c827"); + test 4 + (hash_string (MAC.aes_cmac key) + msg) + (hex "51f0bebf 7e3b9d92 fc497417 79363cfe") + (* RSA *) let some_rsa_key = { @@ -777,7 +892,7 @@ The quick brown fox jumps over the lazy dog. (* Random numbers *) (* This is not a serious statistical test of Cryptokit's RNGs - (use Diehard or TestU01 for this). Rather, it's a simplistic + (use Dieharder or TestU01 for this). Rather, it's a simplistic test intended to detect obvious bugs such as providing fewer random bytes than requested. *) @@ -808,25 +923,28 @@ let _ = testing_function "Random number generation"; printf " 1. PRNG: "; test_rng (Random.pseudo_rng "abcdefghijklmnopqrstuvwxyz"); - printf " 2. /dev/urandom: "; + printf " 2. PRNG based on AES CTR: "; + test_rng (Random.pseudo_rng_aes_ctr "abcdefghijklmnopqrstuvwxyz"); + printf " 3. /dev/urandom: "; begin try test_rng (Random.device_rng "/dev/urandom") with Unix.Unix_error _ -> printf "not available\n" end; - printf " 3. Hardware RNG: "; + printf " 4. Hardware RNG: "; begin try test_rng (Random.hardware_rng ()) with Error No_entropy_source -> printf "not available\n" end; - printf " 4. System RNG: "; + printf " 5. System RNG: "; begin try test_rng (Random.system_rng ()) with Error No_entropy_source -> printf "not available\n" end + (* End of tests *) let _ = |