From 9ff65e266e4ee3927373e5ffe04d7403e8118183 Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 08:24:52 +0000 Subject: ocaml-fileutils-0.5.2 base --- diff --git a/.announce b/.announce new file mode 100644 index 0000000..65265fc --- /dev/null +++ b/.announce @@ -0,0 +1,26 @@ +To: caml-list@inria.fr +Bcc: hump@caml.inria.fr +Subject: [ANN] ocaml-fileutils v0.4.0 + +Ocaml fileutils is aimed to be a platform independent library to perform +operation on file like: +- mv +- cp +- rm +- mkdir +- touch +- which... + +Comes also with a module to manipulate abstract filename: +- classification +- make_relative: made a filename relative to another +- make_absolute + +This new release simplify module structure (nested modules are not required +anymore) and comes with a more clear documentation. It also removes +parser/lexer for path which was little bit overkilling. Some operations have +been optimized for speed (like find) -- coming close in term of performance to +standard POSIX commands. + +Link: +http://le-gall.net/sylvain+violaine/ocaml-fileutils.html diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..fb78ae7 --- /dev/null +++ b/.gitignore @@ -0,0 +1,10 @@ +/_build/ +/setup.data +/setup.log +/dist/ +/test.byte +/test/oUnit.log +/website/website-tools/ +/website/dist/ +/BenchFind.native +/api-fileutils.docdir diff --git a/.merlin b/.merlin new file mode 100644 index 0000000..c6876c1 --- /dev/null +++ b/.merlin @@ -0,0 +1,7 @@ +S src/** +S test/** +B _build/src/** +B _build/test/** +PKG unix +PKG oUnit +FLG -w +a-4-44 diff --git a/AUTHORS.txt b/AUTHORS.txt new file mode 100644 index 0000000..4aff188 --- /dev/null +++ b/AUTHORS.txt @@ -0,0 +1,8 @@ +(* OASIS_START *) +(* DO NOT EDIT (digest: d2992b786e4b2ed3e6406c326eb201cf) *) + +Authors of ocaml-fileutils: + +* Sylvain Le Gall + +(* OASIS_STOP *) diff --git a/CHANGELOG.txt b/CHANGELOG.txt new file mode 100644 index 0000000..44dee63 --- /dev/null +++ b/CHANGELOG.txt @@ -0,0 +1,193 @@ +v0.5.2: + * Minor release: + - Test file existence with Unix.LargeFile.lstat in FileUtilRM. + (Closes: #1749) + + -- Sylvain Le Gall Tue, 23 May 2017 22:09:38 +0200 + +v0.5.1: + * Minor release: + - Fix non POSIX behavior of cp with links when "recurse:false". + (Closes: #1649) + + -- Sylvain Le Gall Wed, 02 Nov 2016 00:19:58 +0100 + +v0.5.0: + * Major release to account all the API changes: + * Rebuild the exception/reporting framework: + - Remove exceptions in favor of a single exception per command and a + polymorphic variant tag. + - Use a reporting function that can be passed as a parameter + [?error:'a error_handler] to most of the functions. + * Reimplement functions to be more POSIX compliant implementation (Closes: #761): + (functions: cp, umask, chmod, mkdir, rm, mv, touch) + * Make sure dead symlinks are handled properly (Closes: #712, #711): + - derefenced when needed (functions: test) + - offer the choice when possible (function: stat) + * Implement symbolic mode that may have contextual meaning. + * Improve documentation (add links to POSIX doc, reorganize content in section). + * Split FileUtil.ml into multiple files. + * Implement chmod (Closes: #416). + * [cp] now propagate timestamp when invoked with [~preserve] (Closes: #709). + * Upgrade OUnit to OUnit2. + * Fix typo in cp (Closes: #816, #1317). + + -- Sylvain Le Gall Fri, 10 Jul 2015 01:44:54 +0200 + +v0.4.5: + * Fix fd leaking cmp (Closes: #1012). + * Fix test suite for BSD system. + + -- Sylvain Le Gall Mon, 03 Jun 2013 01:00:26 +0200 + +v0.4.4: + * Regenerate with oasis 0.3.0~rc6 + + -- Sylvain Le Gall Tue, 12 Jun 2012 22:11:00 +0000 + +v0.4.3: + * OASIS enabled + + -- Sylvain Le Gall Thu, 26 May 2011 09:47:22 +0000 + +v0.4.2: + * Apply patch from Rüdiger Schmitt, fix handling for '.' in find and ls + (Close: #418, #736) + + -- Sylvain Le Gall Mon, 06 Sep 2010 09:34:17 +0000 + +v0.4.1: + * Apply patch from S. Glondu to use the right find function in FileUtilStr + (Closes: #731) + * Fix some typo in documentation + * Apply patch from Debian to use a byte plugin for ocamlbuild + + -- Sylvain Le Gall Wed, 01 Sep 2010 15:09:17 +0200 + +v0.4.0: + * Simplify interface, avoid nested module when possible: + * Add filename information to all exception + * FileUtil: + * size is now a 64bits integer, functions are restricted to 4 most useful + operations + * Str match is now separated into another module (FileUtilStr, package + fileutils-str) + * All operations are now directly in FileUtil and not in FileUtil.StrUtil + * FilePath: + * Remove is_implicit, use is_relative as replacement + * All functions of FilePath.DefaultPath are now directly accessible in + FilePath + * Default operation on string, use sub-module Abstract for abstract + operations + * FilePath.reduce don't reduce ".." except if asked to (i.e. no symlink) + * CygwinPath related function use directly UnixPath + * Make documentation more clear + * Introduce fast operation for string filename: when possible to operate + directly on string use it + * Drop parser/lexer for path: this is complicated and not efficient. Prefer + simple string manipulation which is more efficient + * Replace build system by ocamlbuild, ocamlfind, a simple Makefile, + ocaml-autoconf macros and configure + * Adapt compilation and test to Windows + * Simplify rm and avoid asking question twice (Closes: #FS79) + * Use Unix.LargeFile to handle huge file (Closes: FS#77) + * Simplify size operation. Now all operation is done on Int64 (Closes: FS#76) + * Implement FileUtilStr that allow Str.regexp match outside the core + FileUtil module (Closes: FS#13) + * Add a wildcard on .a and .lib to allow installation on Windows + (Closes: FS#84) + * Update license header (Closes: FS#8, FS#55) + * Accept "/" as separator for Win32 (Closes: FS#78, FS#83, FS#68) + * For win32, use PATHEXT to locate executable with "which" (Closes: FS#73) + * Don't suppose ".." can be reduced and test it (Closes: FS#10) + * Fix "mv" and allow to copy data between filesystem (Closes: FS#6, FS#7) + * Optimize FileUtil.find speed, now only 2x slower than UNIX find (was 40x slower before) + (Closes: FS#65) + + -- Sylvain Le Gall Wed, 09 Sep 2009 15:29:38 +0200 + +v0.3.0: + * Change the version to 0.3 (lot of changes for a minor version) + * Update webpages + * Correct a bug that prevent sr\@Ltn to be parsed (which comes from the + lexer of UnixPath, there is [^'.''/''\\']* which can produce empty token) + * Correct a bug that prevent to parse the initial current dir (ie produce nothing + when use find "." or find "/a/") + +v0.2.2: + * Changes the version to 0.2.2 in TopMakefile.in (closes: #33) + * Stop removing Makefile in distclean target (closes: #31) + * Change --enable-docdir --enable-builddir to --withXX (closes: #32) + * Configure now test that ocamlfind is not detected and that we want to + use ocamlfind (closes: #34) + * Correct error concerning parsing of "" as a current dir (closes: #40) + * Correct error concerning the test Has_extension (closes: #41) + * Use a new CurrenDir of (Long|Short) to denote the difference between "" and "." + * Implement readlink + * Implement pwd (closes: #39) + * Implement cmp (closes: #37, #38) + * Implement new test: Has_no_extension | Basename_is | Dirname_is + * Implement an anti recursion system (experimental, need to be tested) : + * Use a type action_link: Follow, Skip, SkipInform, AskFollow + * Maitain a set of visited directories + * Implement new test: Is_older_than_date, Is_newer_than_date, Size_bigger_than, + Size_smaller_than, Size_equal_to, Size_fuzzy_equal_to, Custom + * Rewrite the test: Is_older_than, Is_newer_than, now takes only one args + * Implement type size and operation coming along (add, sub, convert, compare, + string_of_size). + * Implement type permission / base_permission and operation coming along ( + permission_of_int, int_of_permission). + * Implement type kind (Dir, File...). + * Implement function stat + * Rewrite find, in order to be able to execute codes foreach filename. Very useful + for rewriting other functions (rm, cp, mv) + * Use list argument in place of single filename for rm, cp + * Fix a bug that prevent ls to be able to list "" + * Reworked unitary tests: include test for symlink and anti recursion + * Unitary tests change from Fort to OUnit test suite + +v0.2.1: + * Minor bug fixes to correct website aspect + +v0.2: + * Use module/functor to abstract a lot of operation. + * Generate a decent ocamldoc documentation + * Abstract regexp matching using functor + * Separate the sysPath modules in two: Abstract and not. Abstract + permits to parse once and for all the filename, and then operate + on it. It allows to handle fast all operation. Concrete module + are only proxy that do the conversion to/from the Abstract + implementation. + * Introduce relation (updir, subdir, compare) to allow manipulating + filename in classical structure (Set, Map...) + * Rename sysPath, sysUtil to filePath, fileUtil since it appears that it is + more consistent regarding the name of the library (i was not convinced, that + sysPath represents anything). + +v0.1.1 (devel): + + * Fix some weird comportement with reduce (especially + when trying to reduce filename which try to .. a root) + and add the possibility to reduce relative filename + * Rework on the way everything is made : + * Support 4 different scheme of filename (Unix (the + native way), MacOS, Win32, Cygwin) + * Each scheme use a parser/lexer to decompose his + filename and a .ml to handle the whole discriminant + element of a specific scheme (ie the way filename are + decomposed and the way path like variable are decomposed) + * All the operation are defined relatively to the + discriminant operation in a functorized module + * Each scheme produces a module from his discriminant element + and from the generic operation. These modules are defined in + SysPath.{UnixPath|Win32Path|CygwinPath|MacOSPath}. + * Depending on the current environement one of the module above + is the default binding for all the operation. + * Add SysUtil which try to create some portable file operation : + mv, cp, touch, mkdir, test, find. This module abandon any non + cross platform operation and will never support it (ie links for + example, won't be supported). + * This release is an alpha release. 0.2 will be the stable one. + + -- Sylvain LE GALL Thu, 30 Jan 2004 00:29:00 +0200 + diff --git a/COPYING.txt b/COPYING.txt new file mode 100644 index 0000000..037ace8 --- /dev/null +++ b/COPYING.txt @@ -0,0 +1,524 @@ +As a special exception to the GNU Lesser 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 LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations +below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it +becomes a de-facto standard. To achieve this, non-free programs must +be allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control +compilation and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 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 combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at least + three years, to give the same user the materials specified in + Subsection 6a, above, for a charge no more than the cost of + performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply, and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License +may add an explicit geographical distribution limitation excluding those +countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 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 + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms +of the ordinary General Public License). + + To apply these terms, attach the following notices to the library. +It is safest to attach them to the start of each source file to most +effectively convey the exclusion of warranty; and each file should +have at least the "copyright" line and a pointer to where the full +notice is found. + + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or +your school, if any, to sign a "copyright disclaimer" for the library, +if necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James + Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/INSTALL.txt b/INSTALL.txt new file mode 100644 index 0000000..5e9e43a --- /dev/null +++ b/INSTALL.txt @@ -0,0 +1,39 @@ +(* OASIS_START *) +(* DO NOT EDIT (digest: 1c7c220953a82c8dee6d9f2e084b9e25) *) + +This is the INSTALL file for the ocaml-fileutils distribution. + +This package uses OASIS to generate its build system. See section OASIS for +full information. + +Dependencies +============ + +In order to compile this package, you will need: + +* ocaml for all, test bench-find, test main, doc api-fileutils +* findlib +* oUnit (>= 2.0.0) for executable test + +Installing +========== + +1. Uncompress the source archive and go to the root of the package +2. Run 'ocaml setup.ml -configure' +3. Run 'ocaml setup.ml -build' +4. Run 'ocaml setup.ml -install' + +Uninstalling +============ + +1. Go to the root of the package +2. Run 'ocaml setup.ml -uninstall' + +OASIS +===== + +OASIS is a program that generates a setup.ml file using a simple '_oasis' +configuration file. The generated setup only depends on the standard OCaml +installation: no additional library is required. + +(* OASIS_STOP *) diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..4f70058 --- /dev/null +++ b/Makefile @@ -0,0 +1,138 @@ +############################################################################## +# ocaml-fileutils: files and filenames common operations # +# # +# Copyright (C) 2003-2014, Sylvain Le Gall # +# # +# This library is free software; you can redistribute it and/or modify it # +# under the terms of the GNU Lesser General Public License as published by # +# the Free Software Foundation; either version 2.1 of the License, or (at # +# your option) any later version, with the OCaml static compilation # +# exception. # +# # +# This library is distributed in the hope that it will be useful, but # +# WITHOUT ANY WARRANTY; without even the implied warranty of # +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file # +# COPYING for more details. # +# # +# You should have received a copy of the GNU Lesser General Public License # +# along with this library; if not, write to the Free Software Foundation, # +# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA # +############################################################################## + +defaultl: test + +# OASIS_START +# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) + +SETUP = ocaml setup.ml + +build: setup.data + $(SETUP) -build $(BUILDFLAGS) + +doc: setup.data build + $(SETUP) -doc $(DOCFLAGS) + +test: setup.data build + $(SETUP) -test $(TESTFLAGS) + +all: + $(SETUP) -all $(ALLFLAGS) + +install: setup.data + $(SETUP) -install $(INSTALLFLAGS) + +uninstall: setup.data + $(SETUP) -uninstall $(UNINSTALLFLAGS) + +reinstall: setup.data + $(SETUP) -reinstall $(REINSTALLFLAGS) + +clean: + $(SETUP) -clean $(CLEANFLAGS) + +distclean: + $(SETUP) -distclean $(DISTCLEANFLAGS) + +setup.data: + $(SETUP) -configure $(CONFIGUREFLAGS) + +configure: + $(SETUP) -configure $(CONFIGUREFLAGS) + +.PHONY: build doc test all install uninstall reinstall clean distclean configure + +# OASIS_STOP + +# Precommit target +# Check style of code. +PRECOMMIT_ARGS= \ + --exclude myocamlbuild.ml \ + --exclude setup.ml \ + --exclude README.txt \ + --exclude INSTALL.txt \ + --exclude Makefile \ + --exclude configure \ + --exclude _tags + +precommit: + -@if command -v OCamlPrecommit > /dev/null; then \ + OCamlPrecommit $(PRECOMMIT_ARGS); \ + else \ + echo "Skipping precommit checks.";\ + fi + +precommit-full: + OCamlPrecommit --full $(PRECOMMIT_ARGS) + +test: precommit + +.PHONY: precommit + +# Headache target +# Fix license header of file. + +headache: + find ./ \ + -name _darcs -prune -false -o \ + -name .git -prune -false -o \ + -name _build -prune -false -o \ + -type f \ + | xargs headache -h _header -c _headache.config + +.PHONY: headache + +doc-dev-dist: doc fix-perms + ./doc-dist.sh --version dev + +.PHONY: doc-dev-dist + +# Deploy target +# Deploy/release the software. + +deploy: doc + mkdir dist || true + ./doc-dist.sh --version $(shell oasis query version) + admin-gallu-deploy --verbose \ + --forge_upload --forge_group ocaml-fileutils --forge_user gildor-admin \ + --forge_extra_file "dist/ocaml-fileutils-doc-$(shell oasis query version).tar.gz" + admin-gallu-oasis-increment \ + --setup_run --setup_args "-setup-update dynamic" --use_vcs + +.PHONY: deploy + +fix-perms: + chmod +x doc-dist.sh + +.PHONY: fix-perms + +website-clean: + cd website && $(MAKE) clean + +clean: website-clean + +website-distclean: + cd website && $(MAKE) distclean + +distclean: website-distclean + +.PHONY: website-distclean website-clean diff --git a/README.txt b/README.txt new file mode 100644 index 0000000..c9ca1dc --- /dev/null +++ b/README.txt @@ -0,0 +1,41 @@ +******************************************************************************** +* ocaml-fileutils: files and filenames common operations * +* * +* Copyright (C) 2003-2011, Sylvain Le Gall * +* * +* This library is free software; you can redistribute it and/or modify it * +* under the terms of the GNU Lesser General Public License as published by * +* the Free Software Foundation; either version 2.1 of the License, or (at * +* your option) any later version, with the OCaml static compilation * +* exception. * +* * +* This library is distributed in the hope that it will be useful, but * +* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * +* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more * +* details. * +* * +* You should have received a copy of the GNU Lesser General Public License * +* along with this library; if not, write to the Free Software Foundation, * +* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA * +******************************************************************************** + +(* OASIS_START *) +(* DO NOT EDIT (digest: 4d1985d5a27aa85287d958ea0815611e) *) + +ocaml-fileutils - Functions to manipulate real file (POSIX like) and filename. +============================================================================== + +See the file [INSTALL.txt](INSTALL.txt) for building and installation +instructions. + +Copyright and license +--------------------- + +(C) 2003-2014 Sylvain Le Gall + +ocaml-fileutils is distributed under the terms of the GNU Lesser General +Public License version 2.1 with OCaml linking exception. + +See [LICENSE](LICENSE) for more information. + +(* OASIS_STOP *) diff --git a/TODO.txt b/TODO.txt new file mode 100644 index 0000000..a9a6b38 --- /dev/null +++ b/TODO.txt @@ -0,0 +1,19 @@ + +Must: +- implement a basic glob function to replace the Str implementation (*, ?). +- add more test to the test.ml file ( should have at least 200 test - only 133 + at the time I am writing this line ) +- create a URI parser, in order to be able to adress different filesystem using + the same string (example file:/coucou/ to indicate the subdir coucou of the + current dir) +- install +- pathchk + + +Wishlist: +- Create a libtar-ocaml, to handle the tar format +- Investigate on the different UNIX command that should be great to have... + Maybe go and see if some interesting command exist on other OS... + +Bugs: +- should not take into account files that are links diff --git a/_headache.config b/_headache.config new file mode 100644 index 0000000..d1d7389 --- /dev/null +++ b/_headache.config @@ -0,0 +1,73 @@ +############################################################################## +# ocaml-fileutils: files and filenames common operations # +# # +# Copyright (C) 2003-2014, Sylvain Le Gall # +# # +# This library is free software; you can redistribute it and/or modify it # +# under the terms of the GNU Lesser General Public License as published by # +# the Free Software Foundation; either version 2.1 of the License, or (at # +# your option) any later version, with the OCaml static compilation # +# exception. # +# # +# This library is distributed in the hope that it will be useful, but # +# WITHOUT ANY WARRANTY; without even the implied warranty of # +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file # +# COPYING for more details. # +# # +# You should have received a copy of the GNU Lesser General Public License # +# along with this library; if not, write to the Free Software Foundation, # +# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA # +############################################################################## + +| "aclocal\\.m4" -> no +| ".*\\.patch" -> no +| "install-sh" -> no +| "missing" -> no +| "config\\.log" -> no +| "config\\.status" -> no +| "configure" -> no +| ".*\\.sh" -> skip match:"#!.*" +| ".*\\.sh" -> frame open:"#" line:"#" close:"#" +| "autogen\\.sh" -> frame open:"#" line:"#" close:"#" +| "configure\\.in" -> frame open:"dnl *" line:"*" close:"*" +| "configure\\.ac" -> frame open:"dnl *" line:"*" close:"*" +| ".*\\.xml" -> skip match:"<\?xml.*>" +| ".*\\.xml" -> lines open:"" +| ".*\\.ml\\.in" -> frame open:"(*" line:"*" close:"*)" +| ".*\\.ml" -> skip match:"(\\*pp .* \\*)" +| "_headache\\.config" -> frame open:"#" line:"#" close:"#" +| ".*\\.swp" -> no +| ".*\\.po" -> no +| ".*\\.mo" -> no +| "META" -> frame open:"#" line:"#" close:"#" +| "META\\.in" -> frame open:"#" line:"#" close:"#" +| "POTFILES" -> no +| "LINGUAS" -> no +| ".*\\.pot" -> no +| ".*\\.png" -> no +| "\\.announce" -> no +| ".*\\.mllib" -> frame open:"#" line:"#" close:"#" +| ".*\\.itarget" -> frame open:"#" line:"#" close:"#" +| ".*\\.itarget.in" -> frame open:"#" line:"#" close:"#" +| ".*\\.odocl" -> frame open:"#" line:"#" close:"#" +| "_tags" -> frame open:"#" line:"#" close:"#" +| "\\.boring" -> no +| "\\.gitignore" -> no +| ".*\\.txt" -> no +| ".*\.tar\\.gz" -> no +| ".*\.tar\\.gz\\.asc" -> no +| "setup\\.log" -> no +| "setup\\.data" -> no +| ".*\\.bak" -> no +| "_oasis" -> no +| "_header" -> no +| ".*\\.lua" -> no +| ".*\\.py" -> no +| ".*\\.pyc" -> no +| ".*\\.ico" -> no +| ".*\\.mkd\\.tmpl" -> no +| ".*\\.mkd" -> no +| ".*\\.html" -> no +| ".*\\.css" -> frame open:"/*" line:"*" close:"*/" +| ".*\\.svg" -> skip match:"<\?xml.*>" +| ".*\\.svg" -> lines open:"" diff --git a/_header b/_header new file mode 100644 index 0000000..179c7b7 --- /dev/null +++ b/_header @@ -0,0 +1,18 @@ +ocaml-fileutils: files and filenames common operations + +Copyright (C) 2003-2014, Sylvain Le Gall + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Lesser General Public License as published by +the Free Software Foundation; either version 2.1 of the License, or (at +your option) any later version, with the OCaml static compilation +exception. + +This library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file +COPYING for more details. + +You should have received a copy of the GNU Lesser General Public License +along with this library; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA diff --git a/_oasis b/_oasis new file mode 100644 index 0000000..1976c47 --- /dev/null +++ b/_oasis @@ -0,0 +1,89 @@ +OASISFormat: 0.4 +Name: ocaml-fileutils +Version: 0.5.2 +Authors: Sylvain Le Gall +Copyrights: (C) 2003-2014 Sylvain Le Gall +License: LGPL-2.1 with OCaml linking exception +LicenseFile: LICENSE +BuildTools: ocamlbuild +Plugins: DevFiles (0.4), StdFiles (0.4), META (0.4) +Synopsis: Functions to manipulate real file (POSIX like) and filename. + +Library "fileutils" + Path: src/ + Modules: FileUtil, + FilePath + InternalModules: CommonPath, + ExtensionPath, + FilePath_type, + FileStringExt, + MacOSPath, + UnixPath, + Win32Path, + FileUtilMode, + FileUtilTypes, + FileUtilPermission, + FileUtilSize, + FileUtilMisc, + FileUtilSTAT, + FileUtilUMASK, + FileUtilLS, + FileUtilCHMOD, + FileUtilTEST, + FileUtilPWD, + FileUtilREADLINK, + FileUtilWHICH, + FileUtilMKDIR, + FileUtilTOUCH, + FileUtilFIND, + FileUtilRM, + FileUtilCP, + FileUtilMV, + FileUtilCMP, + FileUtilDU + BuildDepends: unix + +Library "fileutils-str" + FindlibParent: fileutils + FindlibName: str + Path: src/ + Modules: FileUtilStr + BuildDepends: fileutils, str + +Document "api-fileutils" + Title: API reference for fileutils + Type: ocamlbuild (0.4) + InstallDir: $htmldir/api + BuildTools+: ocamldoc + XOCamlbuildPath: src/ + XOCamlbuildLibraries: fileutils, fileutils.str + +SourceRepository head + Type: darcs + Location: http://forge.ocamlcore.org/anonscm/darcs/ocaml-fileutils/ocaml-fileutils + Browser: http://darcs.ocamlcore.org/cgi-bin/darcsweb.cgi?r=ocaml-fileutils/ocaml-fileutils;a=summary + +Executable BenchFind + Path: test + MainIs: BenchFind.ml + BuildDepends: fileutils + Build$: flag(tests) + Install: false + CompiledObject: best + +Executable test + Path: test + MainIs: test.ml + BuildDepends: fileutils, fileutils.str, oUnit (>= 2.0.0) + Build$: flag(tests) + Install: false + +Test "bench-find" + Type: custom (0.4) + Command: $BenchFind + Run: false + +Test main + Type: custom (0.4) + Command: $test + WorkingDirectory: test diff --git a/_tags b/_tags new file mode 100644 index 0000000..1a522fb --- /dev/null +++ b/_tags @@ -0,0 +1,38 @@ +# OASIS_START +# DO NOT EDIT (digest: 4b34a4a853e31c298670a5e399c22371) +# Ignore VCS directories, you can use the same kind of rule outside +# OASIS_START/STOP if you want to exclude directories that contains +# useless stuff for the build process +true: annot, bin_annot +<**/.svn>: -traverse +<**/.svn>: not_hygienic +".bzr": -traverse +".bzr": not_hygienic +".hg": -traverse +".hg": not_hygienic +".git": -traverse +".git": not_hygienic +"_darcs": -traverse +"_darcs": not_hygienic +# Library fileutils +"src/fileutils.cmxs": use_fileutils +# Library fileutils-str +"src/fileutils-str.cmxs": use_fileutils-str +: pkg_str +: pkg_unix +: use_fileutils +# Executable BenchFind +: pkg_unix +: use_fileutils +# Executable test +"test/test.byte": pkg_oUnit +"test/test.byte": pkg_str +"test/test.byte": pkg_unix +"test/test.byte": use_fileutils +"test/test.byte": use_fileutils-str +: pkg_oUnit +: pkg_str +: pkg_unix +: use_fileutils +: use_fileutils-str +# OASIS_STOP diff --git a/ardivink.lua b/ardivink.lua new file mode 100644 index 0000000..3dbd781 --- /dev/null +++ b/ardivink.lua @@ -0,0 +1,18 @@ +oasis = require("oasis") +ci = require("ci") +dist = require("dist") + +ci.init() +dist.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") + +-- Create documentation package. +ci.exec("make", "doc-dev-dist") diff --git a/configure b/configure new file mode 100755 index 0000000..6acfaeb --- /dev/null +++ b/configure @@ -0,0 +1,27 @@ +#!/bin/sh + +# OASIS_START +# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) +set -e + +FST=true +for i in "$@"; do + if $FST; then + set -- + FST=false + fi + + case $i in + --*=*) + ARG=${i%%=*} + VAL=${i##*=} + set -- "$@" "$ARG" "$VAL" + ;; + *) + set -- "$@" "$i" + ;; + esac +done + +ocaml setup.ml -configure "$@" +# OASIS_STOP diff --git a/doc-dist.sh b/doc-dist.sh new file mode 100755 index 0000000..f37d520 --- /dev/null +++ b/doc-dist.sh @@ -0,0 +1,39 @@ +#!/bin/bash +############################################################################## +# ocaml-fileutils: files and filenames common operations # +# # +# Copyright (C) 2003-2014, Sylvain Le Gall # +# # +# This library is free software; you can redistribute it and/or modify it # +# under the terms of the GNU Lesser General Public License as published by # +# the Free Software Foundation; either version 2.1 of the License, or (at # +# your option) any later version, with the OCaml static compilation # +# exception. # +# # +# This library is distributed in the hope that it will be useful, but # +# WITHOUT ANY WARRANTY; without even the implied warranty of # +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file # +# COPYING for more details. # +# # +# You should have received a copy of the GNU Lesser General Public License # +# along with this library; if not, write to the Free Software Foundation, # +# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA # +############################################################################## + +. admin-gallu-common || exit 1 + +set -e + +arg_string_set version --default "dev" \ + "Version of OUnit." + +arg_parse arg_anon_fail "$@" + +CURDIR=$(pwd) + +TOPDIR="ocaml-fileutils-doc-$version" +get_tmpdir TEMPDIR +mkdir -p "$TEMPDIR/$TOPDIR/api-fileutils" +cp -R _build/src/api-fileutils.docdir/* "$TEMPDIR/$TOPDIR/api-fileutils" + +tar czf "$CURDIR/dist/$TOPDIR.tar.gz" -C $TEMPDIR $TOPDIR diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 0000000..0285223 --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,896 @@ +(* OASIS_START *) +(* DO NOT EDIT (digest: 2ff2fa208b8292955ad39dda4ee05185) *) +module OASISGettext = struct +(* # 22 "src/oasis/OASISGettext.ml" *) + + + let ns_ str = str + let s_ str = str + let f_ (str: ('a, 'b, 'c, 'd) format4) = str + + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + + let init = [] +end + +module OASISString = struct +(* # 22 "src/oasis/OASISString.ml" *) + + + (** Various string utilities. + + Mostly inspired by extlib and batteries ExtString and BatString libraries. + + @author Sylvain Le Gall + *) + + + let nsplitf str f = + if str = "" then + [] + else + let buf = Buffer.create 13 in + let lst = ref [] in + let push () = + lst := Buffer.contents buf :: !lst; + Buffer.clear buf + in + let str_len = String.length str in + for i = 0 to str_len - 1 do + if f str.[i] then + push () + else + Buffer.add_char buf str.[i] + done; + push (); + List.rev !lst + + + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the + separator. + *) + let nsplit str c = + nsplitf str ((=) c) + + + let find ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + what_idx := 0; + incr str_idx + done; + if !what_idx <> String.length what then + raise Not_found + else + !str_idx - !what_idx + + + let sub_start str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str len (str_len - len) + + + let sub_end ?(offset=0) str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str 0 (str_len - len) + + + let starts_with ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + let ok = ref true in + while !ok && + !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + ok := false; + incr str_idx + done; + !what_idx = String.length what + + + let strip_starts_with ~what str = + if starts_with ~what str then + sub_start str (String.length what) + else + raise Not_found + + + let ends_with ~what ?(offset=0) str = + let what_idx = ref ((String.length what) - 1) in + let str_idx = ref ((String.length str) - 1) in + let ok = ref true in + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx + else + ok := false; + decr str_idx + done; + !what_idx = -1 + + + let strip_ends_with ~what str = + if ends_with ~what str then + sub_end str (String.length what) + else + raise Not_found + + + let replace_chars f s = + let buf = Buffer.create (String.length s) in + String.iter (fun c -> Buffer.add_char buf (f c)) s; + Buffer.contents buf + + let lowercase_ascii = + replace_chars + (fun c -> + if (c >= 'A' && c <= 'Z') then + Char.chr (Char.code c + 32) + else + c) + + let uncapitalize_ascii s = + if s <> "" then + (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s + + let uppercase_ascii = + replace_chars + (fun c -> + if (c >= 'a' && c <= 'z') then + Char.chr (Char.code c - 32) + else + c) + + let capitalize_ascii s = + if s <> "" then + (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s + +end + +module OASISUtils = struct +(* # 22 "src/oasis/OASISUtils.ml" *) + + + open OASISGettext + + + module MapExt = + struct + module type S = + sig + include Map.S + val add_list: 'a t -> (key * 'a) list -> 'a t + val of_list: (key * 'a) list -> 'a t + val to_list: 'a t -> (key * 'a) list + end + + module Make (Ord: Map.OrderedType) = + struct + include Map.Make(Ord) + + let rec add_list t = + function + | (k, v) :: tl -> add_list (add k v t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] + end + end + + + module MapString = MapExt.Make(String) + + + module SetExt = + struct + module type S = + sig + include Set.S + val add_list: t -> elt list -> t + val of_list: elt list -> t + val to_list: t -> elt list + end + + module Make (Ord: Set.OrderedType) = + struct + include Set.Make(Ord) + + let rec add_list t = + function + | e :: tl -> add_list (add e t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list = elements + end + end + + + module SetString = SetExt.Make(String) + + + let compare_csl s1 s2 = + String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) + + + module HashStringCsl = + Hashtbl.Make + (struct + type t = string + let equal s1 s2 = (compare_csl s1 s2) = 0 + let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) + end) + + module SetStringCsl = + SetExt.Make + (struct + type t = string + let compare = compare_csl + end) + + + let varname_of_string ?(hyphen='_') s = + if String.length s = 0 then + begin + invalid_arg "varname_of_string" + end + else + begin + let buf = + OASISString.replace_chars + (fun c -> + if ('a' <= c && c <= 'z') + || + ('A' <= c && c <= 'Z') + || + ('0' <= c && c <= '9') then + c + else + hyphen) + s; + in + let buf = + (* Start with a _ if digit *) + if '0' <= s.[0] && s.[0] <= '9' then + "_"^buf + else + buf + in + OASISString.lowercase_ascii buf + end + + + let varname_concat ?(hyphen='_') p s = + let what = String.make 1 hyphen in + let p = + try + OASISString.strip_ends_with ~what p + with Not_found -> + p + in + let s = + try + OASISString.strip_starts_with ~what s + with Not_found -> + s + in + p^what^s + + + let is_varname str = + str = varname_of_string str + + + let failwithf fmt = Printf.ksprintf failwith fmt + + + let rec file_location ?pos1 ?pos2 ?lexbuf () = + match pos1, pos2, lexbuf with + | Some p, None, _ | None, Some p, _ -> + file_location ~pos1:p ~pos2:p ?lexbuf () + | Some p1, Some p2, _ -> + let open Lexing in + let fn, lineno = p1.pos_fname, p1.pos_lnum in + let c1 = p1.pos_cnum - p1.pos_bol in + let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in + Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 + | _, _, Some lexbuf -> + file_location + ~pos1:(Lexing.lexeme_start_p lexbuf) + ~pos2:(Lexing.lexeme_end_p lexbuf) + () + | None, None, None -> + s_ "" + + + let failwithpf ?pos1 ?pos2 ?lexbuf fmt = + let loc = file_location ?pos1 ?pos2 ?lexbuf () in + Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt + + +end + +module OASISExpr = struct +(* # 22 "src/oasis/OASISExpr.ml" *) + + + open OASISGettext + open OASISUtils + + + type test = string + type flag = string + + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + type 'a choices = (t * 'a) list + + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + + +end + + +# 437 "myocamlbuild.ml" +module BaseEnvLight = struct +(* # 22 "src/base/BaseEnvLight.ml" *) + + + module MapString = Map.Make(String) + + + type t = string MapString.t + + + let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" + + + let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = + let line = ref 1 in + let lexer st = + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + Genlex.make_lexer ["="] st_line + in + let rec read_file lxr mp = + match Stream.npeek 3 lxr with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; + read_file lxr (MapString.add nm value mp) + | [] -> mp + | _ -> + failwith + (Printf.sprintf "Malformed data file '%s' line %d" filename !line) + in + match stream with + | Some st -> read_file (lexer st) MapString.empty + | None -> + if Sys.file_exists filename then begin + let chn = open_in_bin filename in + let st = Stream.of_channel chn in + try + let mp = read_file (lexer st) MapString.empty in + close_in chn; mp + with e -> + close_in chn; raise e + end else if allow_empty then begin + MapString.empty + end else begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + let rec var_expand str env = + let buff = Buffer.create ((String.length str) * 2) in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = var_expand (MapString.find name env) env + let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst +end + + +# 517 "myocamlbuild.ml" +module MyOCamlbuildFindlib = struct +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) + + + (** OCamlbuild extension, copied from + * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html + * by N. Pouillard and others + * + * Updated on 2016-06-02 + * + * Modified by Sylvain Le Gall + *) + open Ocamlbuild_plugin + + + type conf = {no_automatic_syntax: bool} + + + let run_and_read = Ocamlbuild_pack.My_unix.run_and_read + + + let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings + + + let exec_from_conf exec = + let exec = + let env = BaseEnvLight.load ~allow_empty:true () in + try + BaseEnvLight.var_get exec env + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" exec; + exec + in + let fix_win32 str = + if Sys.os_type = "Win32" then begin + let buff = Buffer.create (String.length str) in + (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. + *) + String.iter + (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) + str; + Buffer.contents buff + end else begin + str + end + in + fix_win32 exec + + + let split s ch = + let buf = Buffer.create 13 in + let x = ref [] in + let flush () = + x := (Buffer.contents buf) :: !x; + Buffer.clear buf + in + String.iter + (fun c -> + if c = ch then + flush () + else + Buffer.add_char buf c) + s; + flush (); + List.rev !x + + + let split_nl s = split s '\n' + + + let before_space s = + try + String.before s (String.index s ' ') + with Not_found -> s + + (* ocamlfind command *) + let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] + + (* This lists all supported packages. *) + let find_packages () = + List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) + + + (* Mock to list available syntaxes. *) + let find_syntaxes () = ["camlp4o"; "camlp4r"] + + + let well_known_syntax = [ + "camlp4.quotations.o"; + "camlp4.quotations.r"; + "camlp4.exceptiontracer"; + "camlp4.extend"; + "camlp4.foldgenerator"; + "camlp4.listcomprehension"; + "camlp4.locationstripper"; + "camlp4.macro"; + "camlp4.mapgenerator"; + "camlp4.metagenerator"; + "camlp4.profiler"; + "camlp4.tracer" + ] + + + let dispatch conf = + function + | After_options -> + (* By using Before_options one let command line options have an higher + * priority on the contrary using After_options will guarantee to have + * the higher priority override default commands by ocamlfind ones *) + Options.ocamlc := ocamlfind & A"ocamlc"; + Options.ocamlopt := ocamlfind & A"ocamlopt"; + Options.ocamldep := ocamlfind & A"ocamldep"; + Options.ocamldoc := ocamlfind & A"ocamldoc"; + Options.ocamlmktop := ocamlfind & A"ocamlmktop"; + Options.ocamlmklib := ocamlfind & A"ocamlmklib" + + | After_rules -> + + (* Avoid warnings for unused tag *) + flag ["tests"] N; + + (* When one link an OCaml library/binary/package, one should use + * -linkpkg *) + flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + let base_args = [A"-package"; A pkg] in + (* TODO: consider how to really choose camlp4o or camlp4r. *) + let syn_args = [A"-syntax"; A "camlp4o"] in + let (args, pargs) = + (* Heuristic to identify syntax extensions: whether they end in + ".syntax"; some might not. + *) + if not (conf.no_automatic_syntax) && + (Filename.check_suffix pkg "syntax" || + List.mem pkg well_known_syntax) then + (syn_args @ base_args, syn_args) + else + (base_args, []) + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + + (* TODO: Check if this is allowed for OCaml < 3.12.1 *) + flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; + end + (find_packages ()); + + (* Like -package but for extensions syntax. Morover -syntax is useless + * when linking. *) + List.iter begin fun syntax -> + flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & + S[A"-syntax"; A syntax]; + end (find_syntaxes ()); + + (* The default "thread" tag is not compatible with ocamlfind. + * Indeed, the default rules add the "threads.cma" or "threads.cmxa" + * options when using this tag. When using the "-linkpkg" option with + * ocamlfind, this module will then be added twice on the command line. + * + * To solve this, one approach is to add the "-thread" option when using + * the "threads" package using the previous plugin. + *) + flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); + flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); + flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]); + + | _ -> + () +end + +module MyOCamlbuildBase = struct +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + + (** Base functions for writing myocamlbuild.ml + @author Sylvain Le Gall + *) + + + open Ocamlbuild_plugin + module OC = Ocamlbuild_pack.Ocaml_compiler + + + type dir = string + type file = string + type name = string + type tag = string + + + type t = + { + lib_ocaml: (name * dir list * string list) list; + lib_c: (name * dir * file list) list; + flags: (tag list * (spec OASISExpr.choices)) list; + (* Replace the 'dir: include' from _tags by a precise interdepends in + * directory. + *) + includes: (dir * dir list) list; + } + + +(* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + + let env_filename = Pathname.basename BaseEnvLight.default_filename + + + let dispatch_combine lst = + fun e -> + List.iter + (fun dispatch -> dispatch e) + lst + + + let tag_libstubs nm = + "use_lib"^nm^"_stubs" + + + let nm_libstubs nm = + nm^"_stubs" + + + let dispatch t e = + let env = BaseEnvLight.load ~allow_empty:true () in + match e with + | Before_options -> + let no_trailing_dot s = + if String.length s >= 1 && s.[0] = '.' then + String.sub s 1 ((String.length s) - 1) + else + s + in + List.iter + (fun (opt, var) -> + try + opt := no_trailing_dot (BaseEnvLight.var_get var env) + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" var) + [ + Options.ext_obj, "ext_obj"; + Options.ext_lib, "ext_lib"; + Options.ext_dll, "ext_dll"; + ] + + | After_rules -> + (* Declare OCaml libraries *) + List.iter + (function + | nm, [], intf_modules -> + ocaml_lib nm; + let cmis = + List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis + | nm, dir :: tl, intf_modules -> + ocaml_lib ~dir:dir (dir^"/"^nm); + List.iter + (fun dir -> + List.iter + (fun str -> + flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) + ["compile"; "infer_interface"; "doc"]) + tl; + let cmis = + List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] + cmis) + t.lib_ocaml; + + (* Declare directories dependencies, replace "include" in _tags. *) + List.iter + (fun (dir, include_dirs) -> + Pathname.define_context dir include_dirs) + t.includes; + + (* Declare C libraries *) + List.iter + (fun (lib, dir, headers) -> + (* Handle C part of library *) + flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; + A("-l"^(nm_libstubs lib))]); + + flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] + (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); + + if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); + + (* When ocaml link something that use the C library, then one + need that file to be up to date. + This holds both for programs and for libraries. + *) + dep ["link"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + dep ["compile"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + (* TODO: be more specific about what depends on headers *) + (* Depends on .h files *) + dep ["compile"; "c"] + headers; + + (* Setup search path for lib *) + flag ["link"; "ocaml"; "use_"^lib] + (S[A"-I"; P(dir)]); + ) + t.lib_c; + + (* Add flags *) + List.iter + (fun (tags, cond_specs) -> + let spec = BaseEnvLight.var_choose cond_specs env in + let rec eval_specs = + function + | S lst -> S (List.map eval_specs lst) + | A str -> A (BaseEnvLight.var_expand str env) + | spec -> spec + in + flag tags & (eval_specs spec)) + t.flags + | _ -> + () + + + let dispatch_default conf t = + dispatch_combine + [ + dispatch t; + MyOCamlbuildFindlib.dispatch conf; + ] + + +end + + +# 878 "myocamlbuild.ml" +open Ocamlbuild_plugin;; +let package_default = + { + MyOCamlbuildBase.lib_ocaml = + [("fileutils", ["src"], []); ("fileutils-str", ["src"], [])]; + lib_c = []; + flags = []; + includes = [("test", ["src"])] + } + ;; + +let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} + +let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; + +# 895 "myocamlbuild.ml" +(* OASIS_STOP *) +Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml new file mode 100644 index 0000000..6ee86ef --- /dev/null +++ b/setup.ml @@ -0,0 +1,7853 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +(* setup.ml generated for the first time by OASIS v0.2.0 *) + +(* OASIS_START *) +(* DO NOT EDIT (digest: 3ebd9340cfb58b7468d8fd0f06e55bde) *) +(* + Regenerated by OASIS v0.4.11~HEAD + Visit http://oasis.forge.ocamlcore.org for more information and + documentation about functions used in this file. +*) +module OASISGettext = struct +(* # 22 "src/oasis/OASISGettext.ml" *) + + + let ns_ str = str + let s_ str = str + let f_ (str: ('a, 'b, 'c, 'd) format4) = str + + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + + let init = [] +end + +module OASISString = struct +(* # 22 "src/oasis/OASISString.ml" *) + + + (** Various string utilities. + + Mostly inspired by extlib and batteries ExtString and BatString libraries. + + @author Sylvain Le Gall + *) + + + let nsplitf str f = + if str = "" then + [] + else + let buf = Buffer.create 13 in + let lst = ref [] in + let push () = + lst := Buffer.contents buf :: !lst; + Buffer.clear buf + in + let str_len = String.length str in + for i = 0 to str_len - 1 do + if f str.[i] then + push () + else + Buffer.add_char buf str.[i] + done; + push (); + List.rev !lst + + + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the + separator. + *) + let nsplit str c = + nsplitf str ((=) c) + + + let find ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + what_idx := 0; + incr str_idx + done; + if !what_idx <> String.length what then + raise Not_found + else + !str_idx - !what_idx + + + let sub_start str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str len (str_len - len) + + + let sub_end ?(offset=0) str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str 0 (str_len - len) + + + let starts_with ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + let ok = ref true in + while !ok && + !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + ok := false; + incr str_idx + done; + !what_idx = String.length what + + + let strip_starts_with ~what str = + if starts_with ~what str then + sub_start str (String.length what) + else + raise Not_found + + + let ends_with ~what ?(offset=0) str = + let what_idx = ref ((String.length what) - 1) in + let str_idx = ref ((String.length str) - 1) in + let ok = ref true in + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx + else + ok := false; + decr str_idx + done; + !what_idx = -1 + + + let strip_ends_with ~what str = + if ends_with ~what str then + sub_end str (String.length what) + else + raise Not_found + + + let replace_chars f s = + let buf = Buffer.create (String.length s) in + String.iter (fun c -> Buffer.add_char buf (f c)) s; + Buffer.contents buf + + let lowercase_ascii = + replace_chars + (fun c -> + if (c >= 'A' && c <= 'Z') then + Char.chr (Char.code c + 32) + else + c) + + let uncapitalize_ascii s = + if s <> "" then + (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s + + let uppercase_ascii = + replace_chars + (fun c -> + if (c >= 'a' && c <= 'z') then + Char.chr (Char.code c - 32) + else + c) + + let capitalize_ascii s = + if s <> "" then + (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s + +end + +module OASISUtils = struct +(* # 22 "src/oasis/OASISUtils.ml" *) + + + open OASISGettext + + + module MapExt = + struct + module type S = + sig + include Map.S + val add_list: 'a t -> (key * 'a) list -> 'a t + val of_list: (key * 'a) list -> 'a t + val to_list: 'a t -> (key * 'a) list + end + + module Make (Ord: Map.OrderedType) = + struct + include Map.Make(Ord) + + let rec add_list t = + function + | (k, v) :: tl -> add_list (add k v t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] + end + end + + + module MapString = MapExt.Make(String) + + + module SetExt = + struct + module type S = + sig + include Set.S + val add_list: t -> elt list -> t + val of_list: elt list -> t + val to_list: t -> elt list + end + + module Make (Ord: Set.OrderedType) = + struct + include Set.Make(Ord) + + let rec add_list t = + function + | e :: tl -> add_list (add e t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list = elements + end + end + + + module SetString = SetExt.Make(String) + + + let compare_csl s1 s2 = + String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) + + + module HashStringCsl = + Hashtbl.Make + (struct + type t = string + let equal s1 s2 = (compare_csl s1 s2) = 0 + let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) + end) + + module SetStringCsl = + SetExt.Make + (struct + type t = string + let compare = compare_csl + end) + + + let varname_of_string ?(hyphen='_') s = + if String.length s = 0 then + begin + invalid_arg "varname_of_string" + end + else + begin + let buf = + OASISString.replace_chars + (fun c -> + if ('a' <= c && c <= 'z') + || + ('A' <= c && c <= 'Z') + || + ('0' <= c && c <= '9') then + c + else + hyphen) + s; + in + let buf = + (* Start with a _ if digit *) + if '0' <= s.[0] && s.[0] <= '9' then + "_"^buf + else + buf + in + OASISString.lowercase_ascii buf + end + + + let varname_concat ?(hyphen='_') p s = + let what = String.make 1 hyphen in + let p = + try + OASISString.strip_ends_with ~what p + with Not_found -> + p + in + let s = + try + OASISString.strip_starts_with ~what s + with Not_found -> + s + in + p^what^s + + + let is_varname str = + str = varname_of_string str + + + let failwithf fmt = Printf.ksprintf failwith fmt + + + let rec file_location ?pos1 ?pos2 ?lexbuf () = + match pos1, pos2, lexbuf with + | Some p, None, _ | None, Some p, _ -> + file_location ~pos1:p ~pos2:p ?lexbuf () + | Some p1, Some p2, _ -> + let open Lexing in + let fn, lineno = p1.pos_fname, p1.pos_lnum in + let c1 = p1.pos_cnum - p1.pos_bol in + let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in + Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 + | _, _, Some lexbuf -> + file_location + ~pos1:(Lexing.lexeme_start_p lexbuf) + ~pos2:(Lexing.lexeme_end_p lexbuf) + () + | None, None, None -> + s_ "" + + + let failwithpf ?pos1 ?pos2 ?lexbuf fmt = + let loc = file_location ?pos1 ?pos2 ?lexbuf () in + Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt + + +end + +module OASISUnixPath = struct +(* # 22 "src/oasis/OASISUnixPath.ml" *) + + + type unix_filename = string + type unix_dirname = string + + + type host_filename = string + type host_dirname = string + + + let current_dir_name = "." + + + let parent_dir_name = ".." + + + let is_current_dir fn = + fn = current_dir_name || fn = "" + + + let concat f1 f2 = + if is_current_dir f1 then + f2 + else + let f1' = + try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 + in + f1'^"/"^f2 + + + let make = + function + | hd :: tl -> + List.fold_left + (fun f p -> concat f p) + hd + tl + | [] -> + invalid_arg "OASISUnixPath.make" + + + let dirname f = + try + String.sub f 0 (String.rindex f '/') + with Not_found -> + current_dir_name + + + let basename f = + try + let pos_start = + (String.rindex f '/') + 1 + in + String.sub f pos_start ((String.length f) - pos_start) + with Not_found -> + f + + + let chop_extension f = + try + let last_dot = + String.rindex f '.' + in + let sub = + String.sub f 0 last_dot + in + try + let last_slash = + String.rindex f '/' + in + if last_slash < last_dot then + sub + else + f + with Not_found -> + sub + + with Not_found -> + f + + + let capitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (OASISString.capitalize_ascii base) + + + let uncapitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (OASISString.uncapitalize_ascii base) + + +end + +module OASISHostPath = struct +(* # 22 "src/oasis/OASISHostPath.ml" *) + + + open Filename + open OASISGettext + + + module Unix = OASISUnixPath + + + let make = + function + | [] -> + invalid_arg "OASISHostPath.make" + | hd :: tl -> + List.fold_left Filename.concat hd tl + + + let of_unix ufn = + match Sys.os_type with + | "Unix" | "Cygwin" -> ufn + | "Win32" -> + make + (List.map + (fun p -> + if p = Unix.current_dir_name then + current_dir_name + else if p = Unix.parent_dir_name then + parent_dir_name + else + p) + (OASISString.nsplit ufn '/')) + | os_type -> + OASISUtils.failwithf + (f_ "Don't know the path format of os_type %S when translating unix \ + filename. %S") + os_type ufn + + +end + +module OASISFileSystem = struct +(* # 22 "src/oasis/OASISFileSystem.ml" *) + + (** File System functions + + @author Sylvain Le Gall + *) + + type 'a filename = string + + class type closer = + object + method close: unit + end + + class type reader = + object + inherit closer + method input: Buffer.t -> int -> unit + end + + class type writer = + object + inherit closer + method output: Buffer.t -> unit + end + + class type ['a] fs = + object + method string_of_filename: 'a filename -> string + method open_out: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> writer + method open_in: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> reader + method file_exists: 'a filename -> bool + method remove: 'a filename -> unit + end + + + module Mode = + struct + let default_in = [Open_rdonly] + let default_out = [Open_wronly; Open_creat; Open_trunc] + + let text_in = Open_text :: default_in + let text_out = Open_text :: default_out + + let binary_in = Open_binary :: default_in + let binary_out = Open_binary :: default_out + end + + let std_length = 4096 (* Standard buffer/read length. *) + let binary_out = Mode.binary_out + let binary_in = Mode.binary_in + + let of_unix_filename ufn = (ufn: 'a filename) + let to_unix_filename fn = (fn: string) + + + let defer_close o f = + try + let r = f o in o#close; r + with e -> + o#close; raise e + + + let stream_of_reader rdr = + let buf = Buffer.create std_length in + let pos = ref 0 in + let eof = ref false in + let rec next idx = + let bpos = idx - !pos in + if !eof then begin + None + end else if bpos < Buffer.length buf then begin + Some (Buffer.nth buf bpos) + end else begin + pos := !pos + Buffer.length buf; + Buffer.clear buf; + begin + try + rdr#input buf std_length; + with End_of_file -> + if Buffer.length buf = 0 then + eof := true + end; + next idx + end + in + Stream.from next + + + let read_all buf rdr = + try + while true do + rdr#input buf std_length + done + with End_of_file -> + () + + class ['a] host_fs rootdir : ['a] fs = + object (self) + method private host_filename fn = Filename.concat rootdir fn + method string_of_filename = self#host_filename + + method open_out ?(mode=Mode.text_out) ?(perm=0o666) fn = + let chn = open_out_gen mode perm (self#host_filename fn) in + object + method close = close_out chn + method output buf = Buffer.output_buffer chn buf + end + + method open_in ?(mode=Mode.text_in) ?(perm=0o666) fn = + (* TODO: use Buffer.add_channel when minimal version of OCaml will + * be >= 4.03.0 (previous version was discarding last chars). + *) + let chn = open_in_gen mode perm (self#host_filename fn) in + let strm = Stream.of_channel chn in + object + method close = close_in chn + method input buf len = + let read = ref 0 in + try + for _i = 0 to len do + Buffer.add_char buf (Stream.next strm); + incr read + done + with Stream.Failure -> + if !read = 0 then + raise End_of_file + end + + method file_exists fn = Sys.file_exists (self#host_filename fn) + method remove fn = Sys.remove (self#host_filename fn) + end + +end + +module OASISContext = struct +(* # 22 "src/oasis/OASISContext.ml" *) + + + open OASISGettext + + + type level = + [ `Debug + | `Info + | `Warning + | `Error] + + + type source + type source_filename = source OASISFileSystem.filename + + + let in_srcdir ufn = OASISFileSystem.of_unix_filename ufn + + + type t = + { + (* TODO: replace this by a proplist. *) + quiet: bool; + info: bool; + debug: bool; + ignore_plugins: bool; + ignore_unknown_fields: bool; + printf: level -> string -> unit; + srcfs: source OASISFileSystem.fs; + load_oasis_plugin: string -> bool; + } + + + let printf lvl str = + let beg = + match lvl with + | `Error -> s_ "E: " + | `Warning -> s_ "W: " + | `Info -> s_ "I: " + | `Debug -> s_ "D: " + in + prerr_endline (beg^str) + + + let default = + ref + { + quiet = false; + info = false; + debug = false; + ignore_plugins = false; + ignore_unknown_fields = false; + printf = printf; + srcfs = new OASISFileSystem.host_fs(Sys.getcwd ()); + load_oasis_plugin = (fun _ -> false); + } + + + let quiet = + {!default with quiet = true} + + + let fspecs () = + (* TODO: don't act on default. *) + let ignore_plugins = ref false in + ["-quiet", + Arg.Unit (fun () -> default := {!default with quiet = true}), + s_ " Run quietly"; + + "-info", + Arg.Unit (fun () -> default := {!default with info = true}), + s_ " Display information message"; + + + "-debug", + Arg.Unit (fun () -> default := {!default with debug = true}), + s_ " Output debug message"; + + "-ignore-plugins", + Arg.Set ignore_plugins, + s_ " Ignore plugin's field."; + + "-C", + Arg.String + (fun str -> + Sys.chdir str; + default := {!default with srcfs = new OASISFileSystem.host_fs str}), + s_ "dir Change directory before running (affects setup.{data,log})."], + fun () -> {!default with ignore_plugins = !ignore_plugins} +end + +module PropList = struct +(* # 22 "src/oasis/PropList.ml" *) + + + open OASISGettext + + + type name = string + + + exception Not_set of name * string option + exception No_printer of name + exception Unknown_field of name * name + + + let () = + Printexc.register_printer + (function + | Not_set (nm, Some rsn) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) + | Not_set (nm, None) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set") nm) + | No_printer nm -> + Some + (Printf.sprintf (f_ "No default printer for value %s") nm) + | Unknown_field (nm, schm) -> + Some + (Printf.sprintf + (f_ "Field %s is not defined in schema %s") nm schm) + | _ -> + None) + + + module Data = + struct + type t = + (name, unit -> unit) Hashtbl.t + + let create () = + Hashtbl.create 13 + + let clear t = + Hashtbl.clear t + + +(* # 77 "src/oasis/PropList.ml" *) + end + + + module Schema = + struct + type ('ctxt, 'extra) value = + { + get: Data.t -> string; + set: Data.t -> ?context:'ctxt -> string -> unit; + help: (unit -> string) option; + extra: 'extra; + } + + type ('ctxt, 'extra) t = + { + name: name; + fields: (name, ('ctxt, 'extra) value) Hashtbl.t; + order: name Queue.t; + name_norm: string -> string; + } + + let create ?(case_insensitive=false) nm = + { + name = nm; + fields = Hashtbl.create 13; + order = Queue.create (); + name_norm = + (if case_insensitive then + OASISString.lowercase_ascii + else + fun s -> s); + } + + let add t nm set get extra help = + let key = + t.name_norm nm + in + + if Hashtbl.mem t.fields key then + failwith + (Printf.sprintf + (f_ "Field '%s' is already defined in schema '%s'") + nm t.name); + Hashtbl.add + t.fields + key + { + set = set; + get = get; + help = help; + extra = extra; + }; + Queue.add nm t.order + + let mem t nm = + Hashtbl.mem t.fields nm + + let find t nm = + try + Hashtbl.find t.fields (t.name_norm nm) + with Not_found -> + raise (Unknown_field (nm, t.name)) + + let get t data nm = + (find t nm).get data + + let set t data nm ?context x = + (find t nm).set + data + ?context + x + + let fold f acc t = + Queue.fold + (fun acc k -> + let v = + find t k + in + f acc k v.extra v.help) + acc + t.order + + let iter f t = + fold + (fun () -> f) + () + t + + let name t = + t.name + end + + + module Field = + struct + type ('ctxt, 'value, 'extra) t = + { + set: Data.t -> ?context:'ctxt -> 'value -> unit; + get: Data.t -> 'value; + sets: Data.t -> ?context:'ctxt -> string -> unit; + gets: Data.t -> string; + help: (unit -> string) option; + extra: 'extra; + } + + let new_id = + let last_id = + ref 0 + in + fun () -> incr last_id; !last_id + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + (* Default value container *) + let v = + ref None + in + + (* If name is not given, create unique one *) + let nm = + match name with + | Some s -> s + | None -> Printf.sprintf "_anon_%d" (new_id ()) + in + + (* Last chance to get a value: the default *) + let default () = + match default with + | Some d -> d + | None -> raise (Not_set (nm, Some (s_ "no default value"))) + in + + (* Get data *) + let get data = + (* Get value *) + try + (Hashtbl.find data nm) (); + match !v with + | Some x -> x + | None -> default () + with Not_found -> + default () + in + + (* Set data *) + let set data ?context x = + let x = + match update with + | Some f -> + begin + try + f ?context (get data) x + with Not_set _ -> + x + end + | None -> + x + in + Hashtbl.replace + data + nm + (fun () -> v := Some x) + in + + (* Parse string value, if possible *) + let parse = + match parse with + | Some f -> + f + | None -> + fun ?context s -> + failwith + (Printf.sprintf + (f_ "Cannot parse field '%s' when setting value %S") + nm + s) + in + + (* Set data, from string *) + let sets data ?context s = + set ?context data (parse ?context s) + in + + (* Output value as string, if possible *) + let print = + match print with + | Some f -> + f + | None -> + fun _ -> raise (No_printer nm) + in + + (* Get data, as a string *) + let gets data = + print (get data) + in + + begin + match schema with + | Some t -> + Schema.add t nm sets gets extra help + | None -> + () + end; + + { + set = set; + get = get; + sets = sets; + gets = gets; + help = help; + extra = extra; + } + + let fset data t ?context x = + t.set data ?context x + + let fget data t = + t.get data + + let fsets data t ?context s = + t.sets data ?context s + + let fgets data t = + t.gets data + end + + + module FieldRO = + struct + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + let fld = + Field.create ?schema ?name ?parse ?print ?default ?update ?help extra + in + fun data -> Field.fget data fld + end +end + +module OASISMessage = struct +(* # 22 "src/oasis/OASISMessage.ml" *) + + + open OASISGettext + open OASISContext + + + let generic_message ~ctxt lvl fmt = + let cond = + if ctxt.quiet then + false + else + match lvl with + | `Debug -> ctxt.debug + | `Info -> ctxt.info + | _ -> true + in + Printf.ksprintf + (fun str -> + if cond then + begin + ctxt.printf lvl str + end) + fmt + + + let debug ~ctxt fmt = + generic_message ~ctxt `Debug fmt + + + let info ~ctxt fmt = + generic_message ~ctxt `Info fmt + + + let warning ~ctxt fmt = + generic_message ~ctxt `Warning fmt + + + let error ~ctxt fmt = + generic_message ~ctxt `Error fmt + +end + +module OASISVersion = struct +(* # 22 "src/oasis/OASISVersion.ml" *) + + + open OASISGettext + + + type t = string + + + type comparator = + | VGreater of t + | VGreaterEqual of t + | VEqual of t + | VLesser of t + | VLesserEqual of t + | VOr of comparator * comparator + | VAnd of comparator * comparator + + + (* Range of allowed characters *) + let is_digit c = '0' <= c && c <= '9' + let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') + let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false + + + let rec version_compare v1 v2 = + if v1 <> "" || v2 <> "" then + begin + (* Compare ascii string, using special meaning for version + * related char + *) + let val_ascii c = + if c = '~' then -1 + else if is_digit c then 0 + else if c = '\000' then 0 + else if is_alpha c then Char.code c + else (Char.code c) + 256 + in + + let len1 = String.length v1 in + let len2 = String.length v2 in + + let p = ref 0 in + + (** Compare ascii part *) + let compare_vascii () = + let cmp = ref 0 in + while !cmp = 0 && + !p < len1 && !p < len2 && + not (is_digit v1.[!p] && is_digit v2.[!p]) do + cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); + incr p + done; + if !cmp = 0 && !p < len1 && !p = len2 then + val_ascii v1.[!p] + else if !cmp = 0 && !p = len1 && !p < len2 then + - (val_ascii v2.[!p]) + else + !cmp + in + + (** Compare digit part *) + let compare_digit () = + let extract_int v p = + let start_p = !p in + while !p < String.length v && is_digit v.[!p] do + incr p + done; + let substr = + String.sub v !p ((String.length v) - !p) + in + let res = + match String.sub v start_p (!p - start_p) with + | "" -> 0 + | s -> int_of_string s + in + res, substr + in + let i1, tl1 = extract_int v1 (ref !p) in + let i2, tl2 = extract_int v2 (ref !p) in + i1 - i2, tl1, tl2 + in + + match compare_vascii () with + | 0 -> + begin + match compare_digit () with + | 0, tl1, tl2 -> + if tl1 <> "" && is_digit tl1.[0] then + 1 + else if tl2 <> "" && is_digit tl2.[0] then + -1 + else + version_compare tl1 tl2 + | n, _, _ -> + n + end + | n -> + n + end + else begin + 0 + end + + + let version_of_string str = str + + + let string_of_version t = t + + + let chop t = + try + let pos = + String.rindex t '.' + in + String.sub t 0 pos + with Not_found -> + t + + + let rec comparator_apply v op = + match op with + | VGreater cv -> + (version_compare v cv) > 0 + | VGreaterEqual cv -> + (version_compare v cv) >= 0 + | VLesser cv -> + (version_compare v cv) < 0 + | VLesserEqual cv -> + (version_compare v cv) <= 0 + | VEqual cv -> + (version_compare v cv) = 0 + | VOr (op1, op2) -> + (comparator_apply v op1) || (comparator_apply v op2) + | VAnd (op1, op2) -> + (comparator_apply v op1) && (comparator_apply v op2) + + + let rec string_of_comparator = + function + | VGreater v -> "> "^(string_of_version v) + | VEqual v -> "= "^(string_of_version v) + | VLesser v -> "< "^(string_of_version v) + | VGreaterEqual v -> ">= "^(string_of_version v) + | VLesserEqual v -> "<= "^(string_of_version v) + | VOr (c1, c2) -> + (string_of_comparator c1)^" || "^(string_of_comparator c2) + | VAnd (c1, c2) -> + (string_of_comparator c1)^" && "^(string_of_comparator c2) + + + let rec varname_of_comparator = + let concat p v = + OASISUtils.varname_concat + p + (OASISUtils.varname_of_string + (string_of_version v)) + in + function + | VGreater v -> concat "gt" v + | VLesser v -> concat "lt" v + | VEqual v -> concat "eq" v + | VGreaterEqual v -> concat "ge" v + | VLesserEqual v -> concat "le" v + | VOr (c1, c2) -> + (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) + | VAnd (c1, c2) -> + (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) + + +end + +module OASISLicense = struct +(* # 22 "src/oasis/OASISLicense.ml" *) + + + (** License for _oasis fields + @author Sylvain Le Gall + *) + + + type license = string + type license_exception = string + + + type license_version = + | Version of OASISVersion.t + | VersionOrLater of OASISVersion.t + | NoVersion + + + type license_dep_5_unit = + { + license: license; + excption: license_exception option; + version: license_version; + } + + + type license_dep_5 = + | DEP5Unit of license_dep_5_unit + | DEP5Or of license_dep_5 list + | DEP5And of license_dep_5 list + + + type t = + | DEP5License of license_dep_5 + | OtherLicense of string (* URL *) + + +end + +module OASISExpr = struct +(* # 22 "src/oasis/OASISExpr.ml" *) + + + open OASISGettext + open OASISUtils + + + type test = string + type flag = string + + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + type 'a choices = (t * 'a) list + + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + + +end + +module OASISText = struct +(* # 22 "src/oasis/OASISText.ml" *) + + type elt = + | Para of string + | Verbatim of string + | BlankLine + + type t = elt list + +end + +module OASISSourcePatterns = struct +(* # 22 "src/oasis/OASISSourcePatterns.ml" *) + + open OASISUtils + open OASISGettext + + module Templater = + struct + (* TODO: use this module in BaseEnv.var_expand and BaseFileAB, at least. *) + type t = + { + atoms: atom list; + origin: string + } + and atom = + | Text of string + | Expr of expr + and expr = + | Ident of string + | String of string + | Call of string * expr + + + type env = + { + variables: string MapString.t; + functions: (string -> string) MapString.t; + } + + + let eval env t = + let rec eval_expr env = + function + | String str -> str + | Ident nm -> + begin + try + MapString.find nm env.variables + with Not_found -> + (* TODO: add error location within the string. *) + failwithf + (f_ "Unable to find variable %S in source pattern %S") + nm t.origin + end + + | Call (fn, expr) -> + begin + try + (MapString.find fn env.functions) (eval_expr env expr) + with Not_found -> + (* TODO: add error location within the string. *) + failwithf + (f_ "Unable to find function %S in source pattern %S") + fn t.origin + end + in + String.concat "" + (List.map + (function + | Text str -> str + | Expr expr -> eval_expr env expr) + t.atoms) + + + let parse env s = + let lxr = Genlex.make_lexer [] in + let parse_expr s = + let st = lxr (Stream.of_string s) in + match Stream.npeek 3 st with + | [Genlex.Ident fn; Genlex.Ident nm] -> Call(fn, Ident nm) + | [Genlex.Ident fn; Genlex.String str] -> Call(fn, String str) + | [Genlex.String str] -> String str + | [Genlex.Ident nm] -> Ident nm + (* TODO: add error location within the string. *) + | _ -> failwithf (f_ "Unable to parse expression %S") s + in + let parse s = + let lst_exprs = ref [] in + let ss = + let buff = Buffer.create (String.length s) in + Buffer.add_substitute + buff + (fun s -> lst_exprs := (parse_expr s) :: !lst_exprs; "\000") + s; + Buffer.contents buff + in + let rec join = + function + | hd1 :: tl1, hd2 :: tl2 -> Text hd1 :: Expr hd2 :: join (tl1, tl2) + | [], tl -> List.map (fun e -> Expr e) tl + | tl, [] -> List.map (fun e -> Text e) tl + in + join (OASISString.nsplit ss '\000', List.rev (!lst_exprs)) + in + let t = {atoms = parse s; origin = s} in + (* We rely on a simple evaluation for checking variables/functions. + It works because there is no if/loop statement. + *) + let _s : string = eval env t in + t + +(* # 144 "src/oasis/OASISSourcePatterns.ml" *) + end + + + type t = Templater.t + + + let env ~modul () = + { + Templater. + variables = MapString.of_list ["module", modul]; + functions = MapString.of_list + [ + "capitalize_file", OASISUnixPath.capitalize_file; + "uncapitalize_file", OASISUnixPath.uncapitalize_file; + ]; + } + + let all_possible_files lst ~path ~modul = + let eval = Templater.eval (env ~modul ()) in + List.fold_left + (fun acc pat -> OASISUnixPath.concat path (eval pat) :: acc) + [] lst + + + let to_string t = t.Templater.origin + + +end + +module OASISTypes = struct +(* # 22 "src/oasis/OASISTypes.ml" *) + + + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string (* TODO: replace everywhere. *) + type host_dirname = string (* TODO: replace everywhere. *) + type host_filename = string (* TODO: replace everywhere. *) + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) + + + type findlib_name = string + type findlib_full = string + + + type compiled_object = + | Byte + | Native + | Best + + + type dependency = + | FindlibPackage of findlib_full * OASISVersion.comparator option + | InternalLibrary of name + + + type tool = + | ExternalTool of name + | InternalExecutable of name + + + type vcs = + | Darcs + | Git + | Svn + | Cvs + | Hg + | Bzr + | Arch + | Monotone + | OtherVCS of url + + + type plugin_kind = + [ `Configure + | `Build + | `Doc + | `Test + | `Install + | `Extra + ] + + + type plugin_data_purpose = + [ `Configure + | `Build + | `Install + | `Clean + | `Distclean + | `Install + | `Uninstall + | `Test + | `Doc + | `Extra + | `Other of string + ] + + + type 'a plugin = 'a * name * OASISVersion.t option + + + type all_plugin = plugin_kind plugin + + + type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list + + + type 'a conditional = 'a OASISExpr.choices + + + type custom = + { + pre_command: (command_line option) conditional; + post_command: (command_line option) conditional; + } + + + type common_section = + { + cs_name: name; + cs_data: PropList.Data.t; + cs_plugin_data: plugin_data; + } + + + type build_section = + { + bs_build: bool conditional; + bs_install: bool conditional; + bs_path: unix_dirname; + bs_compiled_object: compiled_object; + bs_build_depends: dependency list; + bs_build_tools: tool list; + bs_interface_patterns: OASISSourcePatterns.t list; + bs_implementation_patterns: OASISSourcePatterns.t list; + bs_c_sources: unix_filename list; + bs_data_files: (unix_filename * unix_filename option) list; + bs_findlib_extra_files: unix_filename list; + bs_ccopt: args conditional; + bs_cclib: args conditional; + bs_dlllib: args conditional; + bs_dllpath: args conditional; + bs_byteopt: args conditional; + bs_nativeopt: args conditional; + } + + + type library = + { + lib_modules: string list; + lib_pack: bool; + lib_internal_modules: string list; + lib_findlib_parent: findlib_name option; + lib_findlib_name: findlib_name option; + lib_findlib_directory: unix_dirname option; + lib_findlib_containers: findlib_name list; + } + + + type object_ = + { + obj_modules: string list; + obj_findlib_fullname: findlib_name list option; + obj_findlib_directory: unix_dirname option; + } + + + type executable = + { + exec_custom: bool; + exec_main_is: unix_filename; + } + + + type flag = + { + flag_description: string option; + flag_default: bool conditional; + } + + + type source_repository = + { + src_repo_type: vcs; + src_repo_location: url; + src_repo_browser: url option; + src_repo_module: string option; + src_repo_branch: string option; + src_repo_tag: string option; + src_repo_subdir: unix_filename option; + } + + + type test = + { + test_type: [`Test] plugin; + test_command: command_line conditional; + test_custom: custom; + test_working_directory: unix_filename option; + test_run: bool conditional; + test_tools: tool list; + } + + + type doc_format = + | HTML of unix_filename (* TODO: source filename. *) + | DocText + | PDF + | PostScript + | Info of unix_filename (* TODO: source filename. *) + | DVI + | OtherDoc + + + type doc = + { + doc_type: [`Doc] plugin; + doc_custom: custom; + doc_build: bool conditional; + doc_install: bool conditional; + doc_install_dir: unix_filename; (* TODO: dest filename ?. *) + doc_title: string; + doc_authors: string list; + doc_abstract: string option; + doc_format: doc_format; + (* TODO: src filename. *) + doc_data_files: (unix_filename * unix_filename option) list; + doc_build_tools: tool list; + } + + + type section = + | Library of common_section * build_section * library + | Object of common_section * build_section * object_ + | Executable of common_section * build_section * executable + | Flag of common_section * flag + | SrcRepo of common_section * source_repository + | Test of common_section * test + | Doc of common_section * doc + + + type section_kind = + [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + + + type package = + { + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; (* TODO: source filename. *) + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + bugreports: url option; + synopsis: string; + description: OASISText.t option; + tags: string list; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; (* TODO: source filename. *) + sections: section list; + plugins: [`Extra] plugin list; + disable_oasis_section: unix_filename list; (* TODO: source filename. *) + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } + + +end + +module OASISFeatures = struct +(* # 22 "src/oasis/OASISFeatures.ml" *) + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISVersion + + module MapPlugin = + Map.Make + (struct + type t = plugin_kind * name + let compare = Pervasives.compare + end) + + module Data = + struct + type t = + { + oasis_version: OASISVersion.t; + plugin_versions: OASISVersion.t option MapPlugin.t; + alpha_features: string list; + beta_features: string list; + } + + let create oasis_version alpha_features beta_features = + { + oasis_version = oasis_version; + plugin_versions = MapPlugin.empty; + alpha_features = alpha_features; + beta_features = beta_features + } + + let of_package pkg = + create + pkg.OASISTypes.oasis_version + pkg.OASISTypes.alpha_features + pkg.OASISTypes.beta_features + + let add_plugin (plugin_kind, plugin_name, plugin_version) t = + {t with + plugin_versions = MapPlugin.add + (plugin_kind, plugin_name) + plugin_version + t.plugin_versions} + + let plugin_version plugin_kind plugin_name t = + MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions + + let to_string t = + Printf.sprintf + "oasis_version: %s; alpha_features: %s; beta_features: %s; \ + plugins_version: %s" + (OASISVersion.string_of_version (t:t).oasis_version) + (String.concat ", " t.alpha_features) + (String.concat ", " t.beta_features) + (String.concat ", " + (MapPlugin.fold + (fun (_, plg) ver_opt acc -> + (plg^ + (match ver_opt with + | Some v -> + " "^(OASISVersion.string_of_version v) + | None -> "")) + :: acc) + t.plugin_versions [])) + end + + type origin = + | Field of string * string + | Section of string + | NoOrigin + + type stage = Alpha | Beta + + + let string_of_stage = + function + | Alpha -> "alpha" + | Beta -> "beta" + + + let field_of_stage = + function + | Alpha -> "AlphaFeatures" + | Beta -> "BetaFeatures" + + type publication = InDev of stage | SinceVersion of OASISVersion.t + + type t = + { + name: string; + plugin: all_plugin option; + publication: publication; + description: unit -> string; + } + + (* TODO: mutex protect this. *) + let all_features = Hashtbl.create 13 + + + let since_version ver_str = SinceVersion (version_of_string ver_str) + let alpha = InDev Alpha + let beta = InDev Beta + + + let to_string t = + Printf.sprintf + "feature: %s; plugin: %s; publication: %s" + (t:t).name + (match t.plugin with + | None -> "" + | Some (_, nm, _) -> nm) + (match t.publication with + | InDev stage -> string_of_stage stage + | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) + + let data_check t data origin = + let no_message = "no message" in + + let check_feature features stage = + let has_feature = List.mem (t:t).name features in + if not has_feature then + match (origin:origin) with + | Field (fld, where) -> + Some + (Printf.sprintf + (f_ "Field %s in %s is only available when feature %s \ + is in field %s.") + fld where t.name (field_of_stage stage)) + | Section sct -> + Some + (Printf.sprintf + (f_ "Section %s is only available when features %s \ + is in field %s.") + sct t.name (field_of_stage stage)) + | NoOrigin -> + Some no_message + else + None + in + + let version_is_good ~min_version version fmt = + let version_is_good = + OASISVersion.comparator_apply + version (OASISVersion.VGreaterEqual min_version) + in + Printf.ksprintf + (fun str -> if version_is_good then None else Some str) + fmt + in + + match origin, t.plugin, t.publication with + | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha + | _, _, InDev Beta -> check_feature data.Data.beta_features Beta + | Field(fld, where), None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Field %s in %s is only valid since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking \ + OASIS changelog.") + fld where (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Field(fld, where), Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Field %s in %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + fld where plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Field %s in %s is only valid when the OASIS plugin %s \ + is defined.") + fld where plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Field %s in %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + fld where plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | Section sct, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Section %s is only valid for since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking OASIS \ + changelog.") + sct (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Section sct, Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Section %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + sct plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Section %s is only valid when the OASIS plugin %s \ + is defined.") + sct plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Section %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + sct plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | NoOrigin, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version "%s" no_message + + | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> + begin + try + let plugin_version_current = + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> raise Not_found + in + version_is_good ~min_version plugin_version_current + "%s" no_message + with Not_found -> + Some no_message + end + + + let data_assert t data origin = + match data_check t data origin with + | None -> () + | Some str -> failwith str + + + let data_test t data = + match data_check t data NoOrigin with + | None -> true + | Some _ -> false + + + let package_test t pkg = + data_test t (Data.of_package pkg) + + + let create ?plugin name publication description = + let () = + if Hashtbl.mem all_features name then + failwithf "Feature '%s' is already declared." name + in + let t = + { + name = name; + plugin = plugin; + publication = publication; + description = description; + } + in + Hashtbl.add all_features name t; + t + + + let get_stage name = + try + (Hashtbl.find all_features name).publication + with Not_found -> + failwithf (f_ "Feature %s doesn't exist.") name + + + let list () = + Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] + + (* + * Real flags. + *) + + + let features = + create "features_fields" + (since_version "0.4") + (fun () -> + s_ "Enable to experiment not yet official features.") + + + let flag_docs = + create "flag_docs" + (since_version "0.3") + (fun () -> + s_ "Make building docs require '-docs' flag at configure.") + + + let flag_tests = + create "flag_tests" + (since_version "0.3") + (fun () -> + s_ "Make running tests require '-tests' flag at configure.") + + + let pack = + create "pack" + (since_version "0.3") + (fun () -> + s_ "Allow to create packed library.") + + + let section_object = + create "section_object" beta + (fun () -> + s_ "Implement an object section.") + + + let dynrun_for_release = + create "dynrun_for_release" alpha + (fun () -> + s_ "Make '-setup-update dynamic' suitable for releasing project.") + + + let compiled_setup_ml = + create "compiled_setup_ml" alpha + (fun () -> + s_ "Compile the setup.ml and speed-up actions done with it.") + + let disable_oasis_section = + create "disable_oasis_section" alpha + (fun () -> + s_ "Allow the OASIS section comments and digests to be omitted in \ + generated files.") + + let no_automatic_syntax = + create "no_automatic_syntax" alpha + (fun () -> + s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ + that matches the internal heuristic (if a dependency ends with \ + a .syntax or is a well known syntax).") + + let findlib_directory = + create "findlib_directory" beta + (fun () -> + s_ "Allow to install findlib libraries in sub-directories of the target \ + findlib directory.") + + let findlib_extra_files = + create "findlib_extra_files" beta + (fun () -> + s_ "Allow to install extra files for findlib libraries.") + + let source_patterns = + create "source_patterns" alpha + (fun () -> + s_ "Customize mapping between module name and source file.") +end + +module OASISSection = struct +(* # 22 "src/oasis/OASISSection.ml" *) + + + open OASISTypes + + + let section_kind_common = + function + | Library (cs, _, _) -> + `Library, cs + | Object (cs, _, _) -> + `Object, cs + | Executable (cs, _, _) -> + `Executable, cs + | Flag (cs, _) -> + `Flag, cs + | SrcRepo (cs, _) -> + `SrcRepo, cs + | Test (cs, _) -> + `Test, cs + | Doc (cs, _) -> + `Doc, cs + + + let section_common sct = + snd (section_kind_common sct) + + + let section_common_set cs = + function + | Library (_, bs, lib) -> Library (cs, bs, lib) + | Object (_, bs, obj) -> Object (cs, bs, obj) + | Executable (_, bs, exec) -> Executable (cs, bs, exec) + | Flag (_, flg) -> Flag (cs, flg) + | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) + | Test (_, tst) -> Test (cs, tst) + | Doc (_, doc) -> Doc (cs, doc) + + + (** Key used to identify section + *) + let section_id sct = + let k, cs = + section_kind_common sct + in + k, cs.cs_name + + + let string_of_section_kind = + function + | `Library -> "library" + | `Object -> "object" + | `Executable -> "executable" + | `Flag -> "flag" + | `SrcRepo -> "src repository" + | `Test -> "test" + | `Doc -> "doc" + + + let string_of_section sct = + let k, nm = section_id sct in + (string_of_section_kind k)^" "^nm + + + let section_find id scts = + List.find + (fun sct -> id = section_id sct) + scts + + + module CSection = + struct + type t = section + + let id = section_id + + let compare t1 t2 = + compare (id t1) (id t2) + + let equal t1 t2 = + (id t1) = (id t2) + + let hash t = + Hashtbl.hash (id t) + end + + + module MapSection = Map.Make(CSection) + module SetSection = Set.Make(CSection) + + +end + +module OASISBuildSection = struct +(* # 22 "src/oasis/OASISBuildSection.ml" *) + + open OASISTypes + + (* Look for a module file, considering capitalization or not. *) + let find_module source_file_exists bs modul = + let possible_lst = + OASISSourcePatterns.all_possible_files + (bs.bs_interface_patterns @ bs.bs_implementation_patterns) + ~path:bs.bs_path + ~modul + in + match List.filter source_file_exists possible_lst with + | (fn :: _) as fn_lst -> `Sources (OASISUnixPath.chop_extension fn, fn_lst) + | [] -> + let open OASISUtils in + let _, rev_lst = + List.fold_left + (fun (set, acc) fn -> + let base_fn = OASISUnixPath.chop_extension fn in + if SetString.mem base_fn set then + set, acc + else + SetString.add base_fn set, base_fn :: acc) + (SetString.empty, []) possible_lst + in + `No_sources (List.rev rev_lst) + + +end + +module OASISExecutable = struct +(* # 22 "src/oasis/OASISExecutable.ml" *) + + + open OASISTypes + + + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = + OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.dirname exec.exec_main_is) + in + let is_native_exec = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native () + | Byte -> false + in + + OASISUnixPath.concat + dir + (cs.cs_name^(suffix_program ())), + + if not is_native_exec && + not exec.exec_custom && + bs.bs_c_sources <> [] then + Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) + else + None + + +end + +module OASISLibrary = struct +(* # 22 "src/oasis/OASISLibrary.ml" *) + + + open OASISTypes + open OASISGettext + + let find_module ~ctxt source_file_exists cs bs modul = + match OASISBuildSection.find_module source_file_exists bs modul with + | `Sources _ as res -> res + | `No_sources _ as res -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching module '%s' in library %s.") + modul cs.cs_name; + OASISMessage.warning + ~ctxt + (f_ "Use InterfacePatterns or ImplementationPatterns to define \ + this file with feature %S.") + (OASISFeatures.source_patterns.OASISFeatures.name); + res + + let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = + List.fold_left + (fun acc modul -> + match find_module ~ctxt source_file_exists cs bs modul with + | `Sources (base_fn, lst) -> (base_fn, lst) :: acc + | `No_sources _ -> acc) + [] + (lib.lib_modules @ lib.lib_internal_modules) + + + let generated_unix_files + ~ctxt + ~is_native + ~has_native_dynlink + ~ext_lib + ~ext_dll + ~source_file_exists + (cs, bs, lib) = + + let find_modules lst ext = + let find_module modul = + match find_module ~ctxt source_file_exists cs bs modul with + | `Sources (_, [fn]) when ext <> "cmi" + && Filename.check_suffix fn ".mli" -> + None (* No implementation files for pure interface. *) + | `Sources (base_fn, _) -> Some [base_fn] + | `No_sources lst -> Some lst + in + List.fold_left + (fun acc nm -> + match find_module nm with + | None -> acc + | Some base_fns -> + List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) + [] + lst + in + + (* The .cmx that be compiled along *) + let cmxs = + let should_be_built = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native + | Byte -> false + in + if should_be_built then + if lib.lib_pack then + find_modules + [cs.cs_name] + "cmx" + else + find_modules + (lib.lib_modules @ lib.lib_internal_modules) + "cmx" + else + [] + in + + let acc_nopath = + [] + in + + (* The headers and annot/cmt files that should be compiled along *) + let headers = + let sufx = + if lib.lib_pack + then [".cmti"; ".cmt"; ".annot"] + else [".cmi"; ".cmti"; ".cmt"; ".annot"] + in + List.map + (List.fold_left + (fun accu s -> + let dot = String.rindex s '.' in + let base = String.sub s 0 dot in + List.map ((^) base) sufx @ accu) + []) + (find_modules lib.lib_modules "cmi") + in + + (* Compute what libraries should be built *) + let acc_nopath = + (* Add the packed header file if required *) + let add_pack_header acc = + if lib.lib_pack then + [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc + else + acc + in + let byte acc = + add_pack_header ([cs.cs_name^".cma"] :: acc) + in + let native acc = + let acc = + add_pack_header + (if has_native_dynlink then + [cs.cs_name^".cmxs"] :: acc + else acc) + in + [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc + in + match bs.bs_compiled_object with + | Native -> byte (native acc_nopath) + | Best when is_native -> byte (native acc_nopath) + | Byte | Best -> byte acc_nopath + in + + (* Add C library to be built *) + let acc_nopath = + if bs.bs_c_sources <> [] then begin + ["lib"^cs.cs_name^"_stubs"^ext_lib] + :: + if has_native_dynlink then + ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath + else + acc_nopath + end else begin + acc_nopath + end + in + + (* All the files generated *) + List.rev_append + (List.rev_map + (List.rev_map + (OASISUnixPath.concat bs.bs_path)) + acc_nopath) + (headers @ cmxs) + + +end + +module OASISObject = struct +(* # 22 "src/oasis/OASISObject.ml" *) + + + open OASISTypes + open OASISGettext + + + let find_module ~ctxt source_file_exists cs bs modul = + match OASISBuildSection.find_module source_file_exists bs modul with + | `Sources _ as res -> res + | `No_sources _ as res -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching module '%s' in object %s.") + modul cs.cs_name; + OASISMessage.warning + ~ctxt + (f_ "Use InterfacePatterns or ImplementationPatterns to define \ + this file with feature %S.") + (OASISFeatures.source_patterns.OASISFeatures.name); + res + + let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = + List.fold_left + (fun acc modul -> + match find_module ~ctxt source_file_exists cs bs modul with + | `Sources (base_fn, lst) -> (base_fn, lst) :: acc + | `No_sources _ -> acc) + [] + obj.obj_modules + + + let generated_unix_files + ~ctxt + ~is_native + ~source_file_exists + (cs, bs, obj) = + + let find_module ext modul = + match find_module ~ctxt source_file_exists cs bs modul with + | `Sources (base_fn, _) -> [base_fn ^ ext] + | `No_sources lst -> lst + in + + let header, byte, native, c_object, f = + match obj.obj_modules with + | [ m ] -> (find_module ".cmi" m, + find_module ".cmo" m, + find_module ".cmx" m, + find_module ".o" m, + fun x -> x) + | _ -> ([cs.cs_name ^ ".cmi"], + [cs.cs_name ^ ".cmo"], + [cs.cs_name ^ ".cmx"], + [cs.cs_name ^ ".o"], + OASISUnixPath.concat bs.bs_path) + in + List.map (List.map f) ( + match bs.bs_compiled_object with + | Native -> + native :: c_object :: byte :: header :: [] + | Best when is_native -> + native :: c_object :: byte :: header :: [] + | Byte | Best -> + byte :: header :: []) + + +end + +module OASISFindlib = struct +(* # 22 "src/oasis/OASISFindlib.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + + + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + [`Library of library | `Object of object_] * + unix_dirname option * + group_t list) + + + type data = common_section * + build_section * + [`Library of library | `Object of object_] + type tree = + | Node of (data option) * (tree MapString.t) + | Leaf of data + + + let findlib_mapping pkg = + (* Map from library name to either full findlib name or parts + parent. *) + let fndlb_parts_of_lib_name = + let fndlb_parts cs lib = + let name = + match lib.lib_findlib_name with + | Some nm -> nm + | None -> cs.cs_name + in + let name = + String.concat "." (lib.lib_findlib_containers @ [name]) + in + name + in + List.fold_left + (fun mp -> + function + | Library (cs, _, lib) -> + begin + let lib_name = cs.cs_name in + let fndlb_parts = fndlb_parts cs lib in + if MapString.mem lib_name mp then + failwithf + (f_ "The library name '%s' is used more than once.") + lib_name; + match lib.lib_findlib_parent with + | Some lib_name_parent -> + MapString.add + lib_name + (`Unsolved (lib_name_parent, fndlb_parts)) + mp + | None -> + MapString.add + lib_name + (`Solved fndlb_parts) + mp + end + + | Object (cs, _, obj) -> + begin + let obj_name = cs.cs_name in + if MapString.mem obj_name mp then + failwithf + (f_ "The object name '%s' is used more than once.") + obj_name; + let findlib_full_name = match obj.obj_findlib_fullname with + | Some ns -> String.concat "." ns + | None -> obj_name + in + MapString.add + obj_name + (`Solved findlib_full_name) + mp + end + + | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> + mp) + MapString.empty + pkg.sections + in + + (* Solve the above graph to be only library name to full findlib name. *) + let fndlb_name_of_lib_name = + let rec solve visited mp lib_name lib_name_child = + if SetString.mem lib_name visited then + failwithf + (f_ "Library '%s' is involved in a cycle \ + with regard to findlib naming.") + lib_name; + let visited = SetString.add lib_name visited in + try + match MapString.find lib_name mp with + | `Solved fndlb_nm -> + fndlb_nm, mp + | `Unsolved (lib_nm_parent, post_fndlb_nm) -> + let pre_fndlb_nm, mp = + solve visited mp lib_nm_parent lib_name + in + let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in + fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp + with Not_found -> + failwithf + (f_ "Library '%s', which is defined as the findlib parent of \ + library '%s', doesn't exist.") + lib_name lib_name_child + in + let mp = + MapString.fold + (fun lib_name status mp -> + match status with + | `Solved _ -> + (* Solved initialy, no need to go further *) + mp + | `Unsolved _ -> + let _, mp = solve SetString.empty mp lib_name "" in + mp) + fndlb_parts_of_lib_name + fndlb_parts_of_lib_name + in + MapString.map + (function + | `Solved fndlb_nm -> fndlb_nm + | `Unsolved _ -> assert false) + mp + in + + (* Convert an internal library name to a findlib name. *) + let findlib_name_of_library_name lib_nm = + try + MapString.find lib_nm fndlb_name_of_lib_name + with Not_found -> + raise (InternalLibraryNotFound lib_nm) + in + + (* Add a library to the tree. + *) + let add sct mp = + let fndlb_fullname = + let cs, _, _ = sct in + let lib_name = cs.cs_name in + findlib_name_of_library_name lib_name + in + let rec add_children nm_lst (children: tree MapString.t) = + match nm_lst with + | (hd :: tl) -> + begin + let node = + try + add_node tl (MapString.find hd children) + with Not_found -> + (* New node *) + new_node tl + in + MapString.add hd node children + end + | [] -> + (* Should not have a nameless library. *) + assert false + and add_node tl node = + if tl = [] then + begin + match node with + | Node (None, children) -> + Node (Some sct, children) + | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> + (* TODO: allow to merge Package, i.e. + * archive(byte) = "foo.cma foo_init.cmo" + *) + let cs, _, _ = sct in + failwithf + (f_ "Library '%s' and '%s' have the same findlib name '%s'") + cs.cs_name cs'.cs_name fndlb_fullname + end + else + begin + match node with + | Leaf data -> + Node (Some data, add_children tl MapString.empty) + | Node (data_opt, children) -> + Node (data_opt, add_children tl children) + end + and new_node = + function + | [] -> + Leaf sct + | hd :: tl -> + Node (None, MapString.add hd (new_node tl) MapString.empty) + in + add_children (OASISString.nsplit fndlb_fullname '.') mp + in + + let unix_directory dn lib = + let directory = + match lib with + | `Library lib -> lib.lib_findlib_directory + | `Object obj -> obj.obj_findlib_directory + in + match dn, directory with + | None, None -> None + | None, Some dn | Some dn, None -> Some dn + | Some dn1, Some dn2 -> Some (OASISUnixPath.concat dn1 dn2) + in + + let rec group_of_tree dn mp = + MapString.fold + (fun nm node acc -> + let cur = + match node with + | Node (Some (cs, bs, lib), children) -> + let current_dn = unix_directory dn lib in + Package (nm, cs, bs, lib, current_dn, group_of_tree current_dn children) + | Node (None, children) -> + Container (nm, group_of_tree dn children) + | Leaf (cs, bs, lib) -> + let current_dn = unix_directory dn lib in + Package (nm, cs, bs, lib, current_dn, []) + in + cur :: acc) + mp [] + in + + let group_mp = + List.fold_left + (fun mp -> + function + | Library (cs, bs, lib) -> + add (cs, bs, `Library lib) mp + | Object (cs, bs, obj) -> + add (cs, bs, `Object obj) mp + | _ -> + mp) + MapString.empty + pkg.sections + in + + let groups = group_of_tree None group_mp in + + let library_name_of_findlib_name = + lazy begin + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty + end + in + let library_name_of_findlib_name fndlb_nm = + try + MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) + with Not_found -> + raise (FindlibPackageNotFound fndlb_nm) + in + + groups, + findlib_name_of_library_name, + library_name_of_findlib_name + + + let findlib_of_group = + function + | Container (fndlb_nm, _) + | Package (fndlb_nm, _, _, _, _, _) -> fndlb_nm + + + let root_of_group grp = + let rec root_lib_aux = + (* We do a DFS in the group. *) + function + | Container (_, children) -> + List.fold_left + (fun res grp -> + if res = None then + root_lib_aux grp + else + res) + None + children + | Package (_, cs, bs, lib, _, _) -> + Some (cs, bs, lib) + in + match root_lib_aux grp with + | Some res -> + res + | None -> + failwithf + (f_ "Unable to determine root library of findlib library '%s'") + (findlib_of_group grp) + + +end + +module OASISFlag = struct +(* # 22 "src/oasis/OASISFlag.ml" *) + + +end + +module OASISPackage = struct +(* # 22 "src/oasis/OASISPackage.ml" *) + + +end + +module OASISSourceRepository = struct +(* # 22 "src/oasis/OASISSourceRepository.ml" *) + + +end + +module OASISTest = struct +(* # 22 "src/oasis/OASISTest.ml" *) + + +end + +module OASISDocument = struct +(* # 22 "src/oasis/OASISDocument.ml" *) + + +end + +module OASISExec = struct +(* # 22 "src/oasis/OASISExec.ml" *) + + + open OASISGettext + open OASISUtils + open OASISMessage + + + (* TODO: I don't like this quote, it is there because $(rm) foo expands to + * 'rm -f' foo... + *) + let run ~ctxt ?f_exit_code ?(quote=true) cmd args = + let cmd = + if quote then + if Sys.os_type = "Win32" then + if String.contains cmd ' ' then + (* Double the 1st double quote... win32... sigh *) + "\""^(Filename.quote cmd) + else + cmd + else + Filename.quote cmd + else + cmd + in + let cmdline = + String.concat " " (cmd :: args) + in + info ~ctxt (f_ "Running command '%s'") cmdline; + match f_exit_code, Sys.command cmdline with + | None, 0 -> () + | None, i -> + failwithf + (f_ "Command '%s' terminated with error code %d") + cmdline i + | Some f, i -> + f i + + + let run_read_output ~ctxt ?f_exit_code cmd args = + let fn = + Filename.temp_file "oasis-" ".txt" + in + try + begin + let () = + run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) + in + let chn = + open_in fn + in + let routput = + ref [] + in + begin + try + while true do + routput := (input_line chn) :: !routput + done + with End_of_file -> + () + end; + close_in chn; + Sys.remove fn; + List.rev !routput + end + with e -> + (try Sys.remove fn with _ -> ()); + raise e + + + let run_read_one_line ~ctxt ?f_exit_code cmd args = + match run_read_output ~ctxt ?f_exit_code cmd args with + | [fst] -> + fst + | lst -> + failwithf + (f_ "Command return unexpected output %S") + (String.concat "\n" lst) +end + +module OASISFileUtil = struct +(* # 22 "src/oasis/OASISFileUtil.ml" *) + + + open OASISGettext + + + let file_exists_case fn = + let dirname = Filename.dirname fn in + let basename = Filename.basename fn in + if Sys.file_exists dirname then + if basename = Filename.current_dir_name then + true + else + List.mem + basename + (Array.to_list (Sys.readdir dirname)) + else + false + + + let find_file ?(case_sensitive=true) paths exts = + + (* Cardinal product of two list *) + let ( * ) lst1 lst2 = + List.flatten + (List.map + (fun a -> + List.map + (fun b -> a, b) + lst2) + lst1) + in + + let rec combined_paths lst = + match lst with + | p1 :: p2 :: tl -> + let acc = + (List.map + (fun (a, b) -> Filename.concat a b) + (p1 * p2)) + in + combined_paths (acc :: tl) + | [e] -> + e + | [] -> + [] + in + + let alternatives = + List.map + (fun (p, e) -> + if String.length e > 0 && e.[0] <> '.' then + p ^ "." ^ e + else + p ^ e) + ((combined_paths paths) * exts) + in + List.find (fun file -> + (if case_sensitive then + file_exists_case file + else + Sys.file_exists file) + && not (Sys.is_directory file) + ) alternatives + + + let which ~ctxt prg = + let path_sep = + match Sys.os_type with + | "Win32" -> + ';' + | _ -> + ':' + in + let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in + let exec_ext = + match Sys.os_type with + | "Win32" -> + "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) + | _ -> + [""] + in + find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + + + (**/**) + let rec fix_dir dn = + (* Windows hack because Sys.file_exists "src\\" = false when + * Sys.file_exists "src" = true + *) + let ln = + String.length dn + in + if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then + fix_dir (String.sub dn 0 (ln - 1)) + else + dn + + + let q = Filename.quote + (**/**) + + + let cp ~ctxt ?(recurse=false) src tgt = + if recurse then + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt + "xcopy" [q src; q tgt; "/E"] + | _ -> + OASISExec.run ~ctxt + "cp" ["-r"; q src; q tgt] + else + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "copy" + | _ -> "cp") + [q src; q tgt] + + + let mkdir ~ctxt tgt = + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "md" + | _ -> "mkdir") + [q tgt] + + + let rec mkdir_parent ~ctxt f tgt = + let tgt = + fix_dir tgt + in + if Sys.file_exists tgt then + begin + if not (Sys.is_directory tgt) then + OASISUtils.failwithf + (f_ "Cannot create directory '%s', a file of the same name already \ + exists") + tgt + end + else + begin + mkdir_parent ~ctxt f (Filename.dirname tgt); + if not (Sys.file_exists tgt) then + begin + f tgt; + mkdir ~ctxt tgt + end + end + + + let rmdir ~ctxt tgt = + if Sys.readdir tgt = [||] then begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end else begin + OASISMessage.error ~ctxt + (f_ "Cannot remove directory '%s': not empty.") + tgt + end + + + let glob ~ctxt fn = + let basename = + Filename.basename fn + in + if String.length basename >= 2 && + basename.[0] = '*' && + basename.[1] = '.' then + begin + let ext_len = + (String.length basename) - 2 + in + let ext = + String.sub basename 2 ext_len + in + let dirname = + Filename.dirname fn + in + Array.fold_left + (fun acc fn -> + try + let fn_ext = + String.sub + fn + ((String.length fn) - ext_len) + ext_len + in + if fn_ext = ext then + (Filename.concat dirname fn) :: acc + else + acc + with Invalid_argument _ -> + acc) + [] + (Sys.readdir dirname) + end + else + begin + if file_exists_case fn then + [fn] + else + [] + end +end + + +# 3159 "setup.ml" +module BaseEnvLight = struct +(* # 22 "src/base/BaseEnvLight.ml" *) + + + module MapString = Map.Make(String) + + + type t = string MapString.t + + + let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" + + + let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = + let line = ref 1 in + let lexer st = + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + Genlex.make_lexer ["="] st_line + in + let rec read_file lxr mp = + match Stream.npeek 3 lxr with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; + read_file lxr (MapString.add nm value mp) + | [] -> mp + | _ -> + failwith + (Printf.sprintf "Malformed data file '%s' line %d" filename !line) + in + match stream with + | Some st -> read_file (lexer st) MapString.empty + | None -> + if Sys.file_exists filename then begin + let chn = open_in_bin filename in + let st = Stream.of_channel chn in + try + let mp = read_file (lexer st) MapString.empty in + close_in chn; mp + with e -> + close_in chn; raise e + end else if allow_empty then begin + MapString.empty + end else begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + let rec var_expand str env = + let buff = Buffer.create ((String.length str) * 2) in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = var_expand (MapString.find name env) env + let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst +end + + +# 3239 "setup.ml" +module BaseContext = struct +(* # 22 "src/base/BaseContext.ml" *) + + (* TODO: get rid of this module. *) + open OASISContext + + + let args () = fst (fspecs ()) + + + let default = default + +end + +module BaseMessage = struct +(* # 22 "src/base/BaseMessage.ml" *) + + + (** Message to user, overrid for Base + @author Sylvain Le Gall + *) + open OASISMessage + open BaseContext + + + let debug fmt = debug ~ctxt:!default fmt + + + let info fmt = info ~ctxt:!default fmt + + + let warning fmt = warning ~ctxt:!default fmt + + + let error fmt = error ~ctxt:!default fmt + +end + +module BaseEnv = struct +(* # 22 "src/base/BaseEnv.ml" *) + + open OASISGettext + open OASISUtils + open OASISContext + open PropList + + + module MapString = BaseEnvLight.MapString + + + type origin_t = + | ODefault + | OGetEnv + | OFileLoad + | OCommandLine + + + type cli_handle_t = + | CLINone + | CLIAuto + | CLIWith + | CLIEnable + | CLIUser of (Arg.key * Arg.spec * Arg.doc) list + + + type definition_t = + { + hide: bool; + dump: bool; + cli: cli_handle_t; + arg_help: string option; + group: string option; + } + + + let schema = Schema.create "environment" + + + (* Environment data *) + let env = Data.create () + + + (* Environment data from file *) + let env_from_file = ref MapString.empty + + + (* Lexer for var *) + let var_lxr = Genlex.make_lexer [] + + + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + (* TODO: this is a quick hack to allow calling Test.Command + * without defining executable name really. I.e. if there is + * an exec Executable toto, then $(toto) should be replace + * by its real name. It is however useful to have this function + * for other variable that depend on the host and should be + * written better than that. + *) + let st = + var_lxr (Stream.of_string var) + in + match Stream.npeek 3 st with + | [Genlex.Ident "utoh"; Genlex.Ident nm] -> + OASISHostPath.of_unix (var_get nm) + | [Genlex.Ident "utoh"; Genlex.String s] -> + OASISHostPath.of_unix s + | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> + String.escaped (var_get nm) + | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> + String.escaped s + | [Genlex.Ident nm] -> + var_get nm + | _ -> + failwithf + (f_ "Unknown expression '%s' in variable expansion of %s.") + var + str + with + | Unknown_field (_, _) -> + failwithf + (f_ "No variable %s defined when trying to expand %S.") + var + str + | Stream.Error e -> + failwithf + (f_ "Syntax error when parsing '%s' when trying to \ + expand %S: %s") + var + str + e) + str; + Buffer.contents buff + + + and var_get name = + let vl = + try + Schema.get schema env name + with Unknown_field _ as e -> + begin + try + MapString.find name !env_from_file + with Not_found -> + raise e + end + in + var_expand vl + + + let var_choose ?printer ?name lst = + OASISExpr.choose + ?printer + ?name + var_get + lst + + + let var_protect vl = + let buff = + Buffer.create (String.length vl) + in + String.iter + (function + | '$' -> Buffer.add_string buff "\\$" + | c -> Buffer.add_char buff c) + vl; + Buffer.contents buff + + + let var_define + ?(hide=false) + ?(dump=true) + ?short_desc + ?(cli=CLINone) + ?arg_help + ?group + name (* TODO: type constraint on the fact that name must be a valid OCaml + id *) + dflt = + + let default = + [ + OFileLoad, (fun () -> MapString.find name !env_from_file); + ODefault, dflt; + OGetEnv, (fun () -> Sys.getenv name); + ] + in + + let extra = + { + hide = hide; + dump = dump; + cli = cli; + arg_help = arg_help; + group = group; + } + in + + (* Try to find a value that can be defined + *) + let var_get_low lst = + let errors, res = + List.fold_left + (fun (errors, res) (_, v) -> + if res = None then + begin + try + errors, Some (v ()) + with + | Not_found -> + errors, res + | Failure rsn -> + (rsn :: errors), res + | e -> + (Printexc.to_string e) :: errors, res + end + else + errors, res) + ([], None) + (List.sort + (fun (o1, _) (o2, _) -> + Pervasives.compare o2 o1) + lst) + in + match res, errors with + | Some v, _ -> + v + | None, [] -> + raise (Not_set (name, None)) + | None, lst -> + raise (Not_set (name, Some (String.concat (s_ ", ") lst))) + in + + let help = + match short_desc with + | Some fs -> Some fs + | None -> None + in + + let var_get_lst = + FieldRO.create + ~schema + ~name + ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) + ~print:var_get_low + ~default + ~update:(fun ?context:_ x old_x -> x @ old_x) + ?help + extra + in + + fun () -> + var_expand (var_get_low (var_get_lst env)) + + + let var_redefine + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt = + if Schema.mem schema name then + begin + (* TODO: look suspsicious, we want to memorize dflt not dflt () *) + Schema.set schema env ~context:ODefault name (dflt ()); + fun () -> var_get name + end + else + begin + var_define + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt + end + + + let var_ignore (_: unit -> string) = () + + + let print_hidden = + var_define + ~hide:true + ~dump:false + ~cli:CLIAuto + ~arg_help:"Print even non-printable variable. (debug)" + "print_hidden" + (fun () -> "false") + + + let var_all () = + List.rev + (Schema.fold + (fun acc nm def _ -> + if not def.hide || bool_of_string (print_hidden ()) then + nm :: acc + else + acc) + [] + schema) + + + let default_filename = in_srcdir "setup.data" + + + let load ~ctxt ?(allow_empty=false) ?(filename=default_filename) () = + let open OASISFileSystem in + env_from_file := + let repr_filename = ctxt.srcfs#string_of_filename filename in + if ctxt.srcfs#file_exists filename then begin + let buf = Buffer.create 13 in + defer_close + (ctxt.srcfs#open_in ~mode:binary_in filename) + (read_all buf); + defer_close + (ctxt.srcfs#open_in ~mode:binary_in filename) + (fun rdr -> + OASISMessage.info ~ctxt "Loading environment from %S." repr_filename; + BaseEnvLight.load ~allow_empty + ~filename:(repr_filename) + ~stream:(stream_of_reader rdr) + ()) + end else if allow_empty then begin + BaseEnvLight.MapString.empty + end else begin + failwith + (Printf.sprintf + (f_ "Unable to load environment, the file '%s' doesn't exist.") + repr_filename) + end + + + let unload () = + env_from_file := MapString.empty; + Data.clear env + + + let dump ~ctxt ?(filename=default_filename) () = + let open OASISFileSystem in + defer_close + (ctxt.OASISContext.srcfs#open_out ~mode:binary_out filename) + (fun wrtr -> + let buf = Buffer.create 63 in + let output nm value = + Buffer.add_string buf (Printf.sprintf "%s=%S\n" nm value) + in + let mp_todo = + (* Dump data from schema *) + Schema.fold + (fun mp_todo nm def _ -> + if def.dump then begin + try + output nm (Schema.get schema env nm) + with Not_set _ -> + () + end; + MapString.remove nm mp_todo) + !env_from_file + schema + in + (* Dump data defined outside of schema *) + MapString.iter output mp_todo; + wrtr#output buf) + + let print () = + let printable_vars = + Schema.fold + (fun acc nm def short_descr_opt -> + if not def.hide || bool_of_string (print_hidden ()) then + begin + try + let value = Schema.get schema env nm in + let txt = + match short_descr_opt with + | Some s -> s () + | None -> nm + in + (txt, value) :: acc + with Not_set _ -> + acc + end + else + acc) + [] + schema + in + let max_length = + List.fold_left max 0 + (List.rev_map String.length + (List.rev_map fst printable_vars)) + in + let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in + Printf.printf "\nConfiguration:\n"; + List.iter + (fun (name, value) -> + Printf.printf "%s: %s" name (dot_pad name); + if value = "" then + Printf.printf "\n" + else + Printf.printf " %s\n" value) + (List.rev printable_vars); + Printf.printf "\n%!" + + + let args () = + let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in + [ + "--override", + Arg.Tuple + ( + let rvr = ref "" + in + let rvl = ref "" + in + [ + Arg.Set_string rvr; + Arg.Set_string rvl; + Arg.Unit + (fun () -> + Schema.set + schema + env + ~context:OCommandLine + !rvr + !rvl) + ] + ), + "var+val Override any configuration variable."; + + ] + @ + List.flatten + (Schema.fold + (fun acc name def short_descr_opt -> + let var_set s = + Schema.set + schema + env + ~context:OCommandLine + name + s + in + + let arg_name = + OASISUtils.varname_of_string ~hyphen:'-' name + in + + let hlp = + match short_descr_opt with + | Some txt -> txt () + | None -> "" + in + + let arg_hlp = + match def.arg_help with + | Some s -> s + | None -> "str" + in + + let default_value = + try + Printf.sprintf + (f_ " [%s]") + (Schema.get + schema + env + name) + with Not_set _ -> + "" + in + + let args = + match def.cli with + | CLINone -> + [] + | CLIAuto -> + [ + arg_concat "--" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIWith -> + [ + arg_concat "--with-" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIEnable -> + let dflt = + if default_value = " [true]" then + s_ " [default: enabled]" + else + s_ " [default: disabled]" + in + [ + arg_concat "--enable-" arg_name, + Arg.Unit (fun () -> var_set "true"), + Printf.sprintf (f_ " %s%s") hlp dflt; + + arg_concat "--disable-" arg_name, + Arg.Unit (fun () -> var_set "false"), + Printf.sprintf (f_ " %s%s") hlp dflt + ] + | CLIUser lst -> + lst + in + args :: acc) + [] + schema) +end + +module BaseArgExt = struct +(* # 22 "src/base/BaseArgExt.ml" *) + + + open OASISUtils + open OASISGettext + + + let parse argv args = + (* Simulate command line for Arg *) + let current = + ref 0 + in + + try + Arg.parse_argv + ~current:current + (Array.concat [[|"none"|]; argv]) + (Arg.align args) + (failwithf (f_ "Don't know what to do with arguments: '%s'")) + (s_ "configure options:") + with + | Arg.Help txt -> + print_endline txt; + exit 0 + | Arg.Bad txt -> + prerr_endline txt; + exit 1 +end + +module BaseCheck = struct +(* # 22 "src/base/BaseCheck.ml" *) + + + open BaseEnv + open BaseMessage + open OASISUtils + open OASISGettext + + + let prog_best prg prg_lst = + var_redefine + prg + (fun () -> + let alternate = + List.fold_left + (fun res e -> + match res with + | Some _ -> + res + | None -> + try + Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) + with Not_found -> + None) + None + prg_lst + in + match alternate with + | Some prg -> prg + | None -> raise Not_found) + + + let prog prg = + prog_best prg [prg] + + + let prog_opt prg = + prog_best prg [prg^".opt"; prg] + + + let ocamlfind = + prog "ocamlfind" + + + let version + var_prefix + cmp + fversion + () = + (* Really compare version provided *) + let var = + var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) + in + var_redefine + ~hide:true + var + (fun () -> + let version_str = + match fversion () with + | "[Distributed with OCaml]" -> + begin + try + (var_get "ocaml_version") + with Not_found -> + warning + (f_ "Variable ocaml_version not defined, fallback \ + to default"); + Sys.ocaml_version + end + | res -> + res + in + let version = + OASISVersion.version_of_string version_str + in + if OASISVersion.comparator_apply version cmp then + version_str + else + failwithf + (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") + var_prefix + (OASISVersion.string_of_comparator cmp) + version_str) + () + + + let package_version pkg = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%v"; pkg] + + + let package ?version_comparator pkg () = + let var = + OASISUtils.varname_concat + "pkg_" + (OASISUtils.varname_of_string pkg) + in + let findlib_dir pkg = + let dir = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%d"; pkg] + in + if Sys.file_exists dir && Sys.is_directory dir then + dir + else + failwithf + (f_ "When looking for findlib package %s, \ + directory %s return doesn't exist") + pkg dir + in + let vl = + var_redefine + var + (fun () -> findlib_dir pkg) + () + in + ( + match version_comparator with + | Some ver_cmp -> + ignore + (version + var + ver_cmp + (fun _ -> package_version pkg) + ()) + | None -> + () + ); + vl +end + +module BaseOCamlcConfig = struct +(* # 22 "src/base/BaseOCamlcConfig.ml" *) + + + open BaseEnv + open OASISUtils + open OASISGettext + + + module SMap = Map.Make(String) + + + let ocamlc = + BaseCheck.prog_opt "ocamlc" + + + let ocamlc_config_map = + (* Map name to value for ocamlc -config output + (name ^": "^value) + *) + let rec split_field mp lst = + match lst with + | line :: tl -> + let mp = + try + let pos_semicolon = + String.index line ':' + in + if pos_semicolon > 1 then + ( + let name = + String.sub line 0 pos_semicolon + in + let linelen = + String.length line + in + let value = + if linelen > pos_semicolon + 2 then + String.sub + line + (pos_semicolon + 2) + (linelen - pos_semicolon - 2) + else + "" + in + SMap.add name value mp + ) + else + ( + mp + ) + with Not_found -> + ( + mp + ) + in + split_field mp tl + | [] -> + mp + in + + let cache = + lazy + (var_protect + (Marshal.to_string + (split_field + SMap.empty + (OASISExec.run_read_output + ~ctxt:!BaseContext.default + (ocamlc ()) ["-config"])) + [])) + in + var_redefine + "ocamlc_config_map" + ~hide:true + ~dump:false + (fun () -> + (* TODO: update if ocamlc change !!! *) + Lazy.force cache) + + + let var_define nm = + (* Extract data from ocamlc -config *) + let avlbl_config_get () = + Marshal.from_string + (ocamlc_config_map ()) + 0 + in + let chop_version_suffix s = + try + String.sub s 0 (String.index s '+') + with _ -> + s + in + + let nm_config, value_config = + match nm with + | "ocaml_version" -> + "version", chop_version_suffix + | _ -> nm, (fun x -> x) + in + var_redefine + nm + (fun () -> + try + let map = + avlbl_config_get () + in + let value = + SMap.find nm_config map + in + value_config value + with Not_found -> + failwithf + (f_ "Cannot find field '%s' in '%s -config' output") + nm + (ocamlc ())) + +end + +module BaseStandardVar = struct +(* # 22 "src/base/BaseStandardVar.ml" *) + + + open OASISGettext + open OASISTypes + open BaseCheck + open BaseEnv + + + let ocamlfind = BaseCheck.ocamlfind + let ocamlc = BaseOCamlcConfig.ocamlc + let ocamlopt = prog_opt "ocamlopt" + let ocamlbuild = prog "ocamlbuild" + + + (**/**) + let rpkg = + ref None + + + let pkg_get () = + match !rpkg with + | Some pkg -> pkg + | None -> failwith (s_ "OASIS Package is not set") + + + let var_cond = ref [] + + + let var_define_cond ~since_version f dflt = + let holder = ref (fun () -> dflt) in + let since_version = + OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) + in + var_cond := + (fun ver -> + if OASISVersion.comparator_apply ver since_version then + holder := f ()) :: !var_cond; + fun () -> !holder () + + + (**/**) + + + let pkg_name = + var_define + ~short_desc:(fun () -> s_ "Package name") + "pkg_name" + (fun () -> (pkg_get ()).name) + + + let pkg_version = + var_define + ~short_desc:(fun () -> s_ "Package version") + "pkg_version" + (fun () -> + (OASISVersion.string_of_version (pkg_get ()).version)) + + + let c = BaseOCamlcConfig.var_define + + + let os_type = c "os_type" + let system = c "system" + let architecture = c "architecture" + let ccomp_type = c "ccomp_type" + let ocaml_version = c "ocaml_version" + + + (* TODO: Check standard variable presence at runtime *) + + + let standard_library_default = c "standard_library_default" + let standard_library = c "standard_library" + let standard_runtime = c "standard_runtime" + let bytecomp_c_compiler = c "bytecomp_c_compiler" + let native_c_compiler = c "native_c_compiler" + let model = c "model" + let ext_obj = c "ext_obj" + let ext_asm = c "ext_asm" + let ext_lib = c "ext_lib" + let ext_dll = c "ext_dll" + let default_executable_name = c "default_executable_name" + let systhread_supported = c "systhread_supported" + + + let flexlink = + BaseCheck.prog "flexlink" + + + let flexdll_version = + var_define + ~short_desc:(fun () -> "FlexDLL version (Win32)") + "flexdll_version" + (fun () -> + let lst = + OASISExec.run_read_output ~ctxt:!BaseContext.default + (flexlink ()) ["-help"] + in + match lst with + | line :: _ -> + Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) + | [] -> + raise Not_found) + + + (**/**) + let p name hlp dflt = + var_define + ~short_desc:hlp + ~cli:CLIAuto + ~arg_help:"dir" + name + dflt + + + let (/) a b = + if os_type () = Sys.os_type then + Filename.concat a b + else if os_type () = "Unix" || os_type () = "Cygwin" then + OASISUnixPath.concat a b + else + OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") + (os_type ()) + (**/**) + + + let prefix = + p "prefix" + (fun () -> s_ "Install architecture-independent files dir") + (fun () -> + match os_type () with + | "Win32" -> + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) + | _ -> + "/usr/local") + + + let exec_prefix = + p "exec_prefix" + (fun () -> s_ "Install architecture-dependent files in dir") + (fun () -> "$prefix") + + + let bindir = + p "bindir" + (fun () -> s_ "User executables") + (fun () -> "$exec_prefix"/"bin") + + + let sbindir = + p "sbindir" + (fun () -> s_ "System admin executables") + (fun () -> "$exec_prefix"/"sbin") + + + let libexecdir = + p "libexecdir" + (fun () -> s_ "Program executables") + (fun () -> "$exec_prefix"/"libexec") + + + let sysconfdir = + p "sysconfdir" + (fun () -> s_ "Read-only single-machine data") + (fun () -> "$prefix"/"etc") + + + let sharedstatedir = + p "sharedstatedir" + (fun () -> s_ "Modifiable architecture-independent data") + (fun () -> "$prefix"/"com") + + + let localstatedir = + p "localstatedir" + (fun () -> s_ "Modifiable single-machine data") + (fun () -> "$prefix"/"var") + + + let libdir = + p "libdir" + (fun () -> s_ "Object code libraries") + (fun () -> "$exec_prefix"/"lib") + + + let datarootdir = + p "datarootdir" + (fun () -> s_ "Read-only arch-independent data root") + (fun () -> "$prefix"/"share") + + + let datadir = + p "datadir" + (fun () -> s_ "Read-only architecture-independent data") + (fun () -> "$datarootdir") + + + let infodir = + p "infodir" + (fun () -> s_ "Info documentation") + (fun () -> "$datarootdir"/"info") + + + let localedir = + p "localedir" + (fun () -> s_ "Locale-dependent data") + (fun () -> "$datarootdir"/"locale") + + + let mandir = + p "mandir" + (fun () -> s_ "Man documentation") + (fun () -> "$datarootdir"/"man") + + + let docdir = + p "docdir" + (fun () -> s_ "Documentation root") + (fun () -> "$datarootdir"/"doc"/"$pkg_name") + + + let htmldir = + p "htmldir" + (fun () -> s_ "HTML documentation") + (fun () -> "$docdir") + + + let dvidir = + p "dvidir" + (fun () -> s_ "DVI documentation") + (fun () -> "$docdir") + + + let pdfdir = + p "pdfdir" + (fun () -> s_ "PDF documentation") + (fun () -> "$docdir") + + + let psdir = + p "psdir" + (fun () -> s_ "PS documentation") + (fun () -> "$docdir") + + + let destdir = + p "destdir" + (fun () -> s_ "Prepend a path when installing package") + (fun () -> + raise + (PropList.Not_set + ("destdir", + Some (s_ "undefined by construct")))) + + + let findlib_version = + var_define + "findlib_version" + (fun () -> + BaseCheck.package_version "findlib") + + + let is_native = + var_define + "is_native" + (fun () -> + try + let _s: string = + ocamlopt () + in + "true" + with PropList.Not_set _ -> + let _s: string = + ocamlc () + in + "false") + + + let ext_program = + var_define + "suffix_program" + (fun () -> + match os_type () with + | "Win32" | "Cygwin" -> ".exe" + | _ -> "") + + + let rm = + var_define + ~short_desc:(fun () -> s_ "Remove a file.") + "rm" + (fun () -> + match os_type () with + | "Win32" -> "del" + | _ -> "rm -f") + + + let rmdir = + var_define + ~short_desc:(fun () -> s_ "Remove a directory.") + "rmdir" + (fun () -> + match os_type () with + | "Win32" -> "rd" + | _ -> "rm -rf") + + + let debug = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") + ~cli:CLIEnable + "debug" + (fun () -> "true") + + + let profile = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") + ~cli:CLIEnable + "profile" + (fun () -> "false") + + + let tests = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> + s_ "Compile tests executable and library and run them") + ~cli:CLIEnable + "tests" + (fun () -> "false")) + "true" + + + let docs = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> s_ "Create documentations") + ~cli:CLIEnable + "docs" + (fun () -> "true")) + "true" + + + let native_dynlink = + var_define + ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") + ~cli:CLINone + "native_dynlink" + (fun () -> + let res = + let ocaml_lt_312 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (ocaml_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "3.12.0")) + in + let flexdll_lt_030 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (flexdll_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "0.30")) + in + let has_native_dynlink = + let ocamlfind = ocamlfind () in + try + let fn = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ocamlfind + ["query"; "-predicates"; "native"; "dynlink"; + "-format"; "%d/%a"] + in + Sys.file_exists fn + with _ -> + false + in + if not has_native_dynlink then + false + else if ocaml_lt_312 () then + false + else if (os_type () = "Win32" || os_type () = "Cygwin") + && flexdll_lt_030 () then + begin + BaseMessage.warning + (f_ ".cmxs generation disabled because FlexDLL needs to be \ + at least 0.30. Please upgrade FlexDLL from %s to 0.30.") + (flexdll_version ()); + false + end + else + true + in + string_of_bool res) + + + let init pkg = + rpkg := Some pkg; + List.iter (fun f -> f pkg.oasis_version) !var_cond + +end + +module BaseFileAB = struct +(* # 22 "src/base/BaseFileAB.ml" *) + + + open BaseEnv + open OASISGettext + open BaseMessage + open OASISContext + + + let to_filename fn = + if not (Filename.check_suffix fn ".ab") then + warning (f_ "File '%s' doesn't have '.ab' extension") fn; + OASISFileSystem.of_unix_filename (Filename.chop_extension fn) + + + let replace ~ctxt fn_lst = + let open OASISFileSystem in + let ibuf, obuf = Buffer.create 13, Buffer.create 13 in + List.iter + (fun fn -> + Buffer.clear ibuf; Buffer.clear obuf; + defer_close + (ctxt.srcfs#open_in (of_unix_filename fn)) + (read_all ibuf); + Buffer.add_string obuf (var_expand (Buffer.contents ibuf)); + defer_close + (ctxt.srcfs#open_out (to_filename fn)) + (fun wrtr -> wrtr#output obuf)) + fn_lst +end + +module BaseLog = struct +(* # 22 "src/base/BaseLog.ml" *) + + + open OASISUtils + open OASISContext + open OASISGettext + open OASISFileSystem + + + let default_filename = in_srcdir "setup.log" + + + let load ~ctxt () = + let module SetTupleString = + Set.Make + (struct + type t = string * string + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with + | 0 -> String.compare s12 s22 + | n -> n + end) + in + if ctxt.srcfs#file_exists default_filename then begin + defer_close + (ctxt.srcfs#open_in default_filename) + (fun rdr -> + let line = ref 1 in + let lxr = Genlex.make_lexer [] (stream_of_reader rdr) in + let rec read_aux (st, lst) = + match Stream.npeek 2 lxr with + | [Genlex.String e; Genlex.String d] -> + let t = e, d in + Stream.junk lxr; Stream.junk lxr; + if SetTupleString.mem t st then + read_aux (st, lst) + else + read_aux (SetTupleString.add t st, t :: lst) + | [] -> List.rev lst + | _ -> + failwithf + (f_ "Malformed log file '%s' at line %d") + (ctxt.srcfs#string_of_filename default_filename) + !line + in + read_aux (SetTupleString.empty, [])) + end else begin + [] + end + + + let register ~ctxt event data = + defer_close + (ctxt.srcfs#open_out + ~mode:[Open_append; Open_creat; Open_text] + ~perm:0o644 + default_filename) + (fun wrtr -> + let buf = Buffer.create 13 in + Printf.bprintf buf "%S %S\n" event data; + wrtr#output buf) + + + let unregister ~ctxt event data = + let lst = load ~ctxt () in + let buf = Buffer.create 13 in + List.iter + (fun (e, d) -> + if e <> event || d <> data then + Printf.bprintf buf "%S %S\n" e d) + lst; + if Buffer.length buf > 0 then + defer_close + (ctxt.srcfs#open_out default_filename) + (fun wrtr -> wrtr#output buf) + else + ctxt.srcfs#remove default_filename + + + let filter ~ctxt events = + let st_events = SetString.of_list events in + List.filter + (fun (e, _) -> SetString.mem e st_events) + (load ~ctxt ()) + + + let exists ~ctxt event data = + List.exists + (fun v -> (event, data) = v) + (load ~ctxt ()) +end + +module BaseBuilt = struct +(* # 22 "src/base/BaseBuilt.ml" *) + + + open OASISTypes + open OASISGettext + open BaseStandardVar + open BaseMessage + + + type t = + | BExec (* Executable *) + | BExecLib (* Library coming with executable *) + | BLib (* Library *) + | BObj (* Library *) + | BDoc (* Document *) + + + let to_log_event_file t nm = + "built_"^ + (match t with + | BExec -> "exec" + | BExecLib -> "exec_lib" + | BLib -> "lib" + | BObj -> "obj" + | BDoc -> "doc")^ + "_"^nm + + + let to_log_event_done t nm = + "is_"^(to_log_event_file t nm) + + + let register ~ctxt t nm lst = + BaseLog.register ~ctxt (to_log_event_done t nm) "true"; + List.iter + (fun alt -> + let registered = + List.fold_left + (fun registered fn -> + if OASISFileUtil.file_exists_case fn then begin + BaseLog.register ~ctxt + (to_log_event_file t nm) + (if Filename.is_relative fn then + Filename.concat (Sys.getcwd ()) fn + else + fn); + true + end else begin + registered + end) + false + alt + in + if not registered then + warning + (f_ "Cannot find an existing alternative files among: %s") + (String.concat (s_ ", ") alt)) + lst + + + let unregister ~ctxt t nm = + List.iter + (fun (e, d) -> BaseLog.unregister ~ctxt e d) + (BaseLog.filter ~ctxt [to_log_event_file t nm; to_log_event_done t nm]) + + + let fold ~ctxt t nm f acc = + List.fold_left + (fun acc (_, fn) -> + if OASISFileUtil.file_exists_case fn then begin + f acc fn + end else begin + warning + (f_ "File '%s' has been marked as built \ + for %s but doesn't exist") + fn + (Printf.sprintf + (match t with + | BExec | BExecLib -> (f_ "executable %s") + | BLib -> (f_ "library %s") + | BObj -> (f_ "object %s") + | BDoc -> (f_ "documentation %s")) + nm); + acc + end) + acc + (BaseLog.filter ~ctxt [to_log_event_file t nm]) + + + let is_built ~ctxt t nm = + List.fold_left + (fun _ (_, d) -> try bool_of_string d with _ -> false) + false + (BaseLog.filter ~ctxt [to_log_event_done t nm]) + + + let of_executable ffn (cs, bs, exec) = + let unix_exec_is, unix_dll_opt = + OASISExecutable.unix_exec_is + (cs, bs, exec) + (fun () -> + bool_of_string + (is_native ())) + ext_dll + ext_program + in + let evs = + (BExec, cs.cs_name, [[ffn unix_exec_is]]) + :: + (match unix_dll_opt with + | Some fn -> + [BExecLib, cs.cs_name, [[ffn fn]]] + | None -> + []) + in + evs, + unix_exec_is, + unix_dll_opt + + + let of_library ffn (cs, bs, lib) = + let unix_lst = + OASISLibrary.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + ~has_native_dynlink:(bool_of_string (native_dynlink ())) + ~ext_lib:(ext_lib ()) + ~ext_dll:(ext_dll ()) + (cs, bs, lib) + in + let evs = + [BLib, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + + + let of_object ffn (cs, bs, obj) = + let unix_lst = + OASISObject.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + (cs, bs, obj) + in + let evs = + [BObj, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + +end + +module BaseCustom = struct +(* # 22 "src/base/BaseCustom.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + + let run cmd args extra_args = + OASISExec.run ~ctxt:!BaseContext.default ~quote:false + (var_expand cmd) + (List.map + var_expand + (args @ (Array.to_list extra_args))) + + + let hook ?(failsafe=false) cstm f e = + let optional_command lst = + let printer = + function + | Some (cmd, args) -> String.concat " " (cmd :: args) + | None -> s_ "No command" + in + match + var_choose + ~name:(s_ "Pre/Post Command") + ~printer + lst with + | Some (cmd, args) -> + begin + try + run cmd args [||] + with e when failsafe -> + warning + (f_ "Command '%s' fail with error: %s") + (String.concat " " (cmd :: args)) + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + end + | None -> + () + in + let res = + optional_command cstm.pre_command; + f e + in + optional_command cstm.post_command; + res +end + +module BaseDynVar = struct +(* # 22 "src/base/BaseDynVar.ml" *) + + + open OASISTypes + open OASISGettext + open BaseEnv + open BaseBuilt + + + let init ~ctxt pkg = + (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) + (* TODO: provide compile option for library libary_byte_args_VARNAME... *) + List.iter + (function + | Executable (cs, bs, _) -> + if var_choose bs.bs_build then + var_ignore + (var_redefine + (* We don't save this variable *) + ~dump:false + ~short_desc:(fun () -> + Printf.sprintf + (f_ "Filename of executable '%s'") + cs.cs_name) + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + let fn_opt = + fold ~ctxt BExec cs.cs_name (fun _ fn -> Some fn) None + in + match fn_opt with + | Some fn -> fn + | None -> + raise + (PropList.Not_set + (cs.cs_name, + Some (Printf.sprintf + (f_ "Executable '%s' not yet built.") + cs.cs_name))))) + + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + ()) + pkg.sections +end + +module BaseTest = struct +(* # 22 "src/base/BaseTest.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + + let test ~ctxt lst pkg extra_args = + + let one_test (failure, n) (test_plugin, cs, test) = + if var_choose + ~name:(Printf.sprintf + (f_ "test %s run") + cs.cs_name) + ~printer:string_of_bool + test.test_run then + begin + let () = info (f_ "Running test '%s'") cs.cs_name in + let back_cwd = + match test.test_working_directory with + | Some dir -> + let cwd = Sys.getcwd () in + let chdir d = + info (f_ "Changing directory to '%s'") d; + Sys.chdir d + in + chdir dir; + fun () -> chdir cwd + + | None -> + fun () -> () + in + try + let failure_percent = + BaseCustom.hook + test.test_custom + (test_plugin ~ctxt pkg (cs, test)) + extra_args + in + back_cwd (); + (failure_percent +. failure, n + 1) + with e -> + begin + back_cwd (); + raise e + end + end + else + begin + info (f_ "Skipping test '%s'") cs.cs_name; + (failure, n) + end + in + let failed, n = List.fold_left one_test (0.0, 0) lst in + let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in + let msg = + Printf.sprintf + (f_ "Tests had a %.2f%% failure rate") + (100. *. failure_percent) + in + if failure_percent > 0.0 then + failwith msg + else + info "%s" msg; + + (* Possible explanation why the tests where not run. *) + if OASISFeatures.package_test OASISFeatures.flag_tests pkg && + not (bool_of_string (BaseStandardVar.tests ())) && + lst <> [] then + BaseMessage.warning + "Tests are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-tests'" +end + +module BaseDoc = struct +(* # 22 "src/base/BaseDoc.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + + let doc ~ctxt lst pkg extra_args = + + let one_doc (doc_plugin, cs, doc) = + if var_choose + ~name:(Printf.sprintf + (f_ "documentation %s build") + cs.cs_name) + ~printer:string_of_bool + doc.doc_build then + begin + info (f_ "Building documentation '%s'") cs.cs_name; + BaseCustom.hook + doc.doc_custom + (doc_plugin ~ctxt pkg (cs, doc)) + extra_args + end + in + List.iter one_doc lst; + + if OASISFeatures.package_test OASISFeatures.flag_docs pkg && + not (bool_of_string (BaseStandardVar.docs ())) && + lst <> [] then + BaseMessage.warning + "Docs are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-docs'" +end + +module BaseSetup = struct +(* # 22 "src/base/BaseSetup.ml" *) + + open OASISContext + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + open OASISUtils + + + type std_args_fun = + ctxt:OASISContext.t -> package -> string array -> unit + + + type ('a, 'b) section_args_fun = + name * + (ctxt:OASISContext.t -> + package -> + (common_section * 'a) -> + string array -> + 'b) + + + type t = + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + oasis_fn: string option; + oasis_version: string; + oasis_digest: Digest.t option; + oasis_exec: string option; + oasis_setup_args: string list; + setup_update: bool; + } + + + (* Associate a plugin function with data from package *) + let join_plugin_sections filter_map lst = + List.rev + (List.fold_left + (fun acc sct -> + match filter_map sct with + | Some e -> + e :: acc + | None -> + acc) + [] + lst) + + + (* Search for plugin data associated with a section name *) + let lookup_plugin_section plugin action nm lst = + try + List.assoc nm lst + with Not_found -> + failwithf + (f_ "Cannot find plugin %s matching section %s for %s action") + plugin + nm + action + + + let configure ~ctxt t args = + (* Run configure *) + BaseCustom.hook + t.package.conf_custom + (fun () -> + (* Reload if preconf has changed it *) + begin + try + unload (); + load ~ctxt (); + with _ -> + () + end; + + (* Run plugin's configure *) + t.configure ~ctxt t.package args; + + (* Dump to allow postconf to change it *) + dump ~ctxt ()) + (); + + (* Reload environment *) + unload (); + load ~ctxt (); + + (* Save environment *) + print (); + + (* Replace data in file *) + BaseFileAB.replace ~ctxt t.package.files_ab + + + let build ~ctxt t args = + BaseCustom.hook + t.package.build_custom + (t.build ~ctxt t.package) + args + + + let doc ~ctxt t args = + BaseDoc.doc + ~ctxt + (join_plugin_sections + (function + | Doc (cs, e) -> + Some + (lookup_plugin_section + "documentation" + (s_ "build") + cs.cs_name + t.doc, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + + let test ~ctxt t args = + BaseTest.test + ~ctxt + (join_plugin_sections + (function + | Test (cs, e) -> + Some + (lookup_plugin_section + "test" + (s_ "run") + cs.cs_name + t.test, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + + let all ~ctxt t args = + let rno_doc = ref false in + let rno_test = ref false in + let arg_rest = ref [] in + Arg.parse_argv + ~current:(ref 0) + (Array.of_list + ((Sys.executable_name^" all") :: + (Array.to_list args))) + [ + "-no-doc", + Arg.Set rno_doc, + s_ "Don't run doc target"; + + "-no-test", + Arg.Set rno_test, + s_ "Don't run test target"; + + "--", + Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), + s_ "All arguments for configure."; + ] + (failwithf (f_ "Don't know what to do with '%s'")) + ""; + + info "Running configure step"; + configure ~ctxt t (Array.of_list (List.rev !arg_rest)); + + info "Running build step"; + build ~ctxt t [||]; + + (* Load setup.log dynamic variables *) + BaseDynVar.init ~ctxt t.package; + + if not !rno_doc then begin + info "Running doc step"; + doc ~ctxt t [||] + end else begin + info "Skipping doc step" + end; + if not !rno_test then begin + info "Running test step"; + test ~ctxt t [||] + end else begin + info "Skipping test step" + end + + + let install ~ctxt t args = + BaseCustom.hook t.package.install_custom (t.install ~ctxt t.package) args + + + let uninstall ~ctxt t args = + BaseCustom.hook t.package.uninstall_custom (t.uninstall ~ctxt t.package) args + + + let reinstall ~ctxt t args = + uninstall ~ctxt t args; + install ~ctxt t args + + + let clean, distclean = + let failsafe f a = + try + f a + with e -> + warning + (f_ "Action fail with error: %s") + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + in + + let generic_clean ~ctxt t cstm mains docs tests args = + BaseCustom.hook + ~failsafe:true + cstm + (fun () -> + (* Clean section *) + List.iter + (function + | Test (cs, test) -> + let f = + try + List.assoc cs.cs_name tests + with Not_found -> + fun ~ctxt:_ _ _ _ -> () + in + failsafe (f ~ctxt t.package (cs, test)) args + | Doc (cs, doc) -> + let f = + try + List.assoc cs.cs_name docs + with Not_found -> + fun ~ctxt:_ _ _ _ -> () + in + failsafe (f ~ctxt t.package (cs, doc)) args + | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) + t.package.sections; + (* Clean whole package *) + List.iter (fun f -> failsafe (f ~ctxt t.package) args) mains) + () + in + + let clean ~ctxt t args = + generic_clean + ~ctxt + t + t.package.clean_custom + t.clean + t.clean_doc + t.clean_test + args + in + + let distclean ~ctxt t args = + (* Call clean *) + clean ~ctxt t args; + + (* Call distclean code *) + generic_clean + ~ctxt + t + t.package.distclean_custom + t.distclean + t.distclean_doc + t.distclean_test + args; + + (* Remove generated source files. *) + List.iter + (fun fn -> + if ctxt.srcfs#file_exists fn then begin + info (f_ "Remove '%s'") (ctxt.srcfs#string_of_filename fn); + ctxt.srcfs#remove fn + end) + ([BaseEnv.default_filename; BaseLog.default_filename] + @ (List.rev_map BaseFileAB.to_filename t.package.files_ab)) + in + + clean, distclean + + + let version ~ctxt:_ (t: t) _ = print_endline t.oasis_version + + + let update_setup_ml, no_update_setup_ml_cli = + let b = ref true in + b, + ("-no-update-setup-ml", + Arg.Clear b, + s_ " Don't try to update setup.ml, even if _oasis has changed.") + + (* TODO: srcfs *) + let default_oasis_fn = "_oasis" + + + let update_setup_ml t = + let oasis_fn = + match t.oasis_fn with + | Some fn -> fn + | None -> default_oasis_fn + in + let oasis_exec = + match t.oasis_exec with + | Some fn -> fn + | None -> "oasis" + in + let ocaml = + Sys.executable_name + in + let setup_ml, args = + match Array.to_list Sys.argv with + | setup_ml :: args -> + setup_ml, args + | [] -> + failwith + (s_ "Expecting non-empty command line arguments.") + in + let ocaml, setup_ml = + if Sys.executable_name = Sys.argv.(0) then + (* We are not running in standard mode, probably the script + * is precompiled. + *) + "ocaml", "setup.ml" + else + ocaml, setup_ml + in + let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in + let do_update () = + let oasis_exec_version = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | 1 -> + failwithf + (f_ "Executable '%s' is probably an old version \ + of oasis (< 0.3.0), please update to version \ + v%s.") + oasis_exec t.oasis_version + | 127 -> + failwithf + (f_ "Cannot find executable '%s', please install \ + oasis v%s.") + oasis_exec t.oasis_version + | n -> + failwithf + (f_ "Command '%s version' exited with code %d.") + oasis_exec n) + oasis_exec ["version"] + in + if OASISVersion.comparator_apply + (OASISVersion.version_of_string oasis_exec_version) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string t.oasis_version)) then + begin + (* We have a version >= for the executable oasis, proceed with + * update. + *) + (* TODO: delegate this check to 'oasis setup'. *) + if Sys.os_type = "Win32" then + failwithf + (f_ "It is not possible to update the running script \ + setup.ml on Windows. Please update setup.ml by \ + running '%s'.") + (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) + else + begin + OASISExec.run + ~ctxt:!BaseContext.default + ~f_exit_code: + (fun n -> + if n <> 0 then + failwithf + (f_ "Unable to update setup.ml using '%s', \ + please fix the problem and retry.") + oasis_exec) + oasis_exec ("setup" :: t.oasis_setup_args); + OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) + end + end + else + failwithf + (f_ "The version of '%s' (v%s) doesn't match the version of \ + oasis used to generate the %s file. Please install at \ + least oasis v%s.") + oasis_exec oasis_exec_version setup_ml t.oasis_version + in + + if !update_setup_ml then + begin + try + match t.oasis_digest with + | Some dgst -> + if Sys.file_exists oasis_fn && + dgst <> Digest.file default_oasis_fn then + begin + do_update (); + true + end + else + false + | None -> + false + with e -> + error + (f_ "Error when updating setup.ml. If you want to avoid this error, \ + you can bypass the update of %s by running '%s %s %s %s'") + setup_ml ocaml setup_ml no_update_setup_ml_cli + (String.concat " " args); + raise e + end + else + false + + + let setup t = + let catch_exn = ref true in + let act_ref = + ref (fun ~ctxt:_ _ -> + failwithf + (f_ "No action defined, run '%s %s -help'") + Sys.executable_name + Sys.argv.(0)) + + in + let extra_args_ref = ref [] in + let allow_empty_env_ref = ref false in + let arg_handle ?(allow_empty_env=false) act = + Arg.Tuple + [ + Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); + Arg.Unit + (fun () -> + allow_empty_env_ref := allow_empty_env; + act_ref := act); + ] + in + try + let () = + Arg.parse + (Arg.align + ([ + "-configure", + arg_handle ~allow_empty_env:true configure, + s_ "[options*] Configure the whole build process."; + + "-build", + arg_handle build, + s_ "[options*] Build executables and libraries."; + + "-doc", + arg_handle doc, + s_ "[options*] Build documents."; + + "-test", + arg_handle test, + s_ "[options*] Run tests."; + + "-all", + arg_handle ~allow_empty_env:true all, + s_ "[options*] Run configure, build, doc and test targets."; + + "-install", + arg_handle install, + s_ "[options*] Install libraries, data, executables \ + and documents."; + + "-uninstall", + arg_handle uninstall, + s_ "[options*] Uninstall libraries, data, executables \ + and documents."; + + "-reinstall", + arg_handle reinstall, + s_ "[options*] Uninstall and install libraries, data, \ + executables and documents."; + + "-clean", + arg_handle ~allow_empty_env:true clean, + s_ "[options*] Clean files generated by a build."; + + "-distclean", + arg_handle ~allow_empty_env:true distclean, + s_ "[options*] Clean files generated by a build and configure."; + + "-version", + arg_handle ~allow_empty_env:true version, + s_ " Display version of OASIS used to generate this setup.ml."; + + "-no-catch-exn", + Arg.Clear catch_exn, + s_ " Don't catch exception, useful for debugging."; + ] + @ + (if t.setup_update then + [no_update_setup_ml_cli] + else + []) + @ (BaseContext.args ()))) + (failwithf (f_ "Don't know what to do with '%s'")) + (s_ "Setup and run build process current package\n") + in + + (* Instantiate the context. *) + let ctxt = !BaseContext.default in + + (* Build initial environment *) + load ~ctxt ~allow_empty:!allow_empty_env_ref (); + + (** Initialize flags *) + List.iter + (function + | Flag (cs, {flag_description = hlp; + flag_default = choices}) -> + begin + let apply ?short_desc () = + var_ignore + (var_define + ~cli:CLIEnable + ?short_desc + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + string_of_bool + (var_choose + ~name:(Printf.sprintf + (f_ "default value of flag %s") + cs.cs_name) + ~printer:string_of_bool + choices))) + in + match hlp with + | Some hlp -> apply ~short_desc:(fun () -> hlp) () + | None -> apply () + end + | _ -> + ()) + t.package.sections; + + BaseStandardVar.init t.package; + + BaseDynVar.init ~ctxt t.package; + + if not (t.setup_update && update_setup_ml t) then + !act_ref ~ctxt t (Array.of_list (List.rev !extra_args_ref)) + + with e when !catch_exn -> + error "%s" (Printexc.to_string e); + exit 1 + + +end + +module BaseCompat = struct +(* # 22 "src/base/BaseCompat.ml" *) + + (** Compatibility layer to provide a stable API inside setup.ml. + This layer allows OASIS to change in between minor versions + (e.g. 0.4.6 -> 0.4.7) but still provides a stable API inside setup.ml. This + enables to write functions that manipulate setup_t inside setup.ml. See + deps.ml for an example. + + The module opened by default will depend on the version of the _oasis. E.g. + if we have "OASISFormat: 0.3", the module Compat_0_3 will be opened and + the function Compat_0_3 will be called. If setup.ml is generated with the + -nocompat, no module will be opened. + + @author Sylvain Le Gall + *) + + module Compat_0_4 = + struct + let rctxt = ref !BaseContext.default + + module BaseSetup = + struct + module Original = BaseSetup + + open OASISTypes + + type std_args_fun = package -> string array -> unit + type ('a, 'b) section_args_fun = + name * (package -> (common_section * 'a) -> string array -> 'b) + type t = + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + oasis_fn: string option; + oasis_version: string; + oasis_digest: Digest.t option; + oasis_exec: string option; + oasis_setup_args: string list; + setup_update: bool; + } + + let setup t = + let mk_std_args_fun f = + fun ~ctxt pkg args -> rctxt := ctxt; f pkg args + in + let mk_section_args_fun l = + List.map + (fun (nm, f) -> + nm, + (fun ~ctxt pkg sct args -> + rctxt := ctxt; + f pkg sct args)) + l + in + let t' = + { + Original. + configure = mk_std_args_fun t.configure; + build = mk_std_args_fun t.build; + doc = mk_section_args_fun t.doc; + test = mk_section_args_fun t.test; + install = mk_std_args_fun t.install; + uninstall = mk_std_args_fun t.uninstall; + clean = List.map mk_std_args_fun t.clean; + clean_doc = mk_section_args_fun t.clean_doc; + clean_test = mk_section_args_fun t.clean_test; + distclean = List.map mk_std_args_fun t.distclean; + distclean_doc = mk_section_args_fun t.distclean_doc; + distclean_test = mk_section_args_fun t.distclean_test; + + package = t.package; + oasis_fn = t.oasis_fn; + oasis_version = t.oasis_version; + oasis_digest = t.oasis_digest; + oasis_exec = t.oasis_exec; + oasis_setup_args = t.oasis_setup_args; + setup_update = t.setup_update; + } + in + Original.setup t' + + end + + let adapt_setup_t setup_t = + let module O = BaseSetup.Original in + let mk_std_args_fun f = fun pkg args -> f ~ctxt:!rctxt pkg args in + let mk_section_args_fun l = + List.map + (fun (nm, f) -> nm, (fun pkg sct args -> f ~ctxt:!rctxt pkg sct args)) + l + in + { + BaseSetup. + configure = mk_std_args_fun setup_t.O.configure; + build = mk_std_args_fun setup_t.O.build; + doc = mk_section_args_fun setup_t.O.doc; + test = mk_section_args_fun setup_t.O.test; + install = mk_std_args_fun setup_t.O.install; + uninstall = mk_std_args_fun setup_t.O.uninstall; + clean = List.map mk_std_args_fun setup_t.O.clean; + clean_doc = mk_section_args_fun setup_t.O.clean_doc; + clean_test = mk_section_args_fun setup_t.O.clean_test; + distclean = List.map mk_std_args_fun setup_t.O.distclean; + distclean_doc = mk_section_args_fun setup_t.O.distclean_doc; + distclean_test = mk_section_args_fun setup_t.O.distclean_test; + + package = setup_t.O.package; + oasis_fn = setup_t.O.oasis_fn; + oasis_version = setup_t.O.oasis_version; + oasis_digest = setup_t.O.oasis_digest; + oasis_exec = setup_t.O.oasis_exec; + oasis_setup_args = setup_t.O.oasis_setup_args; + setup_update = setup_t.O.setup_update; + } + end + + + module Compat_0_3 = + struct + include Compat_0_4 + end + +end + + +# 5662 "setup.ml" +module InternalConfigurePlugin = struct +(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) + + + (** Configure using internal scheme + @author Sylvain Le Gall + *) + + + open BaseEnv + open OASISTypes + open OASISUtils + open OASISGettext + open BaseMessage + + + (** Configure build using provided series of check to be done + and then output corresponding file. + *) + let configure ~ctxt:_ pkg argv = + let var_ignore_eval var = let _s: string = var () in () in + let errors = ref SetString.empty in + let buff = Buffer.create 13 in + + let add_errors fmt = + Printf.kbprintf + (fun b -> + errors := SetString.add (Buffer.contents b) !errors; + Buffer.clear b) + buff + fmt + in + + let warn_exception e = + warning "%s" (Printexc.to_string e) + in + + (* Check tools *) + let check_tools lst = + List.iter + (function + | ExternalTool tool -> + begin + try + var_ignore_eval (BaseCheck.prog tool) + with e -> + warn_exception e; + add_errors (f_ "Cannot find external tool '%s'") tool + end + | InternalExecutable nm1 -> + (* Check that matching tool is built *) + List.iter + (function + | Executable ({cs_name = nm2; _}, + {bs_build = build; _}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal executable \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + lst + in + + let build_checks sct bs = + if var_choose bs.bs_build then + begin + if bs.bs_compiled_object = Native then + begin + try + var_ignore_eval BaseStandardVar.ocamlopt + with e -> + warn_exception e; + add_errors + (f_ "Section %s requires native compilation") + (OASISSection.string_of_section sct) + end; + + (* Check tools *) + check_tools bs.bs_build_tools; + + (* Check depends *) + List.iter + (function + | FindlibPackage (findlib_pkg, version_comparator) -> + begin + try + var_ignore_eval + (BaseCheck.package ?version_comparator findlib_pkg) + with e -> + warn_exception e; + match version_comparator with + | None -> + add_errors + (f_ "Cannot find findlib package %s") + findlib_pkg + | Some ver_cmp -> + add_errors + (f_ "Cannot find findlib package %s (%s)") + findlib_pkg + (OASISVersion.string_of_comparator ver_cmp) + end + | InternalLibrary nm1 -> + (* Check that matching library is built *) + List.iter + (function + | Library ({cs_name = nm2; _}, + {bs_build = build; _}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal library \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + bs.bs_build_depends + end + in + + (* Parse command line *) + BaseArgExt.parse argv (BaseEnv.args ()); + + (* OCaml version *) + begin + match pkg.ocaml_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "ocaml" + ver_cmp + BaseStandardVar.ocaml_version) + with e -> + warn_exception e; + add_errors + (f_ "OCaml version %s doesn't match version constraint %s") + (BaseStandardVar.ocaml_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* Findlib version *) + begin + match pkg.findlib_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "findlib" + ver_cmp + BaseStandardVar.findlib_version) + with e -> + warn_exception e; + add_errors + (f_ "Findlib version %s doesn't match version constraint %s") + (BaseStandardVar.findlib_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + (* Make sure the findlib version is fine for the OCaml compiler. *) + begin + let ocaml_ge4 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.ocaml_version ())) + (OASISVersion.version_of_string "4.0.0") >= 0 in + if ocaml_ge4 then + let findlib_lt132 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) + (OASISVersion.version_of_string "1.3.2") < 0 in + if findlib_lt132 then + add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" + end; + + (* FlexDLL *) + if BaseStandardVar.os_type () = "Win32" || + BaseStandardVar.os_type () = "Cygwin" then + begin + try + var_ignore_eval BaseStandardVar.flexlink + with e -> + warn_exception e; + add_errors (f_ "Cannot find 'flexlink'") + end; + + (* Check build depends *) + List.iter + (function + | Executable (_, bs, _) + | Library (_, bs, _) as sct -> + build_checks sct bs + | Doc (_, doc) -> + if var_choose doc.doc_build then + check_tools doc.doc_build_tools + | Test (_, test) -> + if var_choose test.test_run then + check_tools test.test_tools + | _ -> + ()) + pkg.sections; + + (* Check if we need native dynlink (presence of libraries that compile to + native) + *) + begin + let has_cmxa = + List.exists + (function + | Library (_, bs, _) -> + var_choose bs.bs_build && + (bs.bs_compiled_object = Native || + (bs.bs_compiled_object = Best && + bool_of_string (BaseStandardVar.is_native ()))) + | _ -> + false) + pkg.sections + in + if has_cmxa then + var_ignore_eval BaseStandardVar.native_dynlink + end; + + (* Check errors *) + if SetString.empty != !errors then + begin + List.iter + (fun e -> error "%s" e) + (SetString.elements !errors); + failwithf + (fn_ + "%d configuration error" + "%d configuration errors" + (SetString.cardinal !errors)) + (SetString.cardinal !errors) + end + + +end + +module InternalInstallPlugin = struct +(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) + + + (** Install using internal scheme + @author Sylvain Le Gall + *) + + + (* TODO: rewrite this module with OASISFileSystem. *) + + open BaseEnv + open BaseStandardVar + open BaseMessage + open OASISTypes + open OASISFindlib + open OASISGettext + open OASISUtils + + + let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) + let lib_hook = ref (fun (cs, bs, dn, lib) -> cs, bs, dn, lib, []) + let obj_hook = ref (fun (cs, bs, dn, obj) -> cs, bs, dn, obj, []) + let doc_hook = ref (fun (cs, doc) -> cs, doc) + + let install_file_ev = "install-file" + let install_dir_ev = "install-dir" + let install_findlib_ev = "install-findlib" + + + (* TODO: this can be more generic and used elsewhere. *) + let win32_max_command_line_length = 8000 + + + let split_install_command ocamlfind findlib_name meta files = + if Sys.os_type = "Win32" then + (* Arguments for the first command: *) + let first_args = ["install"; findlib_name; meta] in + (* Arguments for remaining commands: *) + let other_args = ["install"; findlib_name; "-add"] in + (* Extract as much files as possible from [files], [len] is + the current command line length: *) + let rec get_files len acc files = + match files with + | [] -> + (List.rev acc, []) + | file :: rest -> + let len = len + 1 + String.length file in + if len > win32_max_command_line_length then + (List.rev acc, files) + else + get_files len (file :: acc) rest + in + (* Split the command into several commands. *) + let rec split args files = + match files with + | [] -> + [] + | _ -> + (* Length of "ocamlfind install [META|-add]" *) + let len = + List.fold_left + (fun len arg -> + len + 1 (* for the space *) + String.length arg) + (String.length ocamlfind) + args + in + match get_files len [] files with + | ([], _) -> + failwith (s_ "Command line too long.") + | (firsts, others) -> + let cmd = args @ firsts in + (* Use -add for remaining commands: *) + let () = + let findlib_ge_132 = + OASISVersion.comparator_apply + (OASISVersion.version_of_string + (BaseStandardVar.findlib_version ())) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string "1.3.2")) + in + if not findlib_ge_132 then + failwithf + (f_ "Installing the library %s require to use the \ + flag '-add' of ocamlfind because the command \ + line is too long. This flag is only available \ + for findlib 1.3.2. Please upgrade findlib from \ + %s to 1.3.2") + findlib_name (BaseStandardVar.findlib_version ()) + in + let cmds = split other_args others in + cmd :: cmds + in + (* The first command does not use -add: *) + split first_args files + else + ["install" :: findlib_name :: meta :: files] + + + let install = + + let in_destdir fn = + try + (* Practically speaking destdir is prepended at the beginning of the + target filename + *) + (destdir ())^fn + with PropList.Not_set _ -> + fn + in + + let install_file ~ctxt ?(prepend_destdir=true) ?tgt_fn src_file envdir = + let tgt_dir = + if prepend_destdir then in_destdir (envdir ()) else envdir () + in + let tgt_file = + Filename.concat + tgt_dir + (match tgt_fn with + | Some fn -> + fn + | None -> + Filename.basename src_file) + in + (* Create target directory if needed *) + OASISFileUtil.mkdir_parent + ~ctxt + (fun dn -> + info (f_ "Creating directory '%s'") dn; + BaseLog.register ~ctxt install_dir_ev dn) + (Filename.dirname tgt_file); + + (* Really install files *) + info (f_ "Copying file '%s' to '%s'") src_file tgt_file; + OASISFileUtil.cp ~ctxt src_file tgt_file; + BaseLog.register ~ctxt install_file_ev tgt_file + in + + (* Install the files for a library. *) + + let install_lib_files ~ctxt findlib_name files = + let findlib_dir = + let dn = + let findlib_destdir = + OASISExec.run_read_one_line ~ctxt (ocamlfind ()) + ["printconf" ; "destdir"] + in + Filename.concat findlib_destdir findlib_name + in + fun () -> dn + in + let () = + if not (OASISFileUtil.file_exists_case (findlib_dir ())) then + failwithf + (f_ "Directory '%s' doesn't exist for findlib library %s") + (findlib_dir ()) findlib_name + in + let f dir file = + let basename = Filename.basename file in + let tgt_fn = Filename.concat dir basename in + (* Destdir is already include in printconf. *) + install_file ~ctxt ~prepend_destdir:false ~tgt_fn file findlib_dir + in + List.iter (fun (dir, files) -> List.iter (f dir) files) files ; + in + + (* Install data into defined directory *) + let install_data ~ctxt srcdir lst tgtdir = + let tgtdir = + OASISHostPath.of_unix (var_expand tgtdir) + in + List.iter + (fun (src, tgt_opt) -> + let real_srcs = + OASISFileUtil.glob + ~ctxt:!BaseContext.default + (Filename.concat srcdir src) + in + if real_srcs = [] then + failwithf + (f_ "Wildcard '%s' doesn't match any files") + src; + List.iter + (fun fn -> + install_file ~ctxt + fn + (fun () -> + match tgt_opt with + | Some s -> + OASISHostPath.of_unix (var_expand s) + | None -> + tgtdir)) + real_srcs) + lst + in + + let make_fnames modul sufx = + List.fold_right + begin fun sufx accu -> + (OASISString.capitalize_ascii modul ^ sufx) :: + (OASISString.uncapitalize_ascii modul ^ sufx) :: + accu + end + sufx + [] + in + + (** Install all libraries *) + let install_libs ~ctxt pkg = + + let find_first_existing_files_in_path bs lst = + let path = OASISHostPath.of_unix bs.bs_path in + List.find + OASISFileUtil.file_exists_case + (List.map (Filename.concat path) lst) + in + + let files_of_modules new_files typ cs bs modules = + List.fold_left + (fun acc modul -> + begin + try + (* Add uncompiled header from the source tree *) + [find_first_existing_files_in_path + bs (make_fnames modul [".mli"; ".ml"])] + with Not_found -> + warning + (f_ "Cannot find source header for module %s \ + in %s %s") + typ modul cs.cs_name; + [] + end + @ + List.fold_left + (fun acc fn -> + try + find_first_existing_files_in_path bs [fn] :: acc + with Not_found -> + acc) + acc (make_fnames modul [".annot";".cmti";".cmt"])) + new_files + modules + in + + let files_of_build_section (f_data, new_files) typ cs bs = + let extra_files = + List.map + (fun fn -> + try + find_first_existing_files_in_path bs [fn] + with Not_found -> + failwithf + (f_ "Cannot find extra findlib file %S in %s %s ") + fn + typ + cs.cs_name) + bs.bs_findlib_extra_files + in + let f_data () = + (* Install data associated with the library *) + install_data + ~ctxt + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + f_data, new_files @ extra_files + in + + let files_of_library (f_data, acc) data_lib = + let cs, bs, lib, dn, lib_extra = !lib_hook data_lib in + if var_choose bs.bs_install && + BaseBuilt.is_built ~ctxt BaseBuilt.BLib cs.cs_name then begin + (* Start with lib_extra *) + let new_files = lib_extra in + let new_files = + files_of_modules new_files "library" cs bs lib.lib_modules + in + let f_data, new_files = + files_of_build_section (f_data, new_files) "library" cs bs + in + let new_files = + (* Get generated files *) + BaseBuilt.fold + ~ctxt + BaseBuilt.BLib + cs.cs_name + (fun acc fn -> fn :: acc) + new_files + in + let acc = (dn, new_files) :: acc in + + let f_data () = + (* Install data associated with the library *) + install_data + ~ctxt + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end else begin + (f_data, acc) + end + and files_of_object (f_data, acc) data_obj = + let cs, bs, obj, dn, obj_extra = !obj_hook data_obj in + if var_choose bs.bs_install && + BaseBuilt.is_built ~ctxt BaseBuilt.BObj cs.cs_name then begin + (* Start with obj_extra *) + let new_files = obj_extra in + let new_files = + files_of_modules new_files "object" cs bs obj.obj_modules + in + let f_data, new_files = + files_of_build_section (f_data, new_files) "object" cs bs + in + + let new_files = + (* Get generated files *) + BaseBuilt.fold + ~ctxt + BaseBuilt.BObj + cs.cs_name + (fun acc fn -> fn :: acc) + new_files + in + let acc = (dn, new_files) :: acc in + + let f_data () = + (* Install data associated with the object *) + install_data + ~ctxt + bs.bs_path + bs.bs_data_files + (Filename.concat (datarootdir ()) pkg.name); + f_data () + in + (f_data, acc) + end else begin + (f_data, acc) + end + in + + (* Install one group of library *) + let install_group_lib grp = + (* Iterate through all group nodes *) + let rec install_group_lib_aux data_and_files grp = + let data_and_files, children = + match grp with + | Container (_, children) -> + data_and_files, children + | Package (_, cs, bs, `Library lib, dn, children) -> + files_of_library data_and_files (cs, bs, lib, dn), children + | Package (_, cs, bs, `Object obj, dn, children) -> + files_of_object data_and_files (cs, bs, obj, dn), children + in + List.fold_left + install_group_lib_aux + data_and_files + children + in + + (* Findlib name of the root library *) + let findlib_name = findlib_of_group grp in + + (* Determine root library *) + let root_lib = root_of_group grp in + + (* All files to install for this library *) + let f_data, files = install_group_lib_aux (ignore, []) grp in + + (* Really install, if there is something to install *) + if files = [] then begin + warning + (f_ "Nothing to install for findlib library '%s'") findlib_name + end else begin + let meta = + (* Search META file *) + let _, bs, _ = root_lib in + let res = Filename.concat bs.bs_path "META" in + if not (OASISFileUtil.file_exists_case res) then + failwithf + (f_ "Cannot find file '%s' for findlib library %s") + res + findlib_name; + res + in + let files = + (* Make filename shorter to avoid hitting command max line length + * too early, esp. on Windows. + *) + (* TODO: move to OASISHostPath as make_relative. *) + let remove_prefix p n = + let plen = String.length p in + let nlen = String.length n in + if plen <= nlen && String.sub n 0 plen = p then begin + let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in + let cutpoint = + plen + + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) + in + String.sub n cutpoint (nlen - cutpoint) + end else begin + n + end + in + List.map + (fun (dir, fn) -> + (dir, List.map (remove_prefix (Sys.getcwd ())) fn)) + files + in + let ocamlfind = ocamlfind () in + let nodir_files, dir_files = + List.fold_left + (fun (nodir, dir) (dn, lst) -> + match dn with + | Some dn -> nodir, (dn, lst) :: dir + | None -> lst @ nodir, dir) + ([], []) + (List.rev files) + in + info (f_ "Installing findlib library '%s'") findlib_name; + List.iter + (OASISExec.run ~ctxt ocamlfind) + (split_install_command ocamlfind findlib_name meta nodir_files); + install_lib_files ~ctxt findlib_name dir_files; + BaseLog.register ~ctxt install_findlib_ev findlib_name + end; + + (* Install data files *) + f_data (); + in + + let group_libs, _, _ = findlib_mapping pkg in + + (* We install libraries in groups *) + List.iter install_group_lib group_libs + in + + let install_execs ~ctxt pkg = + let install_exec data_exec = + let cs, bs, _ = !exec_hook data_exec in + if var_choose bs.bs_install && + BaseBuilt.is_built ~ctxt BaseBuilt.BExec cs.cs_name then begin + let exec_libdir () = Filename.concat (libdir ()) pkg.name in + BaseBuilt.fold + ~ctxt + BaseBuilt.BExec + cs.cs_name + (fun () fn -> + install_file ~ctxt + ~tgt_fn:(cs.cs_name ^ ext_program ()) + fn + bindir) + (); + BaseBuilt.fold + ~ctxt + BaseBuilt.BExecLib + cs.cs_name + (fun () fn -> install_file ~ctxt fn exec_libdir) + (); + install_data ~ctxt + bs.bs_path + bs.bs_data_files + (Filename.concat (datarootdir ()) pkg.name) + end + in + List.iter + (function + | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) + | _ -> ()) + pkg.sections + in + + let install_docs ~ctxt pkg = + let install_doc data = + let cs, doc = !doc_hook data in + if var_choose doc.doc_install && + BaseBuilt.is_built ~ctxt BaseBuilt.BDoc cs.cs_name then begin + let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in + BaseBuilt.fold + ~ctxt + BaseBuilt.BDoc + cs.cs_name + (fun () fn -> install_file ~ctxt fn (fun () -> tgt_dir)) + (); + install_data ~ctxt + Filename.current_dir_name + doc.doc_data_files + doc.doc_install_dir + end + in + List.iter + (function + | Doc (cs, doc) -> install_doc (cs, doc) + | _ -> ()) + pkg.sections + in + fun ~ctxt pkg _ -> + install_libs ~ctxt pkg; + install_execs ~ctxt pkg; + install_docs ~ctxt pkg + + + (* Uninstall already installed data *) + let uninstall ~ctxt _ _ = + let uninstall_aux (ev, data) = + if ev = install_file_ev then begin + if OASISFileUtil.file_exists_case data then begin + info (f_ "Removing file '%s'") data; + Sys.remove data + end else begin + warning (f_ "File '%s' doesn't exist anymore") data + end + end else if ev = install_dir_ev then begin + if Sys.file_exists data && Sys.is_directory data then begin + if Sys.readdir data = [||] then begin + info (f_ "Removing directory '%s'") data; + OASISFileUtil.rmdir ~ctxt data + end else begin + warning + (f_ "Directory '%s' is not empty (%s)") + data + (String.concat ", " (Array.to_list (Sys.readdir data))) + end + end else begin + warning (f_ "Directory '%s' doesn't exist anymore") data + end + end else if ev = install_findlib_ev then begin + info (f_ "Removing findlib library '%s'") data; + OASISExec.run ~ctxt (ocamlfind ()) ["remove"; data] + end else begin + failwithf (f_ "Unknown log event '%s'") ev; + end; + BaseLog.unregister ~ctxt ev data + in + (* We process event in reverse order *) + List.iter uninstall_aux + (List.rev + (BaseLog.filter ~ctxt [install_file_ev; install_dir_ev])); + List.iter uninstall_aux + (List.rev (BaseLog.filter ~ctxt [install_findlib_ev])) + +end + + +# 6465 "setup.ml" +module OCamlbuildCommon = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) + + + (** Functions common to OCamlbuild build and doc plugin + *) + + + open OASISGettext + open BaseEnv + open BaseStandardVar + open OASISTypes + + + type extra_args = string list + + + let ocamlbuild_clean_ev = "ocamlbuild-clean" + + + let ocamlbuildflags = + var_define + ~short_desc:(fun () -> "OCamlbuild additional flags") + "ocamlbuildflags" + (fun () -> "") + + + (** Fix special arguments depending on environment *) + let fix_args args extra_argv = + List.flatten + [ + if (os_type ()) = "Win32" then + [ + "-classic-display"; + "-no-log"; + "-no-links"; + ] + else + []; + + if OASISVersion.comparator_apply + (OASISVersion.version_of_string (ocaml_version ())) + (OASISVersion.VLesser (OASISVersion.version_of_string "3.11.1")) then + [ + "-install-lib-dir"; + (Filename.concat (standard_library ()) "ocamlbuild") + ] + else + []; + + if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then + [ + "-byte-plugin" + ] + else + []; + args; + + if bool_of_string (debug ()) then + ["-tag"; "debug"] + else + []; + + if bool_of_string (tests ()) then + ["-tag"; "tests"] + else + []; + + if bool_of_string (profile ()) then + ["-tag"; "profile"] + else + []; + + OASISString.nsplit (ocamlbuildflags ()) ' '; + + Array.to_list extra_argv; + ] + + + (** Run 'ocamlbuild -clean' if not already done *) + let run_clean ~ctxt extra_argv = + let extra_cli = + String.concat " " (Array.to_list extra_argv) + in + (* Run if never called with these args *) + if not (BaseLog.exists ~ctxt ocamlbuild_clean_ev extra_cli) then + begin + OASISExec.run ~ctxt (ocamlbuild ()) (fix_args ["-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 ~ctxt args extra_argv = + (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html + *) + OASISExec.run ~ctxt (ocamlbuild ()) (fix_args args extra_argv); + (* Remove any clean event, we must run it again *) + List.iter + (fun (e, d) -> BaseLog.unregister ~ctxt e d) + (BaseLog.filter ~ctxt [ocamlbuild_clean_ev]) + + + (** Determine real build directory *) + let build_dir extra_argv = + let rec search_args dir = + function + | "-build-dir" :: dir :: tl -> + search_args dir tl + | _ :: tl -> + search_args dir tl + | [] -> + dir + in + search_args "_build" (fix_args [] extra_argv) + + +end + +module OCamlbuildPlugin = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) + + + (** Build using ocamlbuild + @author Sylvain Le Gall + *) + + + open OASISTypes + open OASISGettext + open OASISUtils + open OASISString + open BaseEnv + open OCamlbuildCommon + open BaseStandardVar + + + let cond_targets_hook = ref (fun lst -> lst) + + + let build ~ctxt extra_args pkg argv = + (* Return the filename in build directory *) + let in_build_dir fn = + Filename.concat + (build_dir argv) + fn + in + + (* Return the unix filename in host build directory *) + let in_build_dir_of_unix fn = + in_build_dir (OASISHostPath.of_unix fn) + in + + let cond_targets = + List.fold_left + (fun acc -> + function + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_library + in_build_dir_of_unix + (cs, bs, lib) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ~what:".cma" fn + || ends_with ~what:".cmxs" fn + || ends_with ~what:".cmxa" fn + || ends_with ~what:(ext_lib ()) fn + || ends_with ~what:(ext_dll ()) fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for library %s") + cs.cs_name + end + + | Object (cs, bs, obj) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_object + in_build_dir_of_unix + (cs, bs, obj) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ~what:".cmo" fn + || ends_with ~what:".cmx" fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for object %s") + cs.cs_name + end + + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, _, _ = + BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) + in + + let target ext = + let unix_tgt = + (OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.chop_extension + exec.exec_main_is))^ext + in + let evs = + (* Fix evs, we want to use the unix_tgt, without copying *) + List.map + (function + | BaseBuilt.BExec, nm, _ when nm = cs.cs_name -> + BaseBuilt.BExec, nm, + [[in_build_dir_of_unix unix_tgt]] + | ev -> + ev) + evs + in + evs, [unix_tgt] + in + + (* Add executable *) + let acc = + match bs.bs_compiled_object with + | Native -> + (target ".native") :: acc + | Best when bool_of_string (is_native ()) -> + (target ".native") :: acc + | Byte + | Best -> + (target ".byte") :: acc + in + acc + end + + | Library _ | Object _ | Executable _ | Test _ + | SrcRepo _ | Flag _ | Doc _ -> + acc) + [] + (* Keep the pkg.sections ordered *) + (List.rev pkg.sections); + in + + (* Check and register built files *) + let check_and_register (bt, bnm, lst) = + List.iter + (fun fns -> + if not (List.exists OASISFileUtil.file_exists_case fns) then + failwithf + (fn_ + "Expected built file %s doesn't exist." + "None of expected built files %s exists." + (List.length fns)) + (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) + lst; + (BaseBuilt.register ~ctxt bt bnm lst) + in + + (* Run the hook *) + let cond_targets = !cond_targets_hook cond_targets in + + (* Run a list of target... *) + run_ocamlbuild + ~ctxt + (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 ~ctxt pkg extra_args = + run_clean ~ctxt extra_args; + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + +end + +module OCamlbuildDocPlugin = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) + + + (* Create documentation using ocamlbuild .odocl files + @author Sylvain Le Gall + *) + + + open OASISTypes + open OASISGettext + open OCamlbuildCommon + + + type run_t = + { + extra_args: string list; + run_path: unix_filename; + } + + + let doc_build ~ctxt run _ (cs, _) argv = + let index_html = + OASISUnixPath.make + [ + run.run_path; + cs.cs_name^".docdir"; + "index.html"; + ] + in + let tgt_dir = + OASISHostPath.make + [ + build_dir argv; + OASISHostPath.of_unix run.run_path; + cs.cs_name^".docdir"; + ] + in + run_ocamlbuild ~ctxt (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 ~ctxt _ _ (cs, _) argv = + run_clean ~ctxt argv; + BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name + + +end + + +# 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; + } + + + let run = BaseCustom.run + + + let main ~ctxt:_ t _ extra_args = + let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in + run cmd args extra_args + + + let clean ~ctxt:_ t _ extra_args = + match var_choose t.cmd_clean with + | Some (cmd, args) -> run cmd args extra_args + | _ -> () + + + let distclean ~ctxt:_ t _ extra_args = + match var_choose t.cmd_distclean with + | Some (cmd, args) -> run cmd args extra_args + | _ -> () + + + module Build = + struct + let main ~ctxt t pkg extra_args = + main ~ctxt t pkg extra_args; + List.iter + (fun sct -> + let evs = + match sct with + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, _ = + BaseBuilt.of_library + OASISHostPath.of_unix + (cs, bs, lib) + in + evs + end + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, _, _ = + BaseBuilt.of_executable + OASISHostPath.of_unix + (cs, bs, exec) + in + evs + end + | _ -> + [] + in + List.iter + (fun (bt, bnm, lst) -> BaseBuilt.register ~ctxt bt bnm lst) + evs) + pkg.sections + + let clean ~ctxt t pkg extra_args = + clean ~ctxt t pkg extra_args; + (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild + * considering moving this to BaseSetup? + *) + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + let distclean ~ctxt t pkg extra_args = distclean ~ctxt t pkg extra_args + end + + + module Test = + struct + let main ~ctxt t pkg (cs, _) extra_args = + try + main ~ctxt t pkg extra_args; + 0.0 + with Failure s -> + BaseMessage.warning + (f_ "Test '%s' fails: %s") + cs.cs_name + s; + 1.0 + + let clean ~ctxt t pkg _ extra_args = clean ~ctxt t pkg extra_args + + let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args + end + + + module Doc = + struct + let main ~ctxt t pkg (cs, _) extra_args = + main ~ctxt t pkg extra_args; + BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [] + + let clean ~ctxt t pkg (cs, _) extra_args = + clean ~ctxt t pkg extra_args; + BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name + + let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args + end + + +end + + +# 6969 "setup.ml" +open OASISTypes;; + +let setup_t = + { + BaseSetup.configure = InternalConfigurePlugin.configure; + build = OCamlbuildPlugin.build []; + test = + [ + ("bench-find", + CustomPlugin.Test.main + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$BenchFind", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }); + ("main", + CustomPlugin.Test.main + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + doc = + [ + ("api-fileutils", + OCamlbuildDocPlugin.doc_build + {OCamlbuildDocPlugin.extra_args = []; run_path = "src/"}) + ]; + install = InternalInstallPlugin.install; + uninstall = InternalInstallPlugin.uninstall; + clean = [OCamlbuildPlugin.clean]; + clean_test = + [ + ("bench-find", + CustomPlugin.Test.clean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$BenchFind", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }); + ("main", + CustomPlugin.Test.clean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + clean_doc = + [ + ("api-fileutils", + OCamlbuildDocPlugin.doc_clean + {OCamlbuildDocPlugin.extra_args = []; run_path = "src/"}) + ]; + distclean = []; + distclean_test = + [ + ("bench-find", + CustomPlugin.Test.distclean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$BenchFind", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }); + ("main", + CustomPlugin.Test.distclean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + distclean_doc = []; + package = + { + oasis_version = "0.4"; + ocaml_version = None; + version = "0.5.2"; + license = + OASISLicense.DEP5License + (OASISLicense.DEP5Unit + { + OASISLicense.license = "LGPL"; + excption = Some "OCaml linking"; + version = OASISLicense.Version "2.1" + }); + findlib_version = None; + alpha_features = []; + beta_features = []; + name = "ocaml-fileutils"; + license_file = Some "LICENSE"; + copyrights = ["(C) 2003-2014 Sylvain Le Gall"]; + maintainers = []; + authors = ["Sylvain Le Gall"]; + homepage = None; + bugreports = None; + synopsis = + "Functions to manipulate real file (POSIX like) and filename."; + description = None; + tags = []; + categories = []; + files_ab = []; + sections = + [ + Library + ({ + cs_name = "fileutils"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "src/"; + bs_compiled_object = Best; + bs_build_depends = [FindlibPackage ("unix", None)]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_interface_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${capitalize_file module}.mli" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${uncapitalize_file module}.mli" + } + ]; + bs_implementation_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${capitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${uncapitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${capitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${uncapitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${capitalize_file module}.mly" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${uncapitalize_file module}.mly" + } + ]; + bs_c_sources = []; + bs_data_files = []; + bs_findlib_extra_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = ["FileUtil"; "FilePath"]; + lib_pack = false; + lib_internal_modules = + [ + "CommonPath"; + "ExtensionPath"; + "FilePath_type"; + "FileStringExt"; + "MacOSPath"; + "UnixPath"; + "Win32Path"; + "FileUtilMode"; + "FileUtilTypes"; + "FileUtilPermission"; + "FileUtilSize"; + "FileUtilMisc"; + "FileUtilSTAT"; + "FileUtilUMASK"; + "FileUtilLS"; + "FileUtilCHMOD"; + "FileUtilTEST"; + "FileUtilPWD"; + "FileUtilREADLINK"; + "FileUtilWHICH"; + "FileUtilMKDIR"; + "FileUtilTOUCH"; + "FileUtilFIND"; + "FileUtilRM"; + "FileUtilCP"; + "FileUtilMV"; + "FileUtilCMP"; + "FileUtilDU" + ]; + lib_findlib_parent = None; + lib_findlib_name = None; + lib_findlib_directory = None; + lib_findlib_containers = [] + }); + Library + ({ + cs_name = "fileutils-str"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "src/"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "fileutils"; + FindlibPackage ("str", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_interface_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${capitalize_file module}.mli" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${uncapitalize_file module}.mli" + } + ]; + bs_implementation_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${capitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${uncapitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${capitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${uncapitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${capitalize_file module}.mly" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${uncapitalize_file module}.mly" + } + ]; + bs_c_sources = []; + bs_data_files = []; + bs_findlib_extra_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = ["FileUtilStr"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "fileutils"; + lib_findlib_name = Some "str"; + lib_findlib_directory = None; + lib_findlib_containers = [] + }); + Doc + ({ + cs_name = "api-fileutils"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + doc_type = (`Doc, "ocamlbuild", Some "0.4"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$htmldir/api"; + doc_title = "API reference for fileutils"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = []; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] + }); + SrcRepo + ({ + cs_name = "head"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + src_repo_type = Darcs; + src_repo_location = + "http://forge.ocamlcore.org/anonscm/darcs/ocaml-fileutils/ocaml-fileutils"; + src_repo_browser = + Some + "http://darcs.ocamlcore.org/cgi-bin/darcsweb.cgi?r=ocaml-fileutils/ocaml-fileutils;a=summary"; + src_repo_module = None; + src_repo_branch = None; + src_repo_tag = None; + src_repo_subdir = None + }); + Executable + ({ + cs_name = "BenchFind"; + 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 = Best; + bs_build_depends = [InternalLibrary "fileutils"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_interface_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${capitalize_file module}.mli" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${uncapitalize_file module}.mli" + } + ]; + bs_implementation_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${capitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${uncapitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${capitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${uncapitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${capitalize_file module}.mly" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${uncapitalize_file module}.mly" + } + ]; + bs_c_sources = []; + bs_data_files = []; + bs_findlib_extra_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "BenchFind.ml"}); + Executable + ({ + cs_name = "test"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "tests", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "test"; + bs_compiled_object = Byte; + bs_build_depends = + [ + InternalLibrary "fileutils"; + InternalLibrary "fileutils-str"; + FindlibPackage + ("oUnit", + Some (OASISVersion.VGreaterEqual "2.0.0")) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_interface_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${capitalize_file module}.mli" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mli" + ]; + origin = "${uncapitalize_file module}.mli" + } + ]; + bs_implementation_patterns = + [ + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${capitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".ml" + ]; + origin = "${uncapitalize_file module}.ml" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${capitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mll" + ]; + origin = "${uncapitalize_file module}.mll" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("capitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${capitalize_file module}.mly" + }; + { + OASISSourcePatterns.Templater.atoms = + [ + OASISSourcePatterns.Templater.Text ""; + OASISSourcePatterns.Templater.Expr + (OASISSourcePatterns.Templater.Call + ("uncapitalize_file", + OASISSourcePatterns.Templater.Ident + "module")); + OASISSourcePatterns.Templater.Text ".mly" + ]; + origin = "${uncapitalize_file module}.mly" + } + ]; + bs_c_sources = []; + bs_data_files = []; + bs_findlib_extra_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "test.ml"}); + Test + ({ + cs_name = "bench-find"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + test_type = (`Test, "custom", Some "0.4"); + test_command = + [(OASISExpr.EBool true, ("$BenchFind", []))]; + test_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + test_working_directory = None; + test_run = + [ + (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); + (OASISExpr.EFlag "tests", false) + ]; + test_tools = [ExternalTool "ocamlbuild"] + }); + Test + ({ + cs_name = "main"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + test_type = (`Test, "custom", Some "0.4"); + test_command = [(OASISExpr.EBool true, ("$test", []))]; + test_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + test_working_directory = Some "test"; + test_run = + [ + (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); + (OASISExpr.EFlag "tests", true) + ]; + test_tools = [ExternalTool "ocamlbuild"] + }) + ]; + 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, "DevFiles", Some "0.4"); + (`Extra, "StdFiles", Some "0.4"); + (`Extra, "META", Some "0.4") + ]; + schema_data = PropList.Data.create (); + plugin_data = [] + }; + oasis_fn = None; + oasis_version = "0.4.11~HEAD"; + oasis_digest = None; + oasis_exec = None; + oasis_setup_args = []; + setup_update = false + };; + +let setup () = BaseSetup.setup setup_t;; + +# 7828 "setup.ml" +let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t +open BaseCompat.Compat_0_4 +(* OASIS_STOP *) + +let () = setup ();; diff --git a/src/CommonPath.ml b/src/CommonPath.ml new file mode 100644 index 0000000..d889879 --- /dev/null +++ b/src/CommonPath.ml @@ -0,0 +1,36 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +(** A fast operation cannot be done, will + continue by trying more complex processing + *) + +module StringExt = FileStringExt + +exception CannotHandleFast + + +let fast_concat _ _ = raise CannotHandleFast +let fast_basename _ = raise CannotHandleFast +let fast_dirname _ = raise CannotHandleFast +let fast_is_relative _ = raise CannotHandleFast +let fast_is_current _ = raise CannotHandleFast +let fast_is_parent _ = raise CannotHandleFast diff --git a/src/ExtensionPath.ml b/src/ExtensionPath.ml new file mode 100644 index 0000000..4a4493e --- /dev/null +++ b/src/ExtensionPath.ml @@ -0,0 +1,63 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +(** Manipulate path extension + *) + +let get fn = + let start_pos = + (String.rindex fn '.') + 1 + in + let fn_len = + String.length fn + in + if start_pos = fn_len then + "" + else + String.sub fn start_pos (fn_len - start_pos) + + +let check fn ext = + try + (get fn) = ext + with Not_found -> + false + + +let chop fn = + try + let end_pos = + String.rindex fn '.' + in + if end_pos = 0 then + "" + else + String.sub fn 0 end_pos + with Not_found -> + fn + + +let add fn ext = + fn ^ "." ^ ext + + +let replace fn ext = + add (chop fn) ext diff --git a/src/FilePath.ml b/src/FilePath.ml new file mode 100644 index 0000000..ba5156b --- /dev/null +++ b/src/FilePath.ml @@ -0,0 +1,618 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FilePath_type + +exception BaseFilenameRelative of filename +exception UnrecognizedOS of string +exception EmptyFilename +exception NoExtension of filename +exception InvalidFilename of filename + +module type OS_SPECIFICATION = +sig + val dir_writer: (filename_part list) -> filename + val dir_reader: filename -> (filename_part list) + val path_writer: (filename list) -> string + val path_reader: string -> (filename list) + val fast_concat: filename -> filename -> filename + val fast_basename: filename -> filename + val fast_dirname: filename -> filename + val fast_is_relative: filename -> bool + val fast_is_current: filename -> bool + val fast_is_parent: filename -> bool +end + + +module type PATH_SPECIFICATION = +sig + type filename + type extension + + val string_of_filename: filename -> string + val filename_of_string: string -> filename + val extension_of_string: string -> extension + val string_of_extension: extension -> string + val make_filename: string list -> filename + val is_subdir: filename -> filename -> bool + val is_updir: filename -> filename -> bool + val compare: filename -> filename -> int + val basename: filename -> filename + val dirname: filename -> filename + val concat: filename -> filename -> filename + val reduce: ?no_symlink:bool -> filename -> filename + val make_absolute: filename -> filename -> filename + val make_relative: filename -> filename -> filename + val reparent: filename -> filename -> filename -> filename + val identity: filename -> filename + val is_valid: filename -> bool + val is_relative: filename -> bool + val is_current: filename -> bool + val is_parent: filename -> bool + val chop_extension: filename -> filename + val get_extension: filename -> extension + val check_extension: filename -> extension -> bool + val add_extension: filename -> extension -> filename + val replace_extension: filename -> extension -> filename + val string_of_path: filename list -> string + val path_of_string: string -> filename list + val current_dir: filename + val parent_dir: filename +end + + +module type PATH_STRING_SPECIFICATION = +sig + module Abstract: PATH_SPECIFICATION + + include PATH_SPECIFICATION with + type filename = string and + type extension = string +end + + +(* Convert an OS_SPECIFICATION to PATH_SPECIFICATION *) +module GenericPath = +functor (OsOperation: OS_SPECIFICATION) -> +struct + type filename = FilePath_type.filename_part list + + type extension = FilePath_type.extension + + (* Filename_from_string *) + + let filename_of_string str = + try + OsOperation.dir_reader str + with Parsing.Parse_error -> + raise (InvalidFilename str) + + (* String_from_filename *) + + let string_of_filename path = + OsOperation.dir_writer path + + (* Reduce *) + + let reduce ?(no_symlink=false) path = + (* TODO: not tail recursive ! *) + let rec reduce_aux lst = + match lst with + | ParentDir :: tl when no_symlink -> + begin + match reduce_aux tl with + | Root s :: tl -> + Root s :: tl + | ParentDir :: tl -> + ParentDir :: ParentDir :: tl + | [] -> + ParentDir :: tl + | _ :: tl -> + tl + end + | ParentDir :: tl -> + ParentDir :: (reduce_aux tl) + | CurrentDir _ :: tl + | Component "" :: tl -> + (reduce_aux tl) + | Component s :: tl -> + Component s :: (reduce_aux tl) + | Root s :: tl -> + Root s :: (reduce_aux tl) + | [] -> + [] + in + let rev_path = List.rev path in + match reduce_aux rev_path with + | [] when no_symlink = false-> + (* assert + * ( List.for_all ( function | Component "" + * | CurrentDir _ -> true | _ -> false ) rev_path ) *) + (try + (* use last CurrentDir _ *) + [ List.find ( function | CurrentDir _ -> true | _ -> false ) rev_path ] + with + | Not_found -> [] ) (* Only Component "" *) + |l -> List.rev l + + + + (* Compare, subdir, updir *) + + type filename_relation = SubDir | UpDir | Equal | NoRelation of int + + let relation_of_filename path1 path2 = + let rec relation_of_filename_aux path1 path2 = + match (path1, path2) with + ([], []) -> + Equal + | (hd1 :: tl1, hd2 :: tl2) -> + if hd1 = hd2 then + relation_of_filename_aux tl1 tl2 + else + begin + NoRelation (String.compare + (string_of_filename [hd1]) + (string_of_filename [hd2]) + ) + end + | (_, []) -> SubDir + | ([], _) -> UpDir + in + relation_of_filename_aux path1 path2 + + let is_subdir path1 path2 = + match relation_of_filename path1 path2 with + SubDir -> + true + | _ -> + false + + let is_updir path1 path2 = + match relation_of_filename path1 path2 with + UpDir -> + true + | _ -> + false + + + let compare path1 path2 = + match relation_of_filename path1 path2 with + SubDir -> -1 + | UpDir -> 1 + | Equal -> 0 + | NoRelation i -> i + + (* Concat *) + + let concat lst_path1 lst_path2 = + reduce + (match lst_path2 with + | CurrentDir Short :: tl_path2 -> + lst_path1 @ tl_path2 + | _ -> + lst_path1 @ lst_path2) + + + (* Is_relative *) + + let is_relative lst_path = + match lst_path with + (Root _) :: _ -> false + | _ -> true + + + (* Is_valid *) + + let is_valid path = + (* As we are manipulating abstract filename, + and that it has been parsed, we are + sure that all is correct *) + true + + let is_current path = + match path with + [ (CurrentDir _) ] -> true + | _ -> false + + let is_parent path = + match path with + [ ParentDir ] -> true + | _ -> false + + (* Basename *) + + let basename path = + match List.rev path with + | hd :: _ -> [hd] + | [] -> raise EmptyFilename + + (* Dirname *) + + let dirname path = + match List.rev path with + | _ :: tl -> List.rev tl + | [] -> raise EmptyFilename + + (* Extension manipulation *) + + let wrap_extension f path = + match basename path with + | [Component fn] -> + f fn + | _ -> + raise (NoExtension (string_of_filename path)) + + let check_extension path ext = + wrap_extension + (fun fn -> ExtensionPath.check fn ext) + path + + let get_extension path = + wrap_extension + (fun fn -> ExtensionPath.get fn) + path + + let chop_extension path = + wrap_extension + (fun fn -> + concat + (dirname path) + [Component (ExtensionPath.chop fn)]) + path + + let add_extension path ext = + wrap_extension + (fun fn -> + concat + (dirname path) + [Component (ExtensionPath.add fn ext)]) + path + + let replace_extension path ext = + wrap_extension + (fun fn -> + concat + (dirname path) + [Component (ExtensionPath.replace fn ext)]) + path + + let extension_of_string x = x + + let string_of_extension x = x + + (* Make_asbolute *) + let make_absolute path_base path_path = + reduce + (if is_relative path_base then + raise (BaseFilenameRelative (string_of_filename path_base)) + else if is_relative path_path then + path_base @ path_path + else + path_path) + + (* Make_relative *) + let make_relative path_base path_path = + let rec make_relative_aux lst_base lst_path = + match (lst_base, lst_path) with + x :: tl_base, a :: tl_path when x = a -> + make_relative_aux tl_base tl_path + | _, _ -> + let back_to_base = List.rev_map + (fun _ -> ParentDir) + lst_base + in + back_to_base @ lst_path + in + reduce + (if is_relative path_base then + raise (BaseFilenameRelative (string_of_filename path_base)) + else if is_relative path_path then + path_path + else + make_relative_aux path_base path_path) + + (* Make_filename *) + let make_filename lst_path = + reduce (List.flatten (List.map filename_of_string lst_path)) + + (* Reparent *) + let reparent path_src path_dst path = + let path_relative = + make_relative path_src path + in + make_absolute path_dst path_relative + + (* Identity *) + let identity path = path + + (* Manipulate path like variable *) + + let string_of_path lst = + OsOperation.path_writer (List.map string_of_filename lst) + + let path_of_string str = + List.map + filename_of_string + (OsOperation.path_reader str) + + (* Generic filename component *) + + let current_dir = [ CurrentDir Long ] + + let parent_dir = [ ParentDir ] +end + + +(* Convert an OS_SPECIFICATION to PATH_STRING_SPECIFICATION *) +module GenericStringPath = +functor (OsOperation: OS_SPECIFICATION) -> +struct + + module Abstract = GenericPath(OsOperation) + + type filename = string + type extension = string + + let string_of_filename path = + path + + let filename_of_string path = + path + + let string_of_extension ext = + ext + + let extension_of_string str = + str + + let f2s = Abstract.string_of_filename + + let s2f = Abstract.filename_of_string + + let e2s = Abstract.string_of_extension + + let s2e = Abstract.extension_of_string + + let is_subdir path1 path2 = + Abstract.is_subdir (s2f path1) (s2f path2) + + let is_updir path1 path2 = + Abstract.is_updir (s2f path1) (s2f path2) + + let compare path1 path2 = + Abstract.compare (s2f path1) (s2f path2) + + let basename path = + try + OsOperation.fast_basename path + with CommonPath.CannotHandleFast -> + f2s (Abstract.basename (s2f path)) + + let dirname path = + try + OsOperation.fast_dirname path + with CommonPath.CannotHandleFast -> + f2s (Abstract.dirname (s2f path)) + + let concat path1 path2 = + try + OsOperation.fast_concat path1 path2 + with CommonPath.CannotHandleFast -> + f2s (Abstract.concat (s2f path1) (s2f path2)) + + let make_filename path_lst = + f2s (Abstract.make_filename path_lst) + + let reduce ?no_symlink path = + f2s (Abstract.reduce ?no_symlink (s2f path)) + + let make_absolute base_path path = + f2s (Abstract.make_absolute (s2f base_path) (s2f path)) + + let make_relative base_path path = + f2s (Abstract.make_relative (s2f base_path) (s2f path)) + + let reparent path_src path_dst path = + f2s (Abstract.reparent (s2f path_src) (s2f path_dst) (s2f path)) + + let identity path = + f2s (Abstract.identity (s2f path)) + + let is_valid path = + try + Abstract.is_valid (s2f path) + with InvalidFilename _ -> + false + + let is_relative path = + try + OsOperation.fast_is_relative path + with CommonPath.CannotHandleFast -> + Abstract.is_relative (s2f path) + + let is_current path = + try + OsOperation.fast_is_current path + with CommonPath.CannotHandleFast -> + Abstract.is_current (s2f path) + + let is_parent path = + try + OsOperation.fast_is_parent path + with CommonPath.CannotHandleFast -> + Abstract.is_parent (s2f path) + + let wrap_extension f path = + let bfn = + OsOperation.fast_basename path + in + if OsOperation.fast_is_parent bfn || + OsOperation.fast_is_current bfn || + not (OsOperation.fast_is_relative bfn) then + raise (NoExtension path) + else + f bfn + + let chop_extension path = + try + wrap_extension + (fun fn -> + OsOperation.fast_concat + (OsOperation.fast_dirname path) + (ExtensionPath.chop fn)) + path + with CommonPath.CannotHandleFast -> + f2s (Abstract.chop_extension (s2f path)) + + let get_extension path = + try + wrap_extension + (fun fn -> ExtensionPath.get fn) + path + with CommonPath.CannotHandleFast -> + e2s (Abstract.get_extension (s2f path)) + + let check_extension path ext = + try + wrap_extension + (fun fn -> ExtensionPath.check fn ext) + path + with CommonPath.CannotHandleFast -> + Abstract.check_extension (s2f path) (s2e ext) + + let add_extension path ext = + try + wrap_extension + (fun fn -> + OsOperation.fast_concat + (OsOperation.fast_dirname path) + (ExtensionPath.add fn ext)) + path + with CommonPath.CannotHandleFast -> + f2s (Abstract.add_extension (s2f path) (s2e ext)) + + let replace_extension path ext = + try + wrap_extension + (fun fn -> + OsOperation.fast_concat + (OsOperation.fast_dirname path) + (ExtensionPath.replace fn ext)) + path + with CommonPath.CannotHandleFast -> + f2s (Abstract.replace_extension (s2f path) (s2e ext)) + + let string_of_path path_lst = + Abstract.string_of_path (List.map s2f path_lst) + + let path_of_string str = + List.map f2s (Abstract.path_of_string str) + + let current_dir = + f2s (Abstract.current_dir) + + let parent_dir = + f2s (Abstract.parent_dir) +end + + +module DefaultPath = GenericStringPath(struct + + let os_depend unix macos win32 = + match Sys.os_type with + "Unix" + | "Cygwin" -> unix + | "MacOS" -> macos + | "Win32" -> win32 + | s -> raise (UnrecognizedOS s) + + let dir_writer = + os_depend + UnixPath.dir_writer + MacOSPath.dir_writer + Win32Path.dir_writer + + let dir_reader = + os_depend + UnixPath.dir_reader + MacOSPath.dir_reader + Win32Path.dir_reader + + let path_writer = + os_depend + UnixPath.path_writer + MacOSPath.path_writer + Win32Path.path_writer + + let path_reader = + os_depend + UnixPath.path_reader + MacOSPath.path_reader + Win32Path.path_reader + + let fast_concat = + os_depend + UnixPath.fast_concat + MacOSPath.fast_concat + Win32Path.fast_concat + + let fast_basename = + os_depend + UnixPath.fast_basename + MacOSPath.fast_basename + Win32Path.fast_basename + + let fast_dirname = + os_depend + UnixPath.fast_dirname + MacOSPath.fast_dirname + Win32Path.fast_dirname + + let fast_is_relative = + os_depend + UnixPath.fast_is_relative + MacOSPath.fast_is_relative + Win32Path.fast_is_relative + + let fast_is_current = + os_depend + UnixPath.fast_is_current + MacOSPath.fast_is_current + Win32Path.fast_is_current + + let fast_is_parent = + os_depend + UnixPath.fast_is_parent + MacOSPath.fast_is_parent + Win32Path.fast_is_parent +end) + + +module UnixPath = GenericStringPath(UnixPath) + +module MacOSPath = GenericStringPath(MacOSPath) + +module Win32Path = GenericStringPath(Win32Path) + +module CygwinPath = UnixPath + +include DefaultPath diff --git a/src/FilePath.mli b/src/FilePath.mli new file mode 100644 index 0000000..6238f80 --- /dev/null +++ b/src/FilePath.mli @@ -0,0 +1,302 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +(** Operations on abstract filenames. + + This module allow to manipulate string or abstract representation of a + filename. + + Abstract representation of a filename allow to decode it only once, and + should speed up further operation on it (comparison in particular). If you + intend to do a lot of processing on filename, you should consider using its + abstract representation. + + This module manipulate abstract path that are not bound to a real + filesystem. In particular, it makes the assumption that there is no + symbolic link that should modify the meaning of a path. If you intend to use + this module against a real set of filename, the best solution is to apply to + every filename to solve symbolic link through {!FileUtil.readlink}. + + @author Sylvain Le Gall + *) + +(** Filename type. *) +type filename = string + +(** Extension type. *) +type extension = string + +(** {2 Exceptions and types} *) + +(** Cannot pass a base filename which is relative. *) +exception BaseFilenameRelative of filename + +(** We do not have recognized any OS, please contact upstream. *) +exception UnrecognizedOS of string + +(** The filename use was empty. *) +exception EmptyFilename + +(** The last component of the filename does not support extension (Root, + ParentDir...) + *) +exception NoExtension of filename + +(** The filename used is invalid. *) +exception InvalidFilename of filename + +(** {2 Ordering} *) + +(** [is_subdir fl1 fl2] Is [fl2] a sub directory of [fl1] *) +val is_subdir: filename -> filename -> bool + +(** [is_updir fl1 fl2] Is [fl1] a sub directory of [fl2] *) +val is_updir: filename -> filename -> bool + +(** [compare fl1 fl2] Give an order between the two filename. The + classification is done by sub directory relation, [fl1] < [fl2] iff [fl1] is + a subdirectory of [fl2], and lexicographical order of each part of the + reduce filename when [fl1] and [fl2] has no hierarchical relation + *) +val compare: filename -> filename -> int + +(** {2 Standard operations } *) + +(** Current dir. *) +val current_dir: filename + +(** Upper dir. *) +val parent_dir: filename + +(** Make a filename from a set of strings. *) +val make_filename: string list -> filename + +(** Extract only the file name of a filename. *) +val basename: filename -> filename + +(** Extract the directory name of a filename. *) +val dirname: filename -> filename + +(** Append a filename to a filename. *) +val concat: filename -> filename -> filename + +(** Return the shortest filename which is equal to the filename given. It remove + the "." in Unix filename, for example. + If [no_symlink] flag is set, consider that the path doesn't contain symlink + and in this case ".." for Unix filename are also reduced. + *) +val reduce: ?no_symlink:bool -> filename -> filename + +(** Create an absolute filename from a filename relative and an absolute base + filename. + *) +val make_absolute: filename -> filename -> filename + +(** Create a filename which is relative to the base filename. *) +val make_relative: filename -> filename -> filename + +(** [reparent fln_src fln_dst fln] Return the same filename as [fln] + but the root is no more [fln_src] but [fln_dst]. It replaces the + [fln_src] prefix by [fln_dst]. + *) +val reparent: filename -> filename -> filename -> filename + +(** Identity for testing the stability of implode/explode. *) +val identity: filename -> filename + +(** Test if the filename is a valid one. *) +val is_valid: filename -> bool + +(** Check if the filename is relative to a dir or not. + *) +val is_relative: filename -> bool + +(** Check if the filename is the current directory. + *) +val is_current: filename -> bool + +(** Check if the filename is the parent directory. + *) +val is_parent: filename -> bool + +(** {2 Extension}*) + +(** Extension is define as the suffix of a filename, just after the last ".". + *) + +(** Remove extension and the trailing ".". *) +val chop_extension: filename -> filename + +(** Extract the extension. *) +val get_extension: filename -> extension + +(** Check the extension. *) +val check_extension: filename -> extension -> bool + +(** Add an extension with a "." before. *) +val add_extension: filename -> extension -> filename + +(** Replace extension. *) +val replace_extension: filename -> extension -> filename + +(** {2 PATH-like operation}*) + +(** PATH-like refers the environment variable PATH. This variable holds a list + of filename. The functions [string_of_path] and [path_of_string] allow to + convert this kind of list by using the good separator between filename. + *) + +(** Create a PATH-like string. *) +val string_of_path: filename list -> string + +(** Extract filenames from a PATH-like string. *) +val path_of_string: string -> filename list + +(** {2 Filename specifications} *) + +(** Definition of operations for path manipulation. *) + +(** Generic operations. *) +module type PATH_SPECIFICATION = +sig + type filename + type extension + + (** {3 Converting abstract type from/to string } *) + + (** Create a filename from a string. *) + val string_of_filename: filename -> string + + (** Create a string from a filename. *) + val filename_of_string: string -> filename + + (** Create an extension from a string. *) + val extension_of_string: string -> extension + + (** Return string representation of an extension. *) + val string_of_extension: extension -> string + + (** {3 Standard operations} *) + + (** See {!FilePath.make_filename} *) + val make_filename: string list -> filename + + (** See {!FilePath.is_subdir} *) + val is_subdir: filename -> filename -> bool + + (** See {!FilePath.is_updir} *) + val is_updir: filename -> filename -> bool + + (** See {!FilePath.compare} *) + val compare: filename -> filename -> int + + (** See {!FilePath.basename} *) + val basename: filename -> filename + + (** See {!FilePath.dirname} *) + val dirname: filename -> filename + + (** See {!FilePath.concat} *) + val concat: filename -> filename -> filename + + (** See {!FilePath.reduce} *) + val reduce: ?no_symlink:bool -> filename -> filename + + (** See {!FilePath.make_absolute} *) + val make_absolute: filename -> filename -> filename + + (** See {!FilePath.make_relative} *) + val make_relative: filename -> filename -> filename + + (** See {!FilePath.reparent} *) + val reparent: filename -> filename -> filename -> filename + + (** See {!FilePath.identity} *) + val identity: filename -> filename + + (** See {!FilePath.is_valid} *) + val is_valid: filename -> bool + + (** See {!FilePath.is_relative} *) + val is_relative: filename -> bool + + (** See {!FilePath.is_current} *) + val is_current: filename -> bool + + (** See {!FilePath.is_parent} *) + val is_parent: filename -> bool + + (** See {!FilePath.chop_extension} *) + val chop_extension: filename -> filename + + (** See {!FilePath.get_extension} *) + val get_extension: filename -> extension + + (** See {!FilePath.check_extension} *) + val check_extension: filename -> extension -> bool + + (** See {!FilePath.add_extension} *) + val add_extension: filename -> extension -> filename + + (** See {!FilePath.replace_extension} *) + val replace_extension: filename -> extension -> filename + + (** See {!FilePath.string_of_path} *) + val string_of_path: filename list -> string + + (** See {!FilePath.path_of_string} *) + val path_of_string: string -> filename list + + (** See {!FilePath.current_dir} *) + val current_dir: filename + + (** See {!FilePath.parent_dir} *) + val parent_dir: filename +end + +(** Generic operations, with type filename and extension as strings. *) +module type PATH_STRING_SPECIFICATION = +sig + module Abstract: PATH_SPECIFICATION + + include PATH_SPECIFICATION with + type filename = string and + type extension = string +end + +(** Operations on filenames for other OS. The {!DefaultPath} always match the + current OS. + *) + +(** Default operating system. *) +module DefaultPath: PATH_STRING_SPECIFICATION + +(** Unix operating system. *) +module UnixPath: PATH_STRING_SPECIFICATION + +(** MacOS operating system. *) +module MacOSPath: PATH_STRING_SPECIFICATION + +(** Win32 operating system. *) +module Win32Path: PATH_STRING_SPECIFICATION + +(** Cygwin operating system. *) +module CygwinPath: PATH_STRING_SPECIFICATION diff --git a/src/FilePath_type.ml b/src/FilePath_type.ml new file mode 100644 index 0000000..5c0fc80 --- /dev/null +++ b/src/FilePath_type.ml @@ -0,0 +1,53 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +type current_dir_type = + Short + | Long + + +type filename_part = + Root of string + | ParentDir + | CurrentDir of current_dir_type + | Component of string + + +type filename = string + + +type extension = string + + +(* Utility function to parse filename *) + + +let begin_string str lst = (str, lst) + + +let add_string str1 (str2, lst) = (str1 ^ str2, lst) + + +let end_string (str, lst) = (Component str) :: lst + + +(* Definition of the caracteristic length of a path *) +let path_length = 80 diff --git a/src/FileStringExt.ml b/src/FileStringExt.ml new file mode 100644 index 0000000..5ecdd5a --- /dev/null +++ b/src/FileStringExt.ml @@ -0,0 +1,62 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +(** Extended String module + *) + +(** Split a string, separator not included + *) +let split ?(start_acc=[]) ?(start_pos=0) ~map sep str = + let str_len = String.length str in + let rec split_aux acc pos = + if pos < str_len then begin + let pos_sep = + try + String.index_from str pos sep + with Not_found -> + str_len + in + let part = String.sub str pos (pos_sep - pos) in + let acc = (map part) :: acc in + if pos_sep >= str_len then + (* Nothing more in the string *) + List.rev acc + else if pos_sep = (str_len - 1) then + (* String end with a separator *) + List.rev ((map "") :: acc) + else + split_aux acc (pos_sep + 1) + end else + List.rev acc + in + split_aux start_acc start_pos + + +(** Cut in two a string, separator not included + *) +let break_at_first sep str = + let pos_sep = + String.index str sep + in + (String.sub str 0 pos_sep), + (String.sub str (pos_sep + 1) ((String.length str) - pos_sep - 1)) + + diff --git a/src/FileUtil.ml b/src/FileUtil.ml new file mode 100644 index 0000000..1b32f36 --- /dev/null +++ b/src/FileUtil.ml @@ -0,0 +1,45 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +include FileUtilTypes +include FileUtilPermission +include FileUtilSize +include FileUtilSTAT +include FileUtilUMASK +include FileUtilLS +include FileUtilCHMOD +include FileUtilTEST +include FileUtilPWD +include FileUtilREADLINK +include FileUtilWHICH +include FileUtilMKDIR +include FileUtilTOUCH +include FileUtilFIND +include FileUtilRM +include FileUtilCP +include FileUtilMV +include FileUtilCMP +include FileUtilDU + +type exc = FileUtilMisc.exc +type 'a error_handler = string -> 'a -> unit + +module Mode = FileUtilMode diff --git a/src/FileUtil.mli b/src/FileUtil.mli new file mode 100644 index 0000000..0554286 --- /dev/null +++ b/src/FileUtil.mli @@ -0,0 +1,536 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +(** POSIX utilities for files and directories. + + A module to provide the core POSIX utilities to manipulate files and + directories. All functions try to mimic common POSIX utilities but are + written in pure OCaml. + + @author Sylvain Le Gall + *) + +open FilePath + + +(*********************************************************************) +(** + + {2 Types and exceptions } + + *) + +exception FileDoesntExist of filename +exception RecursiveLink of filename + +(** Generic error handling functions. Whenever such a function is available it + helps report the error and allows to raise an exception. The [string] + provided is the human readable version of ['a]. In most cases ['a] is a + polymorphic variant. + *) +type 'a error_handler = string -> 'a -> unit + +(** Exception raised when after an [error_handler] the execution cannot + continue. The rest of the workflow logic cannot handle the default case and + the whole operation can be in the middle of transformation. + *) +exception Fatal of string + +(** Policy concerning links which are directories. *) +type action_link = + | Follow + (** We consider link as simple directory (it is dangerous) *) + | Skip + (** Just skip it *) + | SkipInform of (filename -> unit) + (** Skip and execute an action *) + | AskFollow of (filename -> bool) + (** Ask and wait for input, false means skip *) + +(** For certain command, you should need to ask the user wether + or not he wants to act. + *) +type interactive = + | Force (** Do it anyway *) + | Ask of (filename -> bool) (** Promp the user *) + + +(*********************************************************************) +(** + + {2 Permission } + + *) + +(** Base permission. This is the permission corresponding to one user or group. + *) +type base_permission = + { + sticky: bool; + exec: bool; + write: bool; + read: bool; + } + +(** Full permission. All the base permissions of a file. + *) +type permission = + { + user: base_permission; + group: base_permission; + other: base_permission; + } + +(** Translate POSIX integer permission. *) +val permission_of_int: int -> permission + +(** Return the POSIX integer permission *) +val int_of_permission: permission -> int + +(** Permission symbolic mode. *) +module Mode: +sig + type who = [`User | `Group | `Other | `All] + type wholist = [ who | `List of who list ] + type permcopy = [`User | `Group | `Other] + type perm = [ `Read | `Write | `Exec | `ExecX | `Sticky | `StickyO ] + type permlist = [ perm | `List of perm list ] + type actionarg = [ permlist | permcopy ] + type action = [ `Set of actionarg | `Add of actionarg | `Remove of actionarg] + type actionlist = [ action | `List of action list ] + type clause = [ `User of actionlist | `Group of actionlist + | `Other of actionlist | `All of actionlist + | `None of actionlist ] + + (** Typical symbolic mode: + - g+r -> [`Group (`Add `Read)] + - u=rw,g+rw,o-rwx -> + [`User (`Set (`List [`Read; `Write])); + `Group (`Add (`List [`Read; `Write])); + `Other (`Remove (`List [`Read; `Write; `Exec]))] + *) + type t = clause list +end + +(*********************************************************************) +(** + + {2 Size operation} + + *) + +(** File size + *) +type size = + TB of int64 (** Tera bytes *) + | GB of int64 (** Giga bytes *) + | MB of int64 (** Mega bytes *) + | KB of int64 (** Kilo bytes *) + | B of int64 (** Bytes *) + +(** Convert size to bytes. *) +val byte_of_size: size -> int64 + +(** Add two sizes. *) +val size_add: size -> size -> size + +(** Compare two sizes, using the classical compare function. If fuzzy is set to + true, the comparison is done on the most significant size unit of both + value. + *) +val size_compare: ?fuzzy:bool -> size -> size -> int + +(** Convert a value to a string representation. If fuzzy is set to true, only + consider the most significant unit + *) +val string_of_size: ?fuzzy:bool -> size -> string + +(*********************************************************************) +(** + + {2 stat } + + *) + +(** Kind of file. This set is a combination of all POSIX file, some of them + doesn't exist at all on certain file system or OS. + *) +type kind = + Dir + | File + | Dev_char + | Dev_block + | Fifo + | Socket + | Symlink (** @since 0.4.6 *) + + +(** Information about a file. This type is derived from Unix.stat + *) +type stat = + { + kind: kind; + is_link: bool; + permission: permission; + size: size; + owner: int; + group_owner: int; + access_time: float; + modification_time: float; + creation_time: float; + device: int; + inode: int; + } + + +(** [stat fln] Return information about the file (like Unix.stat) + Non POSIX command. + *) +val stat: ?dereference:bool -> filename -> stat + +(*********************************************************************) +(** + + {2 umask } + + *) + +exception UmaskError of string + +(** Possible umask errors. *) +type umask_error = [ `Exc of exn | `NoStickyBit of int ] + +(** Get or set the file mode creation mask. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/umask.html}POSIX documentation}. + *) +val umask: + ?error:(umask_error error_handler) -> + ?mode:[< `Octal of int | `Symbolic of Mode.t ] -> + [< `Octal of int -> 'a | `Symbolic of Mode.t -> 'a] -> + 'a + +(** Apply umask to a given file permission. + *) +val umask_apply: int -> int + +(*********************************************************************) +(** + + {2 test } + + *) + +(** Pattern you can use to test file. If the file doesn't exist the result is + always false. + *) +type test_file = + | Is_dev_block (** FILE is block special *) + | Is_dev_char (** FILE is character special *) + | Is_dir (** FILE is a directory *) + | Exists (** FILE exists *) + | Is_file (** FILE is a regular file *) + | Is_set_group_ID (** FILE is set-group-ID *) + | Has_sticky_bit (** FILE has its sticky bit set *) + | Is_link (** FILE is a symbolic link *) + | Is_pipe (** FILE is a named pipe *) + | Is_readable (** FILE is readable *) + | Is_writeable (** FILE is writeable *) + | Size_not_null (** FILE has a size greater than zero *) + | Size_bigger_than of size (** FILE has a size greater than given size *) + | Size_smaller_than of size (** FILE has a size smaller than given size *) + | Size_equal_to of size (** FILE has the same size as given size *) + | Size_fuzzy_equal_to of size (** FILE has approximatively the same size as + given size *) + | Is_socket (** FILE is a socket *) + | Has_set_user_ID (** FILE its set-user-ID bit is set *) + | Is_exec (** FILE is executable *) + | Is_owned_by_user_ID (** FILE is owned by the effective user ID *) + | Is_owned_by_group_ID (** FILE is owned by the effective group ID *) + | Is_newer_than of filename (** FILE1 is newer (modification date) than + FILE2 *) + | Is_older_than of filename (** FILE1 is older than FILE2 *) + | Is_newer_than_date of float (** FILE is newer than given date *) + | Is_older_than_date of float (** FILE is older than given date *) + | And of test_file * test_file (** Result of TEST1 and TEST2 *) + | Or of test_file * test_file (** Result of TEST1 or TEST2 *) + | Not of test_file (** Result of not TEST *) + | Match of string (** Compilable match (Str or PCRE or ...) *) + | True (** Always true *) + | False (** Always false *) + | Has_extension of extension (** Check extension *) + | Has_no_extension (** Check absence of extension *) + | Is_parent_dir (** Basename is the parent dir *) + | Is_current_dir (** Basename is the current dir *) + | Basename_is of filename (** Check the basename *) + | Dirname_is of filename (** Check the dirname *) + | Custom of (filename -> bool) (** Custom operation on filename *) + + +(** Test a file. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/test.html}POSIX documentation}. + *) +val test: + ?match_compile:(filename -> filename -> bool) -> + test_file -> filename -> bool + +(*********************************************************************) +(** + + {2 chmod } + + *) + +exception ChmodError of string + +(** Possible chmod errors. *) +type chmod_error = [`Exc of exn] + +(** Change permissions of files. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/chmod.html}POSIX documentation}. + *) +val chmod: + ?error:(chmod_error error_handler) -> + ?recurse:bool -> + [< `Octal of Unix.file_perm | `Symbolic of Mode.t ] -> + filename list -> unit + +(*********************************************************************) +(** + + {2 mkdir } + + *) + +exception MkdirError of string + +(** Possible mkdir errors. *) +type mkdir_error = + [ `DirnameAlreadyUsed of filename + | `Exc of exn + | `MissingComponentPath of filename + | `MkdirChmod of filename * Unix.file_perm * string * chmod_error ] + +(** Create the directory which name is provided. Set [~parent] to true + if you also want to create every directory of the path. Use mode to + provide some specific right. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/mkdir.html}POSIX documentation}. + *) +val mkdir: + ?error:(mkdir_error error_handler) -> + ?parent:bool -> + ?mode:[< `Octal of Unix.file_perm | `Symbolic of FileUtilMode.t ] -> + filename -> unit + +(*********************************************************************) +(** + + {2 rm } + + *) + +exception RmError of string + +(** Possible rm errors. *) +type rm_error = + [ `DirNotEmpty of filename + | `Exc of exn + | `NoRecurse of filename ] + +(** Remove the filename provided. Set [~recurse] to true in order to + completely delete a directory. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/rm.html}POSIX documentation}. + *) +val rm: + ?error:(rm_error error_handler) -> + ?force:interactive -> ?recurse:bool -> filename list -> unit + +(*********************************************************************) +(** + + {2 cp } + + *) + +exception CpError of string + +(** Possible cp errors. *) +type cp_error = + [ `CannotChmodDstDir of filename * exn + | `CannotCopyDir of filename + | `CannotCopyFilesToFile of filename list * filename + | `CannotCreateDir of filename * exn + | `CannotListSrcDir of filename * exn + | `CannotOpenDstFile of filename * exn + | `CannotOpenSrcFile of filename * exn + | `CannotRemoveDstFile of filename * exn + | `DstDirNotDir of filename + | `ErrorRead of filename * exn + | `ErrorWrite of filename * exn + | `Exc of exn + | `NoSourceFile of filename + | `PartialWrite of filename * int * int + | `SameFile of filename * filename + | `UnhandledType of filename * kind ] + +(** Copy the hierarchy of files/directory to another destination. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/cp.html}POSIX documentation}. + *) +val cp: + ?follow:action_link -> + ?force:interactive -> + ?recurse:bool -> + ?preserve:bool -> + ?error:(cp_error error_handler) -> + filename list -> filename -> unit + +(*********************************************************************) +(** + + {2 mv } + + *) + +exception MvError of string + +(** Possible mv errors. *) +type mv_error = + [ `Exc of exn + | `MvCp of filename * filename * string * cp_error + | `MvRm of filename * string * rm_error + | `NoSourceFile ] + +(** Move files/directories to another destination. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/mv.html}POSIX documentation}. + *) +val mv: + ?error:(mv_error error_handler) -> + ?force:interactive -> filename -> filename -> unit + + +(*********************************************************************) +(** + + {2 touch } + + *) + +(** Time for file *) +type touch_time_t = + | Touch_now (** Use Unix.gettimeofday *) + | Touch_file_time of filename (** Get mtime of file *) + | Touch_timestamp of float (** Use GMT timestamp *) + + +(** Modify the timestamp of the given filename. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/touch.html}POSIX documentation}. + If atime and mtime are not specified, they are both considered true. If only + atime or mtime is sepcified, the other is false. + @param atime modify access time. + @param mtime modify modification time. + @param create if file doesn't exist, create it, default true + @param time what time to set, default Touch_now + *) +val touch: + ?atime:bool -> + ?mtime:bool -> + ?create:bool -> ?time:touch_time_t -> filename -> unit + +(*********************************************************************) +(** + + {2 ls } + + *) + +(** Apply a filtering pattern to a filename. + *) +val filter: test_file -> filename list -> filename list + +(** List the content of a directory. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/ls.html}POSIX documentation}. + *) +val ls: filename -> filename list + +(*********************************************************************) +(** + + {2 Misc operations } + + *) + +(** Return the current dir. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/pwd.html}POSIX documentation}. + *) +val pwd: unit -> filename + +(** Resolve to the real filename removing symlink. + Non POSIX command. + *) +val readlink: filename -> filename + +(** Try to find the executable in the PATH. Use environement variable + PATH if none is provided. + Non POSIX command. + *) +val which: + ?path:filename list -> filename -> filename + +(** [cmp skip1 fln1 skip2 fln2] Compare files [fln1] and [fln2] starting at pos + [skip1] [skip2] and returning the first octect where a difference occurs. + Returns [Some -1] if one of the file is not readable or if it is not a + file. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/cmp.html}POSIX documentation}. + *) +val cmp: + ?skip1:int -> + filename -> ?skip2:int -> filename -> int option + +(** [du fln_lst] Return the amount of space of all the file + which are subdir of fln_lst. Also return details for each + file scanned. + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/du.html}POSIX documentation}. + *) +val du: filename list -> size * (filename * size) list + +(** [find ~follow:fol tst fln exec accu] Descend the directory tree starting + from the given filename and using the test provided. You cannot match + [current_dir] and [parent_dir]. For every file found, the action [exec] is + done, using the [accu] to start. For a simple file listing, you can use + [find True "." (fun x y -> y :: x) []] + See {{:http://pubs.opengroup.org/onlinepubs/007904875/utilities/find.html}POSIX documentation}. + *) +val find: + ?follow:action_link -> + ?match_compile:(filename -> filename -> bool) -> + test_file -> + filename -> ('a -> filename -> 'a) -> 'a -> 'a + +(** For future release: +- [val pathchk: filename -> boolean * string], check whether file names are + valid or portable +- [val setfacl: filename -> permission -> unit], set file access control + lists (UNIX + extended attribute) +- [val getfacl: filename -> permission], get file access control lists + +ACL related function will be handled through a plugin system to handle at +runtime which attribute can be read/write (i.e. Win32 ACL, NFS acl, Linux ACL -- +or none). +*) diff --git a/src/FileUtilCHMOD.ml b/src/FileUtilCHMOD.ml new file mode 100644 index 0000000..c4547a7 --- /dev/null +++ b/src/FileUtilCHMOD.ml @@ -0,0 +1,63 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FileUtilMisc +open FileUtilPermission +open FileUtilSTAT +open FileUtilLS +open FileUtilUMASK + +exception ChmodError of string + +type chmod_error = [`Exc of exn] + + +let chmod + ?(error=fun str _ -> raise (ChmodError str)) + ?(recurse=false) + mode lst = + let _, handle_exception = + handle_error_gen "chmod" error (function #exc -> "") + in + let rec chmod_one fn = + let st = stat fn in + if st.kind = Dir && recurse then begin + List.iter chmod_one (ls fn) + end; + if not st.is_link then begin + let int_perm = + match mode with + | `Octal i -> i + | `Symbolic t -> + FileUtilMode.apply + ~is_dir:(st.kind = Dir) + ~umask:(umask (`Octal (fun i -> i))) + (int_of_permission st.permission) t + in + if int_perm <> int_of_permission st.permission then + try + Unix.chmod fn int_perm + with e -> + handle_exception ~fatal:true e + end + in + List.iter chmod_one lst diff --git a/src/FileUtilCMP.ml b/src/FileUtilCMP.ml new file mode 100644 index 0000000..6170628 --- /dev/null +++ b/src/FileUtilCMP.ml @@ -0,0 +1,79 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FilePath +open FileUtilTEST + + +let cmp ?(skip1 = 0) fln1 ?(skip2 = 0) fln2 = + if (reduce fln1) = (reduce fln2) then + None + else if (test (And(Is_readable, Is_file)) fln1) + && (test (And(Is_readable, Is_file)) fln2) then begin + let fd1 = open_in_bin fln1 in + let fd2 = open_in_bin fln2 in + let clean_fd () = + let () = try close_in fd1 with _ -> () in + let () = try close_in fd2 with _ -> () in + () + in + + let test_empty st = + try + Stream.empty st; + true + with Stream.Failure -> + false + in + + let _ = seek_in fd1 skip1 in + let _ = seek_in fd2 skip2 in + let stream1 = Stream.of_channel fd1 in + let stream2 = Stream.of_channel fd2 in + try + begin + while ((Stream.next stream1) = (Stream.next stream2)) do + () + done; + clean_fd (); + Some (Stream.count stream1) + end + with + | Stream.Failure -> + begin + match ((test_empty stream1), (test_empty stream2)) with + true, true -> + None + | true, false + | false, true + (* Don't know how this case could be... *) + | false, false -> + clean_fd (); + Some (Stream.count stream1) + end + | e -> + clean_fd (); + raise e + end else + Some (-1) + + diff --git a/src/FileUtilCP.ml b/src/FileUtilCP.ml new file mode 100644 index 0000000..787ae15 --- /dev/null +++ b/src/FileUtilCP.ml @@ -0,0 +1,303 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FilePath +open FileUtilMisc +open FileUtilPermission +open FileUtilTOUCH +open FileUtilRM +open FileUtilSTAT +open FileUtilUMASK +open FileUtilMKDIR +open FileUtilCHMOD +open FileUtilTEST + +exception CpError of string +exception CpSkip + +type cp_error = + [ `CannotChmodDstDir of filename * exn + | `CannotCopyDir of filename + | `CannotCopyFilesToFile of filename list * filename + | `CannotCreateDir of filename * exn + | `CannotListSrcDir of filename * exn + | `CannotOpenDstFile of filename * exn + | `CannotOpenSrcFile of filename * exn + | `CannotRemoveDstFile of filename * exn + | `DstDirNotDir of filename + | `ErrorRead of filename * exn + | `ErrorWrite of filename * exn + | `Exc of exn + | `NoSourceFile of filename + | `PartialWrite of filename * int * int + | `SameFile of filename * filename + | `UnhandledType of filename * kind ] + + +let same_file st1 st2 = + st1.device = st2.device && st1.inode = st2.inode + + +let cp + ?(follow=Skip) + ?(force=Force) + ?(recurse=false) + ?(preserve=false) + ?(error=(fun str _ -> raise (CpError str))) + fln_src_lst + fln_dst = + + let herror, _ = + let spf fmt = Printf.sprintf fmt in + let exs () e = + match e with + | Unix.Unix_error(err, _, _) -> Unix.error_message err + | e -> Printexc.to_string e + in + handle_error_gen "cp" error + (function + | `CannotRemoveDstFile(fn_dst, e) -> + spf "Cannot remove destination file '%s': %a." fn_dst exs e + | `CannotOpenDstFile(fn_dst, e) -> + spf "Cannot open destination file '%s': %a." fn_dst exs e + | `CannotOpenSrcFile(fn_src, e) -> + spf "Cannot open source file '%s': %a." fn_src exs e + | `ErrorRead(fn_src, e) -> + spf "Error reading file '%s': %a." fn_src exs e + | `ErrorWrite(fn_dst, e) -> + spf "Error writing file '%s': %a." fn_dst exs e + | `PartialWrite(fn_dst, read, written) -> + spf + "Partial write to file '%s': %d read, %d written." + fn_dst + read + written + | `CannotCopyDir fn_src -> + spf "Cannot copy directory '%s' recursively." fn_src + | `DstDirNotDir fn_dst -> + spf "Destination '%s' is not a directory." fn_dst + | `CannotCreateDir(fn_dst, e) -> + spf "Cannot create directory '%s': %a." fn_dst exs e + | `CannotListSrcDir(fn_src, e) -> + spf "Cannot list directory '%s': %a." fn_src exs e + | `CannotChmodDstDir(fn_dst, e) -> + spf "'Cannot chmod directory %s': %a." fn_dst exs e + | `NoSourceFile fn_src -> + spf "Source file '%s' doesn't exist." fn_src + | `SameFile(fn_src, fn_dst) -> + spf "'%s' and '%s' are the same file." fn_src fn_dst + | `UnhandledType(fn_src, _) -> + spf "Cannot handle the type of kind for file '%s'." fn_src + | `CannotCopyFilesToFile(fn_src_lst, fn_dst) -> + spf "Cannot copy a list of files to another file '%s'." fn_dst + | #exc -> "") + in + let handle_error e = + herror ~fatal:false e; + raise CpSkip + in + let handle_exception f a h = + try + f a + with e -> + herror ~fatal:false (h e); + raise CpSkip + in + + let copy_time_props st_src fln_dst = + if preserve then begin + touch + ~time:(Touch_timestamp st_src.modification_time) + ~mtime:true + ~create:false + fln_dst; + touch + ~time:(Touch_timestamp st_src.access_time) + ~atime:true + ~create:false + fln_dst; + end + in + + let buffer = String.make 1024 ' ' in + + let cp_file st_src dst_exists fn_src fn_dst = + let mode = int_of_permission st_src.permission in + (* POSIX conditions: *) + (* 3a *) + let fd_dst = + (* 3ai *) + if dst_exists && doit force fn_dst then begin + try + (* 3aii *) + Unix.openfile fn_dst [Unix.O_WRONLY; Unix.O_TRUNC] mode + with _ -> + (* 3aii *) + handle_exception + (fun lst -> rm lst) [fn_dst] + (fun e -> `CannotRemoveDstFile(fn_dst, e)); + handle_exception + (Unix.openfile fn_dst [Unix.O_WRONLY; Unix.O_CREAT]) mode + (fun e -> `CannotOpenDstFile(fn_dst, e)) + end else if not dst_exists then begin + handle_exception + (Unix.openfile fn_dst [Unix.O_WRONLY; Unix.O_CREAT]) mode + (fun e -> `CannotOpenDstFile(fn_dst, e)) + end else begin + raise CpSkip + end + in + let read = ref 0 in + try + let fd_src = + handle_exception + (Unix.openfile fn_src [Unix.O_RDONLY]) 0o600 + (fun e -> `CannotOpenSrcFile(fn_src, e)) + in + try + while (read := + handle_exception + (Unix.read fd_src buffer 0) (String.length buffer) + (fun e -> `ErrorRead(fn_src, e)); + !read <> 0) do + let written = + handle_exception + (Unix.write fd_dst buffer 0) !read + (fun e -> `ErrorWrite(fn_dst, e)) + in + if written != !read then + handle_error (`PartialWrite(fn_src, !read, written)) + done; + Unix.close fd_src; + Unix.close fd_dst; + copy_time_props st_src fn_dst + with e -> + Unix.close fd_src; + raise e + with e -> + Unix.close fd_dst; + raise e + in + + let cp_symlink fn_src fn_dst = + (* No Unix.lutimes to set time of the symlink. *) + Unix.symlink (Unix.readlink fn_src) fn_dst + in + + let rec cp_dir st_src dst_exists fn_src fn_dst = + (* 2a *) + if not recurse then begin + handle_error (`CannotCopyDir fn_src) + (* 2d, 2c *) + end else if dst_exists && (stat fn_dst).kind <> Dir then begin + handle_error (`DstDirNotDir fn_dst) + end else begin + (* 2e *) + let dst_created = + if not dst_exists then begin + let mode = + let src_mode = int_of_permission st_src.permission in + let dst_mode = + if preserve then src_mode else umask_apply src_mode + in + `Octal (dst_mode lor 0o0700) + in + handle_exception + (fun fn -> mkdir ~mode fn) fn_dst + (fun e -> `CannotCreateDir(fn_dst, e)); + true + end else begin + false + end + in + (* 2f *) + Array.iter + (fun bn -> + if not (is_current bn || is_parent bn) then + cp_one (concat fn_src bn) (concat fn_dst bn)) + (handle_exception + Sys.readdir fn_src + (fun e -> `CannotListSrcDir(fn_src, e))); + (* 2g *) + if dst_created then begin + let mode = + let src_mode = int_of_permission st_src.permission in + `Octal (if preserve then src_mode else umask_apply src_mode) + in + handle_exception + (chmod mode) [fn_dst] + (fun e -> `CannotChmodDstDir(fn_dst, e)); + copy_time_props st_src fn_dst + end + end + + and cp_one fn_src fn_dst = + let st_src, st_src_deref = + (* Check existence of source files. *) + if test_exists fn_src then begin + let st = stat fn_src in + if st.kind = Symlink && not recurse then begin + st, stat ~dereference:true fn_src + end else begin + st, st + end + end else begin + handle_error (`NoSourceFile fn_src) + end + in + + let same_file, dst_exists = + (* Test if fn_dst exists and if it is the same file as fn_src. *) + try + same_file st_src (stat fn_dst), true + with FileDoesntExist _ -> + false, false + in + + if same_file then begin + handle_error (`SameFile(fn_src, fn_dst)) + end; + try + match st_src.kind with + | Dir -> cp_dir st_src dst_exists fn_src fn_dst + | File -> cp_file st_src dst_exists fn_src fn_dst + | Symlink -> + if st_src_deref.kind = Dir || recurse then + cp_symlink fn_src fn_dst + else + cp_file st_src_deref dst_exists fn_src fn_dst + | Fifo | Dev_char | Dev_block | Socket -> + handle_error (`UnhandledType(fn_src, st_src.kind)) + with CpSkip -> + () + in + if test Is_dir fln_dst then + List.iter + (fun fn_src -> + cp_one fn_src (concat fln_dst (basename fn_src))) + fln_src_lst + else if List.length fln_src_lst <= 1 then + List.iter + (fun fn_src -> cp_one fn_src fln_dst) + fln_src_lst + else + handle_error (`CannotCopyFilesToFile(fln_src_lst, fln_dst)) diff --git a/src/FileUtilDU.ml b/src/FileUtilDU.ml new file mode 100644 index 0000000..fe5ec6f --- /dev/null +++ b/src/FileUtilDU.ml @@ -0,0 +1,37 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FileUtilSize +open FileUtilSTAT +open FileUtilFIND + + +let du fln_lst = + let du_aux (sz, lst) fln = + let st = stat fln in + (size_add sz st.size, (fln, st.size) :: lst) + in + List.fold_left + (fun accu fln -> find True fln du_aux accu) + (B 0L, []) + fln_lst + diff --git a/src/FileUtilFIND.ml b/src/FileUtilFIND.ml new file mode 100644 index 0000000..59760f1 --- /dev/null +++ b/src/FileUtilFIND.ml @@ -0,0 +1,123 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FilePath +open FileUtilMisc +open FileUtilTEST +open FileUtilSTAT +open FileUtilREADLINK + + +let find ?(follow=Skip) ?match_compile tst fln exec user_acc = + + let user_test = compile_filter ?match_compile tst in + + let skip_action = + match follow with + | Skip | AskFollow _ | Follow -> ignore + | SkipInform f -> f + in + + let should_skip fln already_followed = + match follow with + | Skip | SkipInform _ -> true + | AskFollow f -> + if not already_followed then + f fln + else + true + | Follow -> + if already_followed then + raise (RecursiveLink fln) + else + false + in + + let already_read = ref SetFilename.empty in + + let rec find_aux acc fln = + let st_opt = + try + Some (stat fln) + with FileDoesntExist _ -> + None + in + let stL_opt = + match st_opt with + | Some st when st.is_link -> + begin + try + Some (stat ~dereference:true fln) + with FileDoesntExist _ -> + None + end + | _ -> + st_opt + in + let acc = + if user_test ?st_opt ?stL_opt fln then + exec acc fln + else + acc + in + match st_opt with + | Some st -> + if st.kind = Symlink then begin + follow_symlink stL_opt acc fln + end else if st.kind = Dir then begin + enter_dir acc fln + end else begin + acc + end + | None -> acc + + and enter_dir acc drn = + Array.fold_left + (fun acc rfln -> + if is_parent rfln || is_current rfln then + acc + else + find_aux acc (concat drn rfln)) + acc + (Sys.readdir drn) + + and follow_symlink stL_opt acc fln = + match stL_opt with + | Some stL when stL.kind = Dir -> + let cur_link = readlink fln in + let already_followed = + try + already_read := prevent_recursion !already_read cur_link; + false + with RecursiveLink _ -> + true + in + if should_skip fln already_followed then begin + skip_action fln; + acc + end else begin + enter_dir acc fln + end + | _ -> + acc + in + find_aux user_acc (reduce fln) diff --git a/src/FileUtilLS.ml b/src/FileUtilLS.ml new file mode 100644 index 0000000..7190612 --- /dev/null +++ b/src/FileUtilLS.ml @@ -0,0 +1,30 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilMisc + + +let ls dirname = + let array_dir = Sys.readdir (solve_dirname dirname) in + let list_dir = Array.to_list array_dir in + List.map + (fun x -> FilePath.concat dirname x) + list_dir diff --git a/src/FileUtilMKDIR.ml b/src/FileUtilMKDIR.ml new file mode 100644 index 0000000..cffd639 --- /dev/null +++ b/src/FileUtilMKDIR.ml @@ -0,0 +1,92 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FilePath +open FileUtilMisc +open FileUtilTEST +open FileUtilUMASK +open FileUtilCHMOD + +exception MkdirError of string + +type mkdir_error = + [ `DirnameAlreadyUsed of filename + | `Exc of exn + | `MissingComponentPath of filename + | `MkdirChmod of filename * Unix.file_perm * string * exc ] + + +let mkdir + ?(error=(fun str _ -> raise (MkdirError str))) + ?(parent=false) + ?mode dn = + let handle_error, handle_exception = + handle_error_gen "mkdir" error + (function + | `DirnameAlreadyUsed fn -> + Printf.sprintf "Directory %s already exists and is a file." fn + | `MissingComponentPath fn -> + Printf.sprintf + "Unable to create directory %s, an upper directory is missing." + fn + | `MkdirChmod (dn, mode, str, e) -> + Printf.sprintf + "Recursive error in 'mkdir %s' in 'chmod %04o %s': %s" + dn mode dn str + | #exc -> "") + in + let mode_apply = + FileUtilMode.apply ~is_dir:true ~umask:(umask (`Octal (fun i -> i))) + in + let mode_self = + match mode with + | Some (`Octal m) -> m + | Some (`Symbolic t) -> mode_apply 0o777 t + | None -> umask_apply 0o0777 + in + let mode_parent = + umask + (`Symbolic + (fun t -> + mode_apply 0 (t @ [`User (`Add (`List [`Write; `Exec]))]))) + in + let rec mkdir_simple mode dn = + if test_exists dn then begin + if test (Not Is_dir) dn then + handle_error ~fatal:true (`DirnameAlreadyUsed dn); + end else begin + if parent then + mkdir_simple mode_parent (dirname dn); + try + Unix.mkdir dn mode; + chmod + ~error:(fun str e -> + handle_error ~fatal:true + (`MkdirChmod (dn, mode, str, e))) + (`Octal mode) [dn] + with Unix.Unix_error(Unix.ENOENT, _, _) + | Unix.Unix_error(Unix.ENOTDIR, _, _) -> + handle_error ~fatal:true (`MissingComponentPath dn) + | e -> handle_exception ~fatal:true e + end + in + mkdir_simple mode_self dn diff --git a/src/FileUtilMV.ml b/src/FileUtilMV.ml new file mode 100644 index 0000000..4383e79 --- /dev/null +++ b/src/FileUtilMV.ml @@ -0,0 +1,87 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FilePath +open FileUtilMisc +open FileUtilPWD +open FileUtilRM +open FileUtilCP +open FileUtilTEST + + +exception MvError of string + +type mv_error = + [ `Exc of exn + | `MvCp of filename * filename * string * cp_error + | `MvRm of filename * string * rm_error + | `NoSourceFile ] + + +let rec mv + ?(error=fun str _ -> raise (MvError str)) + ?(force=Force) + fln_src fln_dst = + let handle_error, _ = + handle_error_gen "mv" error + (function + | `NoSourceFile -> + "Cannot move an empty list of files." + | `MvCp (fn_src, fn_dst, str, _) -> + Printf.sprintf + "Recursive error in 'mv %s %s' for 'cp %s %s': %s" + fn_src fn_dst fn_src fn_dst str + | `MvRm (fn, str, _) -> + Printf.sprintf "Recursive error in 'mv %s ..' for 'rm %s': %s" + fn fn str + | #exc -> "") + in + let fln_src_abs = make_absolute (pwd ()) fln_src in + let fln_dst_abs = make_absolute (pwd ()) fln_dst in + if compare fln_src_abs fln_dst_abs <> 0 then begin + if test_exists fln_dst_abs && doit force fln_dst then begin + rm [fln_dst_abs]; + mv fln_src_abs fln_dst_abs + end else if test Is_dir fln_dst_abs then begin + mv ~force ~error + fln_src_abs + (make_absolute + fln_dst_abs + (basename fln_src_abs)) + end else if test_exists fln_src_abs then begin + try + Sys.rename fln_src_abs fln_dst_abs + with Sys_error _ -> + cp ~force + ~error:(fun str e -> + handle_error ~fatal:true + (`MvCp (fln_src_abs, fln_dst_abs, str, e))) + ~recurse:true [fln_src_abs] fln_dst_abs; + rm ~force + ~error:(fun str e -> + handle_error ~fatal:true + (`MvRm (fln_src_abs, str, e))) + ~recurse:true [fln_src_abs] + end else + handle_error ~fatal:true `NoSourceFile + end + diff --git a/src/FileUtilMisc.ml b/src/FileUtilMisc.ml new file mode 100644 index 0000000..f476517 --- /dev/null +++ b/src/FileUtilMisc.ml @@ -0,0 +1,79 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FilePath + +module SetFilename = Set.Make (struct + type t = filename + let compare = FilePath.compare +end) + + +let doit force fln = + match force with + Force -> true + | Ask ask -> ask fln + + +let prevent_recursion fln_set fln = + (* TODO: use a set of dev/inode *) + if SetFilename.mem fln fln_set then + raise (RecursiveLink fln) + else + SetFilename.add fln fln_set + + +let solve_dirname dirname = + (* We have an ambiguity concerning "" and "." *) + if is_current dirname then + current_dir + else + reduce dirname + + +type exc = [ `Exc of exn ] + + +let handle_error_gen nm error custom = + let handle_error ~fatal e = + let str = + match e with + | `Exc (Unix.Unix_error(err, nm, arg)) -> + Printf.sprintf "%s: %s (%s, %S)" nm (Unix.error_message err) nm arg + | `Exc exc -> + Printf.sprintf "%s: %s" nm (Printexc.to_string exc) + | e -> custom e + in + if fatal then begin + try + error str e; + raise (Fatal str) + with exc -> + raise exc + end else begin + error str e + end + in + let handle_exception ~fatal exc = + handle_error ~fatal (`Exc exc) + in + handle_error, handle_exception diff --git a/src/FileUtilMode.ml b/src/FileUtilMode.ml new file mode 100644 index 0000000..71824f2 --- /dev/null +++ b/src/FileUtilMode.ml @@ -0,0 +1,239 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +type who = [`User | `Group | `Other | `All] +type wholist = [ who | `List of who list ] +type permcopy = [`User | `Group | `Other] +type perm = [ `Read | `Write | `Exec | `ExecX | `Sticky | `StickyO ] +type permlist = [ perm | `List of perm list ] +type actionarg = [ permlist | permcopy ] +type action = [ `Set of actionarg | `Add of actionarg | `Remove of actionarg] +type actionlist = [ action | `List of action list ] +type clause = [ `User of actionlist | `Group of actionlist + | `Other of actionlist | `All of actionlist + | `None of actionlist ] + +type t = clause list + + +let all_masks = + [ + `User, `Sticky, 0o4000; + `User, `Exec, 0o0100; + `User, `Write, 0o0200; + `User, `Read, 0o0400; + `Group, `Sticky, 0o2000; + `Group, `Exec, 0o0010; + `Group, `Write, 0o0020; + `Group, `Read, 0o0040; + `Other, `StickyO, 0o1000; + `Other, `Exec, 0o0001; + `Other, `Write, 0o0002; + `Other, `Read, 0o0004; + ] + + +let mask = + let module M = + Map.Make + (struct + type t = who * perm + let compare = Pervasives.compare + end) + in + let m = + List.fold_left + (fun m (who, prm, msk) -> M.add (who, prm) msk m) + M.empty all_masks + in + fun who prm -> + try + M.find (who, prm) m + with Not_found -> + 0 + + +let of_int i = + let user, group, other = + List.fold_left + (fun (user, group, other) (who, perm, mask) -> + if (i land mask) <> 0 then begin + match who with + | `User -> perm :: user, group, other + | `Group -> user, perm :: group, other + | `Other -> user, group, perm :: other + end else begin + (user, group, other) + end) + ([], [], []) + all_masks + in + [`User (`Set (`List user)); + `Group (`Set (`List group)); + `Other (`Set (`List other))] + + +let to_string = + let perm = + function + | `Read -> "r" + | `Write -> "w" + | `Exec -> "x" + | `Sticky -> "s" + | `ExecX -> "X" + | `StickyO -> "t" + in + let permlist = + function + | `List lst -> String.concat "" (List.map perm lst) + | #perm as prm -> perm prm + in + let permcopy = + function + | `User -> "u" + | `Group -> "g" + | `Other -> "o" + in + let action act = + let sact, arg = + match act with + | `Set arg -> "=", arg + | `Add arg -> "+", arg + | `Remove arg -> "-", arg + in + let sarg = + match arg with + | #permlist as lst -> permlist lst + | #permcopy as prm -> permcopy prm + in + sact^sarg + in + let actionlist = + function + | `List lst -> String.concat "" (List.map action lst) + | #action as act -> action act + in + let clause cls = + let swho, lst = + match cls with + | `User lst -> "u", lst + | `Group lst -> "g", lst + | `Other lst -> "o", lst + | `All lst -> "a", lst + | `None lst -> "", lst + in + swho^(actionlist lst) + in + fun t -> String.concat "," (List.map clause t) + + +let apply ~is_dir ~umask i (t: t) = + let set who prm b i = + let m = mask who prm in + if b then i lor m else i land (lnot m) + in + let get who prm i = + let m = mask who prm in + (i land m) <> 0 + in + let permlist _who i lst = + List.fold_left + (fun acc -> + function + | `Exec | `Read | `Write | `Sticky | `StickyO as a -> a :: acc + | `ExecX -> + if is_dir || + List.exists (fun who -> get who `Exec i) + [`User; `Group; `Other] then + `Exec :: acc + else + acc) + [] + (match lst with + | `List lst -> lst + | #perm as prm -> [prm]) + in + let permcopy _who i = + List.fold_left + (fun acc (who, prm, _) -> + if get who prm i then + prm :: acc + else + acc) + [] all_masks + in + let args who i = + function + | #permlist as lst -> permlist who i lst + | #permcopy as who -> permcopy who i + in + let rec action who i act = + match act with + | `Set arg -> + action who + (action who i (`Remove (`List (permcopy who i)))) + (`Add arg) + | `Add arg -> + List.fold_left (fun i prm -> set who prm true i) i (args who i arg) + | `Remove arg -> + List.fold_left (fun i prm -> set who prm false i) i (args who i arg) + in + let actionlist who i lst = + match lst with + | `List lst -> List.fold_left (action who) i lst + | #action as act -> action who i act + in + let actionlist_none i lst = + let numask = lnot umask in + let arg_set_if_mask who i arg b = + List.fold_left + (fun i prm -> + if get who prm numask then + set who prm b i + else + i) + i (args who i arg) + in + List.fold_left + (fun i who -> + List.fold_left + (fun i -> + function + | `Set _ -> i + | `Add arg -> arg_set_if_mask who i arg true + | `Remove arg -> arg_set_if_mask who i arg false) + i + (match lst with + | `List lst -> lst + | #action as act -> [act])) + i [`User; `Group; `Other] + in + + let rec clause i cls = + match cls with + | `User lst -> actionlist `User i lst + | `Group lst -> actionlist `Group i lst + | `Other lst -> actionlist `Other i lst + | `All lst -> + List.fold_left clause i [`User lst; `Group lst; `Other lst] + | `None lst -> actionlist_none i lst + in + List.fold_left clause i t diff --git a/src/FileUtilPWD.ml b/src/FileUtilPWD.ml new file mode 100644 index 0000000..e97cd06 --- /dev/null +++ b/src/FileUtilPWD.ml @@ -0,0 +1,22 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +let pwd () = FilePath.reduce (Sys.getcwd ()) diff --git a/src/FileUtilPermission.ml b/src/FileUtilPermission.ml new file mode 100644 index 0000000..f82bae2 --- /dev/null +++ b/src/FileUtilPermission.ml @@ -0,0 +1,75 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes + + +let permission_of_int pr = + let perm_match oct = + (pr land oct) <> 0 + in + { + user = + { + sticky = perm_match 0o4000; + exec = perm_match 0o0100; + write = perm_match 0o0200; + read = perm_match 0o0400; + }; + group = + { + sticky = perm_match 0o2000; + exec = perm_match 0o0010; + write = perm_match 0o0020; + read = perm_match 0o0040; + }; + other = + { + sticky = perm_match 0o1000; + exec = perm_match 0o0001; + write = perm_match 0o0002; + read = perm_match 0o0004; + }; + } + + +let int_of_permission pr = + let permission_int = [ + (pr.user.sticky, 0o4000); + (pr.user.exec, 0o0100); + (pr.user.write, 0o0200); + (pr.user.read, 0o0400); + (pr.group.sticky, 0o2000); + (pr.group.exec, 0o0010); + (pr.group.write, 0o0020); + (pr.group.read, 0o0040); + (pr.other.sticky, 0o1000); + (pr.other.exec, 0o0001); + (pr.other.write, 0o0002); + (pr.other.read, 0o0004) + ] + in + List.fold_left (fun full_perm (b, perm) -> + if b then + perm lor full_perm + else + full_perm) + 0o0000 permission_int diff --git a/src/FileUtilREADLINK.ml b/src/FileUtilREADLINK.ml new file mode 100644 index 0000000..99eef1a --- /dev/null +++ b/src/FileUtilREADLINK.ml @@ -0,0 +1,61 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FilePath +open FileUtilMisc +open FileUtilPWD +open FileUtilTEST + + +let readlink fln = + let all_upper_dir fln = + let rec all_upper_dir_aux lst fln = + let dir = dirname fln in + match lst with + | prev_dir :: _ when prev_dir = dir -> lst + | _ -> all_upper_dir_aux (dir :: lst) dir + in + all_upper_dir_aux [fln] fln + in + let ctst = + let st_opt, stL_opt = None, None in + compile_filter ?st_opt ?stL_opt Is_link + in + let rec readlink_aux already_read fln = + let newly_read = prevent_recursion already_read fln in + let dirs = all_upper_dir fln in + try + let src_link = List.find ctst (List.rev dirs) in + let dst_link = Unix.readlink src_link in + let real_link = + if is_relative dst_link then + reduce (concat (dirname src_link) dst_link) + else + reduce dst_link + in + readlink_aux newly_read (reparent src_link real_link fln) + with Not_found -> + fln + in + readlink_aux SetFilename.empty (make_absolute (pwd ()) fln) + + diff --git a/src/FileUtilRM.ml b/src/FileUtilRM.ml new file mode 100644 index 0000000..0bc7e1d --- /dev/null +++ b/src/FileUtilRM.ml @@ -0,0 +1,84 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FilePath +open FileUtilMisc +open FileUtilTEST +open FileUtilLS + +exception RmError of string + +type rm_error = + [ `DirNotEmpty of filename + | `Exc of exn + | `NoRecurse of filename ] + + +let rm + ?(error=fun str _ -> raise (RmError str)) + ?(force=Force) + ?(recurse=false) + fln_lst = + let handle_error, handle_exception = + handle_error_gen "rm" error + (function + | `DirNotEmpty fn -> + Printf.sprintf "Directory %s not empty." fn + | `NoRecurse fn -> + Printf.sprintf + "Cannot delete directory %s when recurse is not set." + fn + | #exc -> "") + in + let test_dir = test (And(Is_dir, Not(Is_link))) in + let rmdir fn = + try + Unix.rmdir fn + with + | Unix.Unix_error(Unix.ENOTEMPTY, _, _) -> + handle_error ~fatal:true (`DirNotEmpty fn) + | e -> + handle_exception ~fatal:true e + in + let rec rm_aux lst = + List.iter + (fun fn -> + let exists = + try + let _st: Unix.LargeFile.stats = Unix.LargeFile.lstat fn in + true + with Unix.Unix_error(Unix.ENOENT, _, _) -> + false + in + if exists && (doit force fn) then begin + if test_dir fn then begin + if recurse then begin + rm_aux (ls fn); + rmdir fn + end else + handle_error ~fatal:true (`NoRecurse fn) + end else + Unix.unlink fn + end) + lst + in + rm_aux fln_lst diff --git a/src/FileUtilSTAT.ml b/src/FileUtilSTAT.ml new file mode 100644 index 0000000..a562ba0 --- /dev/null +++ b/src/FileUtilSTAT.ml @@ -0,0 +1,61 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FileUtilPermission + + +let stat ?(dereference=false) fln = + let kind_of_stat ustat = + match ustat.Unix.LargeFile.st_kind with + | Unix.S_REG -> File + | Unix.S_DIR -> Dir + | Unix.S_CHR -> Dev_char + | Unix.S_BLK -> Dev_block + | Unix.S_FIFO -> Fifo + | Unix.S_SOCK -> Socket + | Unix.S_LNK -> Symlink + in + try + let ustat = Unix.LargeFile.lstat fln in + let is_link = (kind_of_stat ustat = Symlink) in + let ustat = + if is_link && dereference then + Unix.LargeFile.stat fln + else + ustat + in + { + kind = kind_of_stat ustat; + is_link = is_link; + permission = permission_of_int ustat.Unix.LargeFile.st_perm; + size = B ustat.Unix.LargeFile.st_size; + owner = ustat.Unix.LargeFile.st_uid; + group_owner = ustat.Unix.LargeFile.st_gid; + access_time = ustat.Unix.LargeFile.st_atime; + modification_time = ustat.Unix.LargeFile.st_mtime; + creation_time = ustat.Unix.LargeFile.st_ctime; + device = ustat.Unix.LargeFile.st_dev; + inode = ustat.Unix.LargeFile.st_ino; + } + with Unix.Unix_error(Unix.ENOENT, _, _) -> + raise (FileDoesntExist fln) + diff --git a/src/FileUtilSize.ml b/src/FileUtilSize.ml new file mode 100644 index 0000000..0350047 --- /dev/null +++ b/src/FileUtilSize.ml @@ -0,0 +1,150 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes + +let byte_of_size sz = + let rec mul_1024 n i = + if n > 0 then + mul_1024 + (n - 1) + (Int64.mul 1024L i) + else + i + in + match sz with + | B i -> i + | KB i -> mul_1024 1 i + | MB i -> mul_1024 2 i + | GB i -> mul_1024 3 i + | TB i -> mul_1024 4 i + + +let size_add sz1 sz2 = + B (Int64.add (byte_of_size sz1) (byte_of_size sz2)) + + +let size_compare ?(fuzzy=false) sz1 sz2 = + let by1 = + byte_of_size sz1 + in + let by2 = + byte_of_size sz2 + in + if fuzzy then begin + let rec fuzzy_comp n1 n2 = + if n1 = n2 then + 0 + else begin + let up_unit_n1 = + Int64.div n1 1024L + in + let up_unit_n2 = + Int64.div n2 1024L + in + if up_unit_n1 <> 0L && up_unit_n2 <> 0L then + fuzzy_comp up_unit_n1 up_unit_n2 + else + Int64.compare n1 n2 + end + in + fuzzy_comp by1 by2 + end else + Int64.compare by1 by2 + + +let string_of_size ?(fuzzy=false) sz = + let szstr i unt (cur_i, cur_unt, tl) = + let tl = + (cur_i, cur_unt) :: tl + in + i, unt, tl + in + + let rec decomp_continue fup i unt acc = + if i = 0L then + szstr i unt acc + else begin + (** Continue with upper unit *) + let r = + Int64.rem i 1024L + in + let q = + Int64.div i 1024L + in + decomp_start (szstr r unt acc) (fup q) + end + + and decomp_start acc sz = + (* Decompose size for current unit and try + * to use upper unit + *) + match sz with + | TB i -> + szstr i "TB" acc + | GB i -> + decomp_continue (fun n -> TB n) i "GB" acc + | MB i -> + decomp_continue (fun n -> GB n) i "MB" acc + | KB i -> + decomp_continue (fun n -> MB n) i "KB" acc + | B i -> + decomp_continue (fun n -> KB n) i "B" acc + in + + (* Only accumulate significant unit in tail *) + let only_significant_unit (cur_i, cur_unt, lst) = + let significant_lst = + List.filter + (fun (i, _) -> i <> 0L) + ((cur_i, cur_unt) :: lst) + in + match significant_lst with + | [] -> cur_i, cur_unt, [] + | (cur_i, cur_unt) :: tl -> (cur_i, cur_unt, tl) + in + + let main_i, main_unt, rem_lst = + only_significant_unit (decomp_start (0L, "B", []) sz) + in + + if fuzzy then begin + let _, rem = + List.fold_left + (fun (div, acc) (i, _unt) -> + let acc = + acc +. ((Int64.to_float i) /. div) + in + div *. 1024.0, + acc) + (1024.0, 0.0) + rem_lst + in + Printf.sprintf "%.2f %s" + ((Int64.to_float main_i) +. rem) + main_unt + end else begin + String.concat + " " + (List.map + (fun (i, unt) -> Printf.sprintf "%Ld %s" i unt) + ((main_i, main_unt) :: rem_lst)) + end diff --git a/src/FileUtilStr.ml b/src/FileUtilStr.ml new file mode 100644 index 0000000..64ae2a9 --- /dev/null +++ b/src/FileUtilStr.ml @@ -0,0 +1,40 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +(** FileUtil with Str regexp match test + @author Sylvain Le Gall + *) + +(** Compile [FileUtil.Match] expression using [Str.regexp] + *) +let match_compile str = + let regex = Str.regexp str in + fun fn -> Str.string_match regex fn 0 + + +(** See {!FileUtil.test} + *) +let test = FileUtil.test ~match_compile:match_compile + + +(** See {!FileUtil.find} + *) +let find = FileUtil.find ~match_compile:match_compile diff --git a/src/FileUtilTEST.ml b/src/FileUtilTEST.ml new file mode 100644 index 0000000..24b0058 --- /dev/null +++ b/src/FileUtilTEST.ml @@ -0,0 +1,215 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FilePath +open FileUtilMisc +open FileUtilSize +open FileUtilSTAT + + +let compile_filter ?(match_compile=(fun s fn -> s = fn)) flt = + let cflt = + let rec cc = + function + | True -> `Val true + | False -> `Val false + | Is_dev_block -> `Stat (`Kind Dev_block) + | Is_dev_char -> `Stat (`Kind Dev_char) + | Is_dir -> `Stat (`Kind Dir) + | Is_file -> `Stat (`Kind File) + | Is_socket -> `Stat (`Kind Socket) + | Is_pipe -> `Stat (`Kind Fifo) + | Is_link -> `Is_link + | Is_set_group_ID -> `Stat `Is_set_group_ID + | Has_sticky_bit -> `Stat `Has_sticky_bit + | Has_set_user_ID -> `Stat `Has_set_user_ID + | Is_readable -> `Stat `Is_readable + | Is_writeable -> `Stat `Is_writeable + | Is_exec -> `Stat `Is_exec + | Size_not_null -> `Stat (`Size (`Bigger, B 0L)) + | Size_bigger_than sz -> `Stat (`Size (`Bigger, sz)) + | Size_smaller_than sz -> `Stat (`Size (`Smaller, sz)) + | Size_equal_to sz -> `Stat (`Size (`Equal, sz)) + | Size_fuzzy_equal_to sz -> `Stat (`Size (`FuzzyEqual, sz)) + | Is_owned_by_user_ID -> + `Stat (`Is_owned_by_user_ID (Unix.geteuid ())) + | Is_owned_by_group_ID -> + `Stat (`Is_owned_by_group_ID (Unix.getegid ())) + | Exists -> `Stat `Exists + | Is_newer_than fn1 -> `Stat (`Newer (stat fn1).modification_time) + | Is_older_than fn1 -> `Stat (`Older (stat fn1).modification_time) + | Is_newer_than_date(dt) -> `Stat (`Newer dt) + | Is_older_than_date(dt) -> `Stat (`Older dt) + | Has_extension ext -> `Has_extension ext + | Has_no_extension -> `Has_no_extension + | Is_current_dir -> `Is_current_dir + | Is_parent_dir -> `Is_parent_dir + | Basename_is s -> `Basename_is s + | Dirname_is s -> `Dirname_is s + | Custom f -> `Custom f + | Match str -> `Custom (match_compile str) + | And(flt1, flt2) -> + begin + match cc flt1, cc flt2 with + | `Val true, cflt | cflt, `Val true -> cflt + | `Val false, _ | _, `Val false -> `Val false + | cflt1, cflt2 -> `And (cflt1, cflt2) + end + | Or(flt1, flt2) -> + begin + match cc flt1, cc flt2 with + | `Val true, _ | _, `Val true -> `Val true + | `Val false, cflt | cflt, `Val false -> cflt + | cflt1, cflt2 -> `Or (cflt1, cflt2) + end + | Not flt -> + begin + match cc flt with + | `Val b -> `Val (not b) + | cflt -> `Not cflt + end + in + cc flt + in + let need_statL, need_stat = + let rec dfs = + function + | `Val _ | `Has_extension _ | `Has_no_extension | `Is_current_dir + | `Is_parent_dir | `Basename_is _ | `Dirname_is _ + | `Custom _ -> + false, false + | `Stat _ -> + true, false + | `Is_link -> + false, true + | `And (cflt1, cflt2) | `Or (cflt1, cflt2) -> + let need_stat1, need_statL1 = dfs cflt1 in + let need_stat2, need_statL2 = dfs cflt2 in + need_stat1 || need_stat2, need_statL1 || need_statL2 + | `Not cflt -> + dfs cflt + in + dfs cflt + in + (* Compiled function to return. *) + fun ?st_opt ?stL_opt fn -> + let st_opt = + if need_stat && st_opt = None then begin + try + match stL_opt with + | Some st when not st.is_link -> stL_opt + | _ -> Some (stat fn) + with FileDoesntExist _ -> + None + end else + st_opt + in + let stL_opt = + if need_statL && stL_opt = None then begin + try + match st_opt with + | Some st when not st.is_link -> st_opt + | _ -> Some (stat ~dereference:true fn) + with FileDoesntExist _ -> + None + end else + stL_opt + in + let rec eval = + function + | `Val b -> b + | `Has_extension ext -> + begin + try + check_extension fn ext + with FilePath.NoExtension _ -> + false + end + | `Has_no_extension -> + begin + try + let _str: filename = chop_extension fn in + false + with FilePath.NoExtension _ -> + true + end + | `Is_current_dir -> is_current (basename fn) + | `Is_parent_dir -> is_parent (basename fn) + | `Basename_is bn -> (FilePath.compare (basename fn) bn) = 0 + | `Dirname_is dn -> (FilePath.compare (dirname fn) dn) = 0 + | `Custom f -> f fn + | `Stat e -> + begin + match stL_opt, e with + | Some _, `Exists -> true + | Some stL, `Kind knd -> stL.kind = knd + | Some stL, `Is_set_group_ID -> stL.permission.group.sticky + | Some stL, `Has_sticky_bit -> stL.permission.other.sticky + | Some stL, `Has_set_user_ID -> stL.permission.user.sticky + | Some stL, `Size (cmp, sz) -> + begin + let diff = size_compare stL.size sz in + match cmp with + | `Bigger -> diff > 0 + | `Smaller -> diff < 0 + | `Equal -> diff = 0 + | `FuzzyEqual -> + (size_compare ~fuzzy:true stL.size sz) = 0 + end + | Some stL, `Is_owned_by_user_ID uid -> uid = stL.owner + | Some stL, `Is_owned_by_group_ID gid -> gid = stL.group_owner + | Some stL, `Is_readable -> + let perm = stL.permission in + perm.user.read || perm.group.read || perm.other.read + | Some stL, `Is_writeable -> + let perm = stL.permission in + perm.user.write || perm.group.write || perm.other.write + | Some stL, `Is_exec -> + let perm = stL.permission in + perm.user.exec || perm.group.exec || perm.other.exec + | Some stL, `Newer dt -> stL.modification_time > dt + | Some stL, `Older dt -> stL.modification_time < dt + | None, _ -> false + end + | `Is_link -> + begin + match st_opt with + | Some st -> st.is_link + | None -> false + end + | `And (cflt1, cflt2) -> (eval cflt1) && (eval cflt2) + | `Or (cflt1, cflt2) -> (eval cflt1) || (eval cflt2) + | `Not cflt -> not (eval cflt) + in + eval cflt + + +let test ?match_compile tst = + let ctst = compile_filter ?match_compile tst in + fun fln -> ctst (solve_dirname fln) + + +let filter flt lst = List.filter (test flt) lst + + +let test_exists = test (Or(Exists, Is_link)) + diff --git a/src/FileUtilTOUCH.ml b/src/FileUtilTOUCH.ml new file mode 100644 index 0000000..81c4c6a --- /dev/null +++ b/src/FileUtilTOUCH.ml @@ -0,0 +1,63 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FileUtilSTAT +open FileUtilTEST + + +let touch ?atime ?mtime ?(create=true) ?(time=Touch_now) fln = + + let atime, mtime = + match atime, mtime with + | None, None -> true, true + | Some b, None -> b, false + | None, Some b -> false, b + | Some b1, Some b2 -> b1, b2 + in + + let set_time () = + let fatime, fmtime = + match time with + | Touch_now -> 0.0, 0.0 + | Touch_timestamp time_ref -> time_ref, time_ref + | Touch_file_time fln_ref -> + let st = stat fln_ref in + st.access_time, st.modification_time + in + let fatime, fmtime = + if not (atime && mtime) then begin + let st = stat fln in + (if atime then fatime else st.access_time), + (if mtime then fmtime else st.modification_time) + end else begin + fatime, fmtime + end + in + Unix.utimes fln fatime fmtime + in + (* Create file if required *) + if test_exists fln then begin + set_time () + end else if create then begin + close_out (open_out fln); + set_time () + end diff --git a/src/FileUtilTypes.ml b/src/FileUtilTypes.ml new file mode 100644 index 0000000..4197f6a --- /dev/null +++ b/src/FileUtilTypes.ml @@ -0,0 +1,145 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FilePath + +exception FileDoesntExist of filename +exception RecursiveLink of filename +exception Fatal of string + +(** See FileUtil.mli *) +type action_link = + | Follow + | Skip + | SkipInform of (filename -> unit) + | AskFollow of (filename -> bool) + + +(** See FileUtil.mli *) +type interactive = + Force + | Ask of (filename -> bool) + + +(** See FileUtil.mli *) +type size = + TB of int64 + | GB of int64 + | MB of int64 + | KB of int64 + | B of int64 + + +(** See FileUtil.mli *) +type kind = + Dir + | File + | Dev_char + | Dev_block + | Fifo + | Socket + | Symlink + + +(** See FileUtil.mli *) +type base_permission = + { + sticky: bool; + exec: bool; + write: bool; + read: bool; + } + + +(** See FileUtil.mli *) +type permission = + { + user: base_permission; + group: base_permission; + other: base_permission; + } + + +(** See FileUtil.mli *) +type stat = + { + kind: kind; + is_link: bool; + permission: permission; + size: size; + owner: int; + group_owner: int; + access_time: float; + modification_time: float; + creation_time: float; + device: int; + inode: int; + } + + +(** See FileUtil.mli *) +type test_file = + | Is_dev_block + | Is_dev_char + | Is_dir + | Exists + | Is_file + | Is_set_group_ID + | Has_sticky_bit + | Is_link + | Is_pipe + | Is_readable + | Is_writeable + | Size_not_null + | Size_bigger_than of size + | Size_smaller_than of size + | Size_equal_to of size + | Size_fuzzy_equal_to of size + | Is_socket + | Has_set_user_ID + | Is_exec + | Is_owned_by_user_ID + | Is_owned_by_group_ID + | Is_newer_than of filename + | Is_older_than of filename + | Is_newer_than_date of float + | Is_older_than_date of float + | And of test_file * test_file + | Or of test_file * test_file + | Not of test_file + | Match of string + | True + | False + | Has_extension of extension + | Has_no_extension + | Is_parent_dir + | Is_current_dir + | Basename_is of filename + | Dirname_is of filename + | Custom of (filename -> bool) + + +(** See FileUtil.mli *) +type touch_time_t = + | Touch_now + | Touch_file_time of filename + | Touch_timestamp of float + diff --git a/src/FileUtilUMASK.ml b/src/FileUtilUMASK.ml new file mode 100644 index 0000000..26d8f3e --- /dev/null +++ b/src/FileUtilUMASK.ml @@ -0,0 +1,76 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilMisc + +exception UmaskError of string + +type umask_error = [ `Exc of exn | `NoStickyBit of int ] + + +let umask + ?(error=(fun str _ -> raise (UmaskError str))) + ?mode out = + let handle_error, handle_exception = + handle_error_gen "umask" error + (function + | `NoStickyBit i -> + Printf.sprintf "Cannot set sticky bit in umask 0o%04o" i + | #exc -> "") + in + let complement i = 0o0777 land (lnot i) in + let try_umask i = + try + Unix.umask i + with e -> + handle_exception ~fatal:true e; + raise e + in + let get () = + let cmask = try_umask 0o777 in + let _mask: int = try_umask cmask in + cmask + in + let set i = + let eff_i = i land 0o777 in + let _i: int = + if i <> eff_i then + handle_error ~fatal:true (`NoStickyBit i); + try_umask eff_i + in + eff_i + in + let v = + match mode with + | Some (`Symbolic s) -> + let v = get () in + set + (complement + (FileUtilMode.apply ~is_dir:false ~umask:0 (complement v) s)) + | Some (`Octal i) -> set i + | None -> get () + in + match out with + | `Symbolic f -> f (FileUtilMode.of_int (0o0777 land (lnot v))) + | `Octal f -> f v + + +let umask_apply m = m land (lnot (umask (`Octal (fun i -> i)))) diff --git a/src/FileUtilWHICH.ml b/src/FileUtilWHICH.ml new file mode 100644 index 0000000..b7babba --- /dev/null +++ b/src/FileUtilWHICH.ml @@ -0,0 +1,89 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FileUtilTypes +open FilePath +open FileUtilTEST + + +let which ?(path) fln = + let real_path = + match path with + | None -> + path_of_string + (try + Sys.getenv "PATH" + with Not_found -> + "") + | Some x -> + x + in + let exec_test = test (And(Is_exec, Is_file)) in + let which_path = + match Sys.os_type with + | "Win32" -> + begin + let real_ext = + List.map + (fun dot_ext -> + (* Remove leading "." if it exists *) + if (String.length dot_ext) >= 1 && dot_ext.[0] = '.' then + String.sub dot_ext 1 ((String.length dot_ext) - 1) + else + dot_ext) + (* Extract possible extension from PATHEXT *) + (path_of_string + (try + Sys.getenv "PATHEXT" + with Not_found -> + "")) + in + let to_filename dirname ext = add_extension (concat dirname fln) ext in + let ctst dirname ext = exec_test (to_filename dirname ext) in + List.fold_left + (fun found dirname -> + if found = None then begin + try + let ext = List.find (ctst dirname) real_ext in + Some (to_filename dirname ext) + with Not_found -> + None + end else + found) + None + real_path + end + | _ -> + begin + let to_filename dirname = concat dirname fln in + try + Some + (to_filename + (List.find + (fun dirname -> + exec_test (to_filename dirname)) real_path)) + with Not_found -> + None + end + in + match which_path with + | Some fn -> fn + | None -> raise Not_found diff --git a/src/META b/src/META new file mode 100644 index 0000000..dd8ded3 --- /dev/null +++ b/src/META @@ -0,0 +1,22 @@ +# OASIS_START +# DO NOT EDIT (digest: 2980041ae6b330235ad5dc97a9a5f896) +version = "0.5.2" +description = "Functions to manipulate real file (POSIX like) and filename." +requires = "unix" +archive(byte) = "fileutils.cma" +archive(byte, plugin) = "fileutils.cma" +archive(native) = "fileutils.cmxa" +archive(native, plugin) = "fileutils.cmxs" +exists_if = "fileutils.cma" +package "str" ( + version = "0.5.2" + description = "Functions to manipulate real file (POSIX like) and filename." + requires = "fileutils str" + archive(byte) = "fileutils-str.cma" + archive(byte, plugin) = "fileutils-str.cma" + archive(native) = "fileutils-str.cmxa" + archive(native, plugin) = "fileutils-str.cmxs" + exists_if = "fileutils-str.cma" +) +# OASIS_STOP + diff --git a/src/MacOSPath.ml b/src/MacOSPath.ml new file mode 100644 index 0000000..a7358a3 --- /dev/null +++ b/src/MacOSPath.ml @@ -0,0 +1,75 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FilePath_type + +include CommonPath + + +let dir_writer lst = + let buffer = Buffer.create path_length in + let rec dir_writer_aux lst = + match lst with + Root s :: tl -> + Buffer.add_string buffer s; + Buffer.add_char buffer ':'; + dir_writer_aux tl + | (CurrentDir _) :: tl + | ParentDir :: tl -> + Buffer.add_char buffer ':'; + dir_writer_aux tl + | (Component "") :: tl -> + dir_writer_aux tl + | (Component s) :: [] -> + Buffer.add_string buffer s; + dir_writer_aux [] + | (Component s) :: tl -> + Buffer.add_string buffer s; + Buffer.add_char buffer ':'; + dir_writer_aux tl + | [] -> + Buffer.contents buffer + in + match lst with + ParentDir :: _ -> dir_writer_aux ( (CurrentDir Long) :: lst ) + | [ CurrentDir Short ] -> "" + | _ -> dir_writer_aux lst + + +let dir_reader str = + let rec dir_reader_aux = + function + | [""] -> [] + | "" :: tl -> ParentDir :: (dir_reader_aux tl) + | str :: tl -> Component str :: (dir_reader_aux tl) + | [] -> [] + in + match StringExt.split ~map:(fun s -> s) ':' str with + | [] -> [CurrentDir Short] + | "" :: tl -> CurrentDir Long :: (dir_reader_aux tl) + | [id] -> [Component id] + | root :: tl -> Root root :: (dir_reader_aux tl) + + +let path_writer lst = String.concat ";" lst + + +let path_reader = StringExt.split ~map:(fun s -> s) ';' diff --git a/src/UnixPath.ml b/src/UnixPath.ml new file mode 100644 index 0000000..8bec643 --- /dev/null +++ b/src/UnixPath.ml @@ -0,0 +1,127 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FilePath_type + +include CommonPath + + +let rec dir_writer lst = + match lst with + Root _ :: tl -> "/"^(dir_writer tl) + | [ CurrentDir Short ] -> "" + | lst -> + let dir_writer_aux cmp = + match cmp with + Root _ -> "" + | ParentDir -> ".." + | CurrentDir _ -> "." + | Component s -> s + in + String.concat "/" ( List.map dir_writer_aux lst ) + + +let dir_reader fn = + let sep = '/' in + let fn_part_of_string = + function + | "." -> CurrentDir Long + | ".." -> ParentDir + | str -> Component str + in + if (String.length fn) > 0 then begin + if fn.[0] = sep then + StringExt.split + ~start_acc:[Root ""] + ~start_pos:1 + ~map:fn_part_of_string + sep + fn + else + StringExt.split + ~map:fn_part_of_string + sep + fn + end else + [CurrentDir Short] + + +let path_writer lst = String.concat ":" lst + + +let path_reader str = StringExt.split ~map:(fun s -> s) ':' str + + +let fast_concat fn1 fn2 = + let fn1_len = String.length fn1 in + if fn1_len = 0 || fn1.[fn1_len - 1] = '/' then + fn1 ^ fn2 + else + fn1 ^ "/" ^ fn2 + + +let fast_basename fn = + try + let start_pos = (String.rindex fn '/') + 1 in + let fn_len = String.length fn in + if start_pos = fn_len then + "" + else + String.sub fn start_pos (fn_len - start_pos) + with Not_found -> + fn + + +let fast_dirname fn = + try + let last_pos = String.rindex fn '/' in + if last_pos = 0 then + "/" + else + String.sub fn 0 last_pos + with Not_found -> + "" + + +let fast_is_relative fn = + if String.length fn = 0 || fn.[0] <> '/' then + true + else + false + + +let fast_is_current fn = + if String.length fn = 0 || fn = "." then + true + else if fn.[0] <> '.' then + false + else + raise CannotHandleFast + + +let fast_is_parent fn = + if fn = ".." then + true + else if String.length fn < 2 || fn.[0] <> '.' || fn.[1] <> '.' then + false + else + raise CannotHandleFast + diff --git a/src/Win32Path.ml b/src/Win32Path.ml new file mode 100644 index 0000000..c576715 --- /dev/null +++ b/src/Win32Path.ml @@ -0,0 +1,72 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open FilePath_type + +include CommonPath + + +let rec dir_writer lst = + match lst with + Root s :: tl -> (s^":\\")^(dir_writer tl) + | [ CurrentDir Short ] -> "" + | lst -> + let dir_writer_aux cmp = + match cmp with + (* We should raise an exception here *) + Root s -> s + | ParentDir -> ".." + | CurrentDir _ -> "." + | Component s -> s + in + String.concat "\\" (List.map dir_writer_aux lst) + + +let dir_reader str = + let fn_part_of_string = + function + | ".." -> ParentDir + | "." -> CurrentDir Long + | str -> Component str + in + let fn_part_split str = + let lst = + List.flatten + (List.map + (StringExt.split ~map:fn_part_of_string '\\') + (StringExt.split ~map:(fun s -> s) '/' str)) + in + match lst with + (* TODO: we don't make the difference between c:a and c:\a *) + | Component "" :: tl -> tl + | lst -> lst + in + try + let drive_letter, str = StringExt.break_at_first ':' str in + Root drive_letter :: (fn_part_split str) + with Not_found -> + fn_part_split str + + +let path_writer lst = String.concat ";" lst + + +let path_reader str = StringExt.split ~map:(fun s -> s) ';' str diff --git a/src/api-fileutils.odocl b/src/api-fileutils.odocl new file mode 100644 index 0000000..2311bf7 --- /dev/null +++ b/src/api-fileutils.odocl @@ -0,0 +1,6 @@ +# OASIS_START +# DO NOT EDIT (digest: 186cfe8e4a6214f40bd5a22bcd602455) +FileUtil +FilePath +FileUtilStr +# OASIS_STOP diff --git a/src/fileutils-str.mldylib b/src/fileutils-str.mldylib new file mode 100644 index 0000000..23a9e43 --- /dev/null +++ b/src/fileutils-str.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 67a61a916112672c67498e1c6ad935b3) +FileUtilStr +# OASIS_STOP diff --git a/src/fileutils-str.mllib b/src/fileutils-str.mllib new file mode 100644 index 0000000..23a9e43 --- /dev/null +++ b/src/fileutils-str.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 67a61a916112672c67498e1c6ad935b3) +FileUtilStr +# OASIS_STOP diff --git a/src/fileutils.mldylib b/src/fileutils.mldylib new file mode 100644 index 0000000..fe55583 --- /dev/null +++ b/src/fileutils.mldylib @@ -0,0 +1,33 @@ +# OASIS_START +# DO NOT EDIT (digest: f44cb2fb85f59c50bf131ba99e5ebf9e) +FileUtil +FilePath +CommonPath +ExtensionPath +FilePath_type +FileStringExt +MacOSPath +UnixPath +Win32Path +FileUtilMode +FileUtilTypes +FileUtilPermission +FileUtilSize +FileUtilMisc +FileUtilSTAT +FileUtilUMASK +FileUtilLS +FileUtilCHMOD +FileUtilTEST +FileUtilPWD +FileUtilREADLINK +FileUtilWHICH +FileUtilMKDIR +FileUtilTOUCH +FileUtilFIND +FileUtilRM +FileUtilCP +FileUtilMV +FileUtilCMP +FileUtilDU +# OASIS_STOP diff --git a/src/fileutils.mllib b/src/fileutils.mllib new file mode 100644 index 0000000..fe55583 --- /dev/null +++ b/src/fileutils.mllib @@ -0,0 +1,33 @@ +# OASIS_START +# DO NOT EDIT (digest: f44cb2fb85f59c50bf131ba99e5ebf9e) +FileUtil +FilePath +CommonPath +ExtensionPath +FilePath_type +FileStringExt +MacOSPath +UnixPath +Win32Path +FileUtilMode +FileUtilTypes +FileUtilPermission +FileUtilSize +FileUtilMisc +FileUtilSTAT +FileUtilUMASK +FileUtilLS +FileUtilCHMOD +FileUtilTEST +FileUtilPWD +FileUtilREADLINK +FileUtilWHICH +FileUtilMKDIR +FileUtilTOUCH +FileUtilFIND +FileUtilRM +FileUtilCP +FileUtilMV +FileUtilCMP +FileUtilDU +# OASIS_STOP diff --git a/test/BenchFind.ml b/test/BenchFind.ml new file mode 100644 index 0000000..3b64d05 --- /dev/null +++ b/test/BenchFind.ml @@ -0,0 +1,91 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + + +(* What should be the fastest possible function in OCaml. *) +let rec simple fn = + let st = Unix.lstat fn in + match st.Unix.st_kind with + | Unix.S_DIR -> + begin + let fd = Unix.opendir fn in + try + while true do + let bn = Unix.readdir fd in + if bn <> "." && bn <> ".." then + simple (Filename.concat fn bn) + done + with End_of_file -> + Unix.closedir fd + end + | Unix.S_LNK -> + () + | _ -> + () + +let () = + let dir = + "/home/gildor" + in + let sys_find () = + let _i: int = + Sys.command ("find "^(Filename.quote dir)^" -name '*.mp3' \ + | (echo -n 'Count: '; wc -l)") + in + () + in + let fileutils_find () = + let count = + FileUtil.find + (FileUtil.Has_extension "mp3") + dir + (fun i _ -> i + 1) + 0 + in + Printf.eprintf "Count: %d\n%!" count + in + let time str f = + let start_time = + Unix.gettimeofday () + in + let time = + prerr_endline str; + f (); + (Unix.gettimeofday ()) -. start_time + in + Printf.eprintf "Time: %.2fs\n%!" time; + time + in + let () = + prerr_endline "System find (load)"; + sys_find () + in + let time_ref = + time "System find (reference)" sys_find + in + let time_fileutils = + time "FileUtil find" fileutils_find + in + let _time_simple = + time "Simple" (fun () -> simple dir) + in + Printf.eprintf "Performance: %.2f%%\n%!" + (100.0 *. (time_ref /. time_fileutils)) diff --git a/test/test.ml b/test/test.ml new file mode 100644 index 0000000..007446d --- /dev/null +++ b/test/test.ml @@ -0,0 +1,1472 @@ +(******************************************************************************) +(* ocaml-fileutils: files and filenames common operations *) +(* *) +(* Copyright (C) 2003-2014, Sylvain Le Gall *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) +(* COPYING for more details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open OUnit2 +open FilePath +open FileUtil + +exception ExpectedException + +let test_umask = 0o0022 + + +let umask_mutex = OUnitShared.Mutex.create OUnitShared.ScopeProcess + + +let bracket_umask umask = + bracket + (fun test_ctxt -> + OUnitShared.Mutex.lock test_ctxt.OUnitTest.shared umask_mutex; + Unix.umask umask) + (fun umask test_ctxt -> + let _i: int = Unix.umask umask in + OUnitShared.Mutex.unlock test_ctxt.OUnitTest.shared umask_mutex) + + +let with_bracket_umask test_ctxt umask f = + OUnitBracket.with_bracket test_ctxt (bracket_umask umask) f + + +module SetFilename = Set.Make (struct + type t = FilePath.DefaultPath.filename + let compare = FilePath.DefaultPath.compare +end) + + +let assert_equal_string ~msg = + assert_equal ~printer:(fun x -> x) ~msg:msg + + +module DiffSetFilename = + OUnitDiff.SetMake + (struct + type t = string + let compare = FilePath.DefaultPath.compare + let pp_printer = Format.pp_print_string + let pp_print_sep = OUnitDiff.pp_comma_separator + end) + +(** Check that two set of file are equal *) +let assert_equal_set_filename ?msg st_ref st = + DiffSetFilename.assert_equal ?msg + (DiffSetFilename.of_list (SetFilename.elements st_ref)) + (DiffSetFilename.of_list (SetFilename.elements st)) + + +let assert_perm fn exp = + assert_equal + ~msg:(Printf.sprintf "permission of '%s'" fn) + ~printer:(Printf.sprintf "0o%04o") + exp (Unix.lstat fn).Unix.st_perm + + +let assert_error msg e f = + assert_raises + ~msg + ExpectedException + (fun () -> + f (fun _ err -> if e err then raise ExpectedException)) + +(** Ensure that we are dealing with generated file (and not random + file on the filesystem). + *) +module SafeFS = +struct + module S = + Set.Make + (struct + type t = int * int + let compare = Pervasives.compare + end) + + type t = + { + mutable files: SetFilename.t; + mutable dirs: SetFilename.t; + mutable markers: S.t; + } + + let default () = + { + files = SetFilename.empty; + dirs = SetFilename.empty; + markers = S.empty; + } + + let marker fn = + let st = Unix.lstat fn in + (st.Unix.st_dev, st.Unix.st_ino) + + let mark t fn = + t.markers <- S.add (marker fn) t.markers + + let touch t fn = + if Sys.file_exists fn then begin + failwith (Printf.sprintf "File %S already exists." fn) + end else begin + let chn = open_out fn in + close_out chn; + mark t fn; + t.files <- SetFilename.add fn t.files + end + + let mkdir t dn = + if Sys.file_exists dn then begin + failwith (Printf.sprintf "Directory %S already exists." dn) + end else begin + Unix.mkdir dn 0o755; + mark t dn; + t.dirs <- SetFilename.add dn t.dirs + end + + let auto_ask_user t = + Ask (fun fn -> S.mem (marker fn) t.markers) + + let create dn dirs files = + let t = default () in + mark t dn; + t.dirs <- SetFilename.add dn t.dirs; + List.iter (fun fn -> mkdir t (Filename.concat dn fn)) dirs; + List.iter (fun fn -> touch t (Filename.concat dn fn)) files; + t +end + +module Test = +functor (OsPath: PATH_STRING_SPECIFICATION) -> +struct + let os_string = ref "" + + let test_label s value = (!os_string)^" : "^s^" \""^value^"\"" + + let test_label_list s lst = test_label s ("["^(String.concat ";" lst)^"]") + + let test_label_pair s (a, b) = test_label s (a^"\" \""^b) + + let test_name s = (s) + + let reduce (exp, res) = + (test_name "reduce") >:: + (fun _ -> + assert_equal_string + ~msg:(test_label "reduce" exp) + res (OsPath.reduce ~no_symlink:true exp)) + + let make_path (exp, res) = + (test_name "make_path") >:: + (fun _ -> + assert_equal_string ~msg:(test_label_list "make_path" exp) + res (OsPath.string_of_path exp)) + + let make_absolute (base, rela, res) = + (test_name "make_absolute") >:: + (fun _ -> + assert_equal_string ~msg:(test_label_pair "make_absolute" (base, rela)) + res (OsPath.reduce ~no_symlink:true (OsPath.make_absolute base rela))) + + let make_relative (base, abs, res) = + (test_name "make_relative") >:: + (fun _ -> + assert_equal_string ~msg:(test_label_pair "make_relative" (base, abs)) + res (OsPath.make_relative base abs)) + + let valid exp = + (test_name "valid") >:: + (fun _ -> + assert_bool (test_label "is_valid" exp) + (OsPath.is_valid exp)) + + let identity exp = + (test_name "identity") >:: + (fun _ -> + assert_equal_string ~msg:(test_label "identity" exp) + exp (OsPath.identity exp)) + + let extension (filename, basename, extension) = + (test_name "extension") >:: + (fun _ -> + assert_equal_string ~msg:(test_label "chop_extension" filename) + (OsPath.chop_extension filename) basename; + + assert_equal_string ~msg:(test_label "get_extension" filename) + (OsPath.string_of_extension (OsPath.get_extension filename)) + extension; + + assert_bool (test_label "check_extension" filename) + (OsPath.check_extension filename + (OsPath.extension_of_string extension)); + + assert_bool (test_label "check_extension (false) " filename) + (not (OsPath.check_extension filename + (OsPath.extension_of_string "dummy")))) + + let is_relative (filename, res) = + (test_name "is_relative") >:: + (fun _ -> + assert_equal + res + (OsPath.is_relative filename)) +end + + +module TestUnix = Test(UnixPath) +module TestMacOS = Test(MacOSPath) +module TestWin32 = Test(Win32Path) +let () = + TestUnix.os_string := "Unix"; + TestMacOS.os_string := "MacOS"; + TestWin32.os_string := "Win32" + + +(** Static test *) +let _ = + assert(UnixPath.get_extension "test.txt" = "txt"); + assert(MacOSPath.get_extension "test.txt" = "txt"); + assert(Win32Path.get_extension "test.txt" = "txt") + +(*********************) +(* Unix FilePath test*) +(*********************) +let test_unix = + let test_path = + [ + ("/"); + ("/a/b"); + ("/a/b/c/"); + ("/a/../b/c"); + ("/a/../b/../c"); + ("a/b/c/"); + ("../a/b"); + (""); + ("."); + ("./"); + (".."); + ("../") + ] + in + "Unix FilePath" >::: ( + (* Is_valid *) + ( + List.map TestUnix.valid test_path + ) + + (* Identity *) + @ ( + List.map TestUnix.identity test_path + ) + + (* Reduce path *) + @ ( + List.map TestUnix.reduce + [ + ("/a/b/c", "/a/b/c"); + ("/a/b/c/", "/a/b/c"); + ("/a/b/c/d/..", "/a/b/c"); + ("/a/b/c/.", "/a/b/c"); + ("/a/d/../b/c", "/a/b/c"); + ("/a/./b/c", "/a/b/c"); + ("/a/b/c/d/./..", "/a/b/c"); + ("/a/b/c/d/../.", "/a/b/c"); + ("/a/b/d/./../c", "/a/b/c"); + ("/a/b/d/.././c", "/a/b/c"); + ("/a/b/../d/../b/c", "/a/b/c"); + ("/a/./././b/./c", "/a/b/c"); + ("/a/../a/./b/../c/../b/./c", "/a/b/c"); + ("/a/../..", "/"); + ("./d/../a/b/c", "a/b/c"); + ("a/b/c/../../../", ""); + ("", ""); + (".", ""); + ("./", ""); + ("..", ".."); + ("../", ".."); + ] + ) + + (* Create path *) + @ ( + List.map TestUnix.make_path + [ + (["/a"; "b"; "/c/d"], "/a:b:/c/d"); + ([], ""); + ] + ) + + (* Convert to absolute *) + @ ( + List.map TestUnix.make_absolute + [ + ("/a/b/c", ".", "/a/b/c"); + ("/a/b/c", "./d", "/a/b/c/d"); + ("/a/b/c", "../d", "/a/b/d"); + ("/a/b/c", "", "/a/b/c"); + ("/a/b/c", ".", "/a/b/c"); + ("/a/b/c", "./", "/a/b/c"); + ("/a/b/c", "..", "/a/b"); + ("/a/b/c", "../", "/a/b") + ] + ) + + (* Convert to relative *) + @ ( + List.map TestUnix.make_relative + [ + ("/a/b/c", "/a/b/c", ""); + ("/a/b/c", "/a/b/d", "../d") + ] + ) + + (* Check extension *) + @ ( + List.map TestUnix.extension + [ + ("/a/b/c.d", "/a/b/c", "d"); + ("/a/b.c/d.e", "/a/b.c/d", "e"); + ("a.", "a", ""); + ] + ) + ) + + +(**********************) +(* Win32 FilePath test*) +(**********************) +let test_win32 = + let test_path = + [ + ("c:\\"); + ("c:\\a\\b"); + ("c:\\a\\b\\c\\"); + ("c:\\a\\..\\b\\c"); + ("c:\\a\\..\\b\\..\\c"); + ("a\\b\\c\\"); + ("..\\a\\b"); + (""); + ("."); + (".\\"); + (".."); + ("..\\") + ] + in + "Win32 FilePath" >::: + ( + (* Is_valid *) + (List.map TestWin32.valid test_path) + + (* Identity *) + @ (List.map TestWin32.identity test_path) + + (* Reduce path *) + @ (List.map TestWin32.reduce + [("c:\\a\\b\\c", "c:\\a\\b\\c"); + ("c:\\a\\b\\c\\", "c:\\a\\b\\c"); + ("c:\\a\\b\\c\\d\\..", "c:\\a\\b\\c"); + ("c:\\a\\b\\c\\.", "c:\\a\\b\\c"); + ("c:\\a\\d\\..\\b\\c", "c:\\a\\b\\c"); + ("c:\\a\\.\\b\\c", "c:\\a\\b\\c"); + ("c:\\a\\b\\c\\d\\.\\..", "c:\\a\\b\\c"); + ("c:\\a\\b\\c\\d\\..\\.", "c:\\a\\b\\c"); + ("c:\\a\\b\\d\\.\\..\\c", "c:\\a\\b\\c"); + ("c:\\a\\b\\d\\..\\.\\c", "c:\\a\\b\\c"); + ("c:\\a\\b\\..\\d\\..\\b\\c", "c:\\a\\b\\c"); + ("c:\\a\\.\\.\\.\\b\\.\\c", "c:\\a\\b\\c"); + ("c:\\a\\..\\a\\.\\b\\..\\c\\..\\b\\.\\c", "c:\\a\\b\\c"); + ("a\\..\\b", "b"); + ("", ""); + (".", ""); + (".\\", ""); + ("..", ".."); + ("..\\", "..")]) + + (* Create path *) + @ (List.map TestWin32.make_path + [(["c:/a"; "b"; "c:/c\\d"], "c:\\a;b;c:\\c\\d"); + ([], "")]) + + (* Convert to absolute *) + @ ( + List.map TestWin32.make_absolute + [ + ("c:\\a\\b\\c", ".", "c:\\a\\b\\c"); + ("c:\\a\\b\\c", ".\\d", "c:\\a\\b\\c\\d"); + ("c:\\a\\b\\c", "..\\d", "c:\\a\\b\\d"); + ("c:\\a\\b\\c", "", "c:\\a\\b\\c"); + ("c:\\a\\b\\c", ".", "c:\\a\\b\\c"); + ("c:\\a\\b\\c", ".\\", "c:\\a\\b\\c"); + ("c:\\a\\b\\c", "..", "c:\\a\\b"); + ("c:\\a\\b\\c", "..\\", "c:\\a\\b"); + ] + ) + + (* Convert to relative *) + @ ( + List.map TestWin32.make_relative + [ + ("c:\\a\\b\\c", "c:/a\\b\\c", ""); + ("c:\\a\\b\\c", "c:/a\\b\\d", "..\\d") + ] + ) + + (* Check extension *) + @ ( + List.map TestWin32.extension + [ + ("c:\\a\\b\\c.d", "c:\\a\\b\\c", "d"); + ("c:\\a\\b.c\\d.e", "c:\\a\\b.c\\d", "e"); + ("a.", "a", ""); + ] + ) + + @ ( + List.map TestWin32.is_relative + [ + "c:/a", false; + "c:\\a", false; + "./a", true; + ".\\a", true; + "../a", true; + "..\\a", true; + ] + ) + ) + + +(**********************) +(* MacOS FilePath test*) +(**********************) +let test_macos = + let test_path = + [ + ("a:"); + ("a:::"); + (":a:b:c"); + (""); + (":"); + ("::"); + ] + in + "MacOS FilePath" >::: + ( + (* Is_valid *) + ( + List.map TestMacOS.valid test_path + ) + + (* Identity *) + @ ( + List.map TestMacOS.identity test_path + ) + + (* Reduce path *) + @ ( + List.map TestMacOS.reduce + [ + ("root:a:b:c", "root:a:b:c"); + ("root:a:b:c:", "root:a:b:c"); + ("root:a:b:c:d::", "root:a:b:c"); + ("root:a:d::b:c", "root:a:b:c"); + ("root:a:b:c:d::", "root:a:b:c"); + ("root:a:b:d::c", "root:a:b:c"); + ("root:a:b::d::b:c", "root:a:b:c"); + ("", ""); + (":", ""); + ("::", "::"); + ] + ) + + (* Create path *) + @ ( + List.map TestMacOS.make_path + [ + ([":a"; "b"; ":c:d"], ":a;b;:c:d"); + ([], ""); + ] + ) + + (* Convert to absolute *) + @ ( + List.map TestMacOS.make_absolute + [ + ("root:a:b:c", ":", "root:a:b:c"); + ("root:a:b:c", ":d", "root:a:b:c:d"); + ("root:a:b:c", "::d", "root:a:b:d"); + ("root:a:b:c", "", "root:a:b:c"); + ("root:a:b:c", ":", "root:a:b:c"); + ("root:a:b:c", "::", "root:a:b"); + ] + ) + + (* Convert to relative *) + @ ( + List.map TestMacOS.make_relative + [ + ("root:a:b:c", "root:a:b:c", ""); + ("root:a:b:c", "root:a:b:d", "::d") + ] + ) + + (* Check extension *) + @ ( + List.map TestMacOS.extension + [ + ("root:a:b:c.d", "root:a:b:c", "d"); + ("root:a:b.c:d.e", "root:a:b.c:d", "e"); + ("a.", "a", ""); + ] + ) + ) + + +(*****************) +(* FileUtil test *) +(*****************) + +(* Test to be performed *) +let test_fileutil = + "FileUtil" >::: + ["Test" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let file_test = + let fn, chn = bracket_tmpfile test_ctxt in + output_string chn "foo"; + close_out chn; + fn + in + let non_fatal_test file (stest, expr, res) = + non_fatal test_ctxt + (fun _ -> + assert_bool + ("Test "^stest^" on "^file) + (res = (test expr file))) + in + non_fatal_test file_test ("Size_not_null", Size_not_null, true); + List.iter + (non_fatal_test tmp_dir) + [ + "True", True, true; + "False", False, false; + "Is_dir", Is_dir, true; + "Not Is_dir", (Not Is_dir), false; + "Is_dev_block", Is_dev_block, false; + "Is_dev_char", Is_dev_char, false; + "Exists", Exists, true; + "Is_file", Is_file, false; + "Is_set_group_ID", Is_set_group_ID, false; + "Has_sticky_bit", Has_sticky_bit, false; + "Is_link", Is_link, false; + "Is_pipe", Is_pipe, false; + "Is_readable", Is_readable, true; + "Is_writeable", Is_writeable, true; + "Is_socket", Is_socket, false; + "Has_set_user_ID", Has_set_user_ID, false; + "Is_exec", Is_exec, true; + "Match", Match(tmp_dir), true; + + "And of test_file * test_file", And(True, False), false; + "Or of test_file * test_file", Or(True, False), true; + "Is_newer_than", (Is_newer_than tmp_dir), false; + "Is_older_than", (Is_older_than tmp_dir), false; + ]; + if Sys.os_type <> "Win32" then begin + List.iter + (non_fatal_test tmp_dir) + [ + "Is_owned_by_user_ID", Is_owned_by_user_ID, true; + "Is_owned_by_group_ID", Is_owned_by_group_ID, true; + ] + end); + + "Test with FileUtilStr.Match" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir ~prefix:"fileutil-foobar" test_ctxt in + assert_bool + "FileUtilStr.Match = true" + (FileUtilStr.test (Match ".*fileutil-") tmp_dir); + assert_bool + "FileUtilStr.Match = false" + (not (FileUtilStr.test (Match "fileutil") tmp_dir))); + + "Mode" >::: + [ + "to_string" >:: + (fun _ -> + List.iter + (fun (str, mode) -> + assert_equal + ~printer:(fun s -> s) + str + (FileUtilMode.to_string mode)) + [ + "u+r", [`User (`Add `Read)]; + "u+rw", [`User (`Add (`List [`Read; `Write]))]; + "+rw,u=rw,g=rwx", + [ + `None (`Add (`List [`Read; `Write])); + `User (`Set (`List [`Read; `Write])); + `Group (`Set (`List [`Read; `Write; `Exec])); + ]; + ]); + + "apply" >:: + (fun _ -> + List.iter + (fun (is_dir, umask, i, m, e) -> + assert_equal + ~msg:(Printf.sprintf "0o%04o + %s" i (FileUtilMode.to_string m)) + ~printer:(Printf.sprintf "0o%04o") + e (FileUtilMode.apply ~is_dir ~umask i m)) + [ + false, 0o022, 0o0600, + [`Group (`Add `Read)], 0o0640; + + false, 0o022, 0o0600, + [`Group (`Add (`List [`Read; `Write]))], 0o0660; + + false, 0o022, 0o0600, + [`Other (`Add (`List [`Read; `Write]))], 0o0606; + + false, 0o022, 0o0600, + [`User (`Set (`List [`Read; `Write; `Exec]))], 0o0700; + + false, 0o022, 0o0600, + [`User (`Set (`List [`Read; `Write; `Exec]))], 0o0700; + + false, 0o022, 0o0600, + [`None (`Add (`List [`Read; `Write; `Exec]))], 0o0755; + + false, 0o022, 0o0600, + [`Group (`Add `ExecX)], 0o0600; + + false, 0o022, 0o0700, + [`Group (`Add `ExecX)], 0o0710; + + true, 0o022, 0o0600, + [`Group (`Add `ExecX)], 0o0610; + + false, 0o022, 0o0600, + [`Group (`Set `User)], 0o0660; + + false, 0o022, 0o0600, + [`Group (`Add `StickyO)], 0o0600; + + false, 0o022, 0o0600, + [`Group (`Add `Sticky)], 0o2600; + + false, 0o022, 0o0600, + [`Other (`Add `StickyO)], 0o1600; + + false, 0o022, 0o0600, + [`Other (`Add `Sticky)], 0o0600; + ] + ) + ]; + + "Touch in not existing subdir" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + try + let file = make_filename [tmp_dir; "doesntexist"; "essai0"] in + touch file; + assert_failure + "Touch should have failed, since intermediate directory is missing" + with _ -> + ()); + + "Touch in existing dir v1" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let file = make_filename [tmp_dir; "essai0"] in + touch file; + assert_bool "touch" (test Exists file); + ); + + "Touch in existing dir with no create" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let file = make_filename [tmp_dir; "essai2"] in + touch ~create:false file; + assert_bool "touch" (not (test Exists file))); + + "Touch in existing dir v2" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let file = make_filename [tmp_dir; "essai1"] in + touch file; + assert_bool "touch" (test Exists file)); + + "Touch precedence" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let time = Unix.gettimeofday () in + let fn1 = make_filename [tmp_dir; "essai1"] in + let fn2 = make_filename [tmp_dir; "essai0"] in + touch ~time:(Touch_timestamp time) fn1; + touch ~time:(Touch_timestamp (time +. 1.0)) fn2; + assert_bool "touch precedence 1" + (test (Is_newer_than fn1) fn2); + assert_bool + "touch precedence 2" + (test (Is_older_than fn2) fn1)); + + "Mkdir simple v1" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let dir = make_filename [tmp_dir; "essai2"] in + mkdir dir; + assert_bool "mkdir" (test Is_dir dir)); + + "Mkdir simple && mode 700" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let dir = make_filename [tmp_dir; "essai3"] in + mkdir ~mode:(`Octal 0o0700) dir; + assert_bool "mkdir" (test Is_dir dir)); + + "Mkdir recurse v2" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let dir = make_filename [tmp_dir; "essai4"; "essai5"] in + assert_error + "missing component path" + (function + | `MissingComponentPath _ -> true + | _ -> false) + (fun error -> mkdir ~error dir)); + + "Mkdir && already exist v3" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let dir = make_filename [tmp_dir; "essai0"] in + touch dir; + assert_error + "dirname already used" + (function + | `DirnameAlreadyUsed _ -> true + | _ -> false) + (fun error -> mkdir ~error dir)); + + "Mkdir recurse v4" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let dir1 = (make_filename [tmp_dir; "essai4"]) in + let dir2 = (make_filename [dir1; "essai5"]) in + mkdir ~parent:true dir2; + assert_bool "mkdir" (test Is_dir dir2); + assert_perm dir1 0o0755; + assert_perm dir2 0o0755; + rm ~recurse:true [dir1]; + assert_bool "no dir" (not (test Exists dir2)); + + mkdir + ~parent:true + ~mode:(`Symbolic [`Group (`Add `Write); `Other (`Set (`List []))]) + dir2; + assert_bool "mkdir" (test Is_dir dir2); + assert_perm dir1 0o0755; + assert_perm dir2 0o0770; + rm ~recurse:true [dir1]; + assert_bool "no dir" (not (test Exists dir2)); + + mkdir + ~parent:true + ~mode:(`Octal 0o0770) + dir2; + assert_bool "mkdir" (test Is_dir dir2); + assert_perm dir1 0o0755; + assert_perm dir2 0o0770; + rm ~recurse:true [dir1]; + assert_bool "no dir" (not (test Exists dir2))); + + "Find v0" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + with_bracket_chdir test_ctxt tmp_dir + (fun _ -> + let find_acc _ = + find True "." (fun acc x -> reduce x :: acc) [] + in + let lst_dot = + find_acc "." + in + let lst_empty = + find_acc "" + in + assert_bool "find '.' is empty" (lst_dot <> []); + assert_bool "find '' is empty" (lst_empty <> []); + assert_bool "find '.' <> find ''" (lst_dot = lst_empty))); + + "Find v1" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let sfs = + SafeFS.create tmp_dir + ["essai_dir"] + ["essai_file"] + in + let set = + find True tmp_dir (fun set fln -> SetFilename.add fln set) + SetFilename.empty + in + assert_equal_set_filename + (SetFilename.union sfs.SafeFS.dirs sfs.SafeFS.files) + set); + + "Find v2" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let sfs = + SafeFS.create tmp_dir + ["essai_dir"] + ["essai_file"] + in + let set = + find Is_dir tmp_dir (fun set fln -> SetFilename.add fln set) + SetFilename.empty + in + assert_equal_set_filename sfs.SafeFS.dirs set); + + "Find v3" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let sfs = + SafeFS.create tmp_dir + ["essai_dir"] + ["essai_file"] + in + let set = + find Is_file tmp_dir (fun set fln -> SetFilename.add fln set) + SetFilename.empty + in + assert_equal_set_filename sfs.SafeFS.files set); + + "Find v4" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let sfs = + SafeFS.create tmp_dir + ["essai_dir"] + ["essai_file"] + in + let set = + find Is_file (Filename.concat tmp_dir "") + (fun set fln -> SetFilename.add fln set) + SetFilename.empty + in + assert_equal_set_filename sfs.SafeFS.files set); + + "Unix specific" >::: + ( + let mk_symlink test_ctxt = + let () = + skip_if (Sys.os_type <> "Unix") "Symlink only works on Unix." + in + let tmp_dir = bracket_tmpdir test_ctxt in + let symlink = make_filename [tmp_dir; "recurse"] in + let sfs = + SafeFS.create tmp_dir + ["essai_dir"] + ["essai_file"] + in + Unix.symlink current_dir symlink; + SafeFS.mark sfs symlink; + tmp_dir, symlink, sfs + in + let mk_filelink test_ctxt = + let () = + skip_if (Sys.os_type <> "Unix") "Symlink only works on Unix." + in + let tmp_dir = bracket_tmpdir test_ctxt in + let symlink = make_filename [tmp_dir; "recurse"] in + let source = make_filename [tmp_dir; "essai_file"] in + let sfs = + SafeFS.create tmp_dir + [] + ["essai_file"] + in + Unix.symlink source symlink; + SafeFS.mark sfs symlink; + tmp_dir, symlink, sfs + in + let mk_deadlink test_ctxt = + let () = + skip_if (Sys.os_type <> "Unix") "Symlink only works on Unix." + in + let tmp_dir = bracket_tmpdir test_ctxt in + let dir = make_filename [tmp_dir; "dir1"] in + let symlink = make_filename [dir; "dead"] in + mkdir dir; + Unix.symlink "non_existing.txt" symlink; + tmp_dir, symlink, dir + in + [ + "Unix symlink" >:: + (fun test_ctxt -> + let _, symlink, _ = mk_symlink test_ctxt in + assert_bool "symlink is not a link" (test Is_link symlink); + assert_bool "symlink is not a dir" (test Is_dir symlink)); + + "Find v4 (link follow)" >:: + (fun test_ctxt -> + let tmp_dir, _, _ = mk_symlink test_ctxt in + try + find ~follow:Follow Is_dir tmp_dir (fun () _ -> ()) (); + assert_failure + "find follow should have failed, since there is \ + recursive symlink" + with RecursiveLink _ -> + ()); + + "Find v5 (no link follow)" >:: + (fun test_ctxt -> + let tmp_dir, fn, sfs = mk_symlink test_ctxt in + let set = + find ~follow:Skip Is_dir tmp_dir + (fun set fln -> SetFilename.add fln set) + SetFilename.empty + in + assert_bool "find symlink skip fails" + (SetFilename.equal set + (SetFilename.add fn sfs.SafeFS.dirs))); + + "Unix delete symlink" >:: + (fun test_ctxt -> + let _, symlink, _ = mk_symlink test_ctxt in + rm [symlink]; + try + let _st: Unix.stats = Unix.lstat symlink in + assert_failure "rm symlink failed" + with Unix.Unix_error(Unix.ENOENT, _, _) -> + ()); + "Dead link + stat" >:: + (fun test_ctxt -> + let _, symlink, _ = mk_deadlink test_ctxt in + let st = stat symlink in + assert_bool "is marked as a link" st.is_link; + assert_equal ~msg:"is a link" Symlink st.kind; + assert_raises + ~msg:"cannot dereference" + (FileDoesntExist symlink) + (fun () -> stat ~dereference:true symlink)); + + "Dead link + test" >:: + (fun test_ctxt -> + let _, symlink, _ = mk_deadlink test_ctxt in + assert_bool "dead link exists" + (test Is_link symlink)); + + "Dead symlink + rm" >:: + (fun test_ctxt -> + let _, _, dir = mk_deadlink test_ctxt in + rm ~recurse:true [dir]); + + "Dead symlink + cp -r" >:: + (fun test_ctxt -> + let tmp_dir, _, dir1 = mk_deadlink test_ctxt in + let dir2 = make_filename [tmp_dir; "dir2"] in + cp ~recurse:true [dir1] dir2; + try + (* test Is_link *) + let _st: Unix.stats = + Unix.lstat (make_filename [dir2; "dead"]) + in + () + with Unix.Unix_error(Unix.ENOENT, _, _) -> + assert_failure "dead link not copied."); + + "Dead symlink + cp -r v2" >:: + (fun test_ctxt -> + let tmp_dir, symlink, _ = mk_deadlink test_ctxt in + let dir2 = make_filename [tmp_dir; "dir2"] in + cp ~recurse:true [symlink] dir2; + try + (* test Is_link *) + let _st: Unix.stats = Unix.lstat dir2 in + () + with Unix.Unix_error(Unix.ENOENT, _, _) -> + assert_failure "dead link not copied."); + + "Dead symlink + cp" >:: + (fun test_ctxt -> + let tmp_dir, symlink, _ = mk_deadlink test_ctxt in + let dir2 = make_filename [tmp_dir; "dir2"] in + try + cp [symlink] dir2; + assert_failure "dead link should not copied." + with FileDoesntExist _ -> + ()); + + "Live filelink + cp" >:: + (fun test_ctxt -> + let tmp_dir, symlink, _ = mk_filelink test_ctxt in + let dest = make_filename [tmp_dir; "dest"] in + cp [symlink] dest; + assert_bool "regular" (not(test Is_link dest))); + + "Readlink" >:: + (fun test_ctxt -> + let tmp_dir, fn, _ = mk_symlink test_ctxt in + assert_equal + ~printer:(Printf.sprintf "%S") + tmp_dir (readlink fn)); + ] + ); + + "Chmod" >:: + (fun test_ctxt -> + let fn, chn = bracket_tmpfile test_ctxt in + let () = close_out chn in + + let iter_chmod = + List.iter + (fun (ini, mode, exp) -> + Unix.chmod fn ini; + chmod mode [fn]; + assert_perm fn exp) + in + + let () = + if Sys.os_type = "Unix" then begin + iter_chmod + [ + 0o0000, `Symbolic [`User (`Add `Exec)], 0o0100; + 0o0100, `Symbolic [`User (`Remove `Exec)], 0o0000; + 0o0000, `Symbolic [`Group (`Add `Exec)], 0o0010; + 0o0010, `Symbolic [`Group (`Remove `Exec)], 0o0000; + 0o0000, `Symbolic [`Other (`Add `Exec)], 0o0001; + 0o0001, `Symbolic [`Other (`Remove `Exec)], 0o0000; + 0o0000, `Symbolic [`All (`Add `Exec)], 0o0111; + 0o0111, `Symbolic [`All (`Remove `Exec)], 0o0000; + 0o0000, `Symbolic [`User (`Add `ExecX)], 0o0000; + 0o0010, `Symbolic [`User (`Add `ExecX)], 0o0110; + 0o0001, `Symbolic [`User (`Add `ExecX)], 0o0101; + ] + end; + iter_chmod + [ + 0o0200, `Symbolic [`User (`Add `Write)], 0o0200; + 0o0000, `Symbolic [`User (`Add `Write)], 0o0200; + 0o0200, `Symbolic [`User (`Remove `Write)], 0o0000; + 0o0000, `Symbolic [`Group (`Add `Write)], 0o0020; + 0o0020, `Symbolic [`Group (`Remove `Write)], 0o0000; + 0o0000, `Symbolic [`Other (`Add `Write)], 0o0002; + 0o0002, `Symbolic [`Other (`Remove `Write)], 0o0000; + 0o0000, `Symbolic [`All (`Add `Write)], 0o0222; + 0o0222, `Symbolic [`All (`Remove `Write)], 0o0000; + 0o0000, `Symbolic [`User (`Add `Read)], 0o0400; + 0o0400, `Symbolic [`User (`Remove `Read)], 0o0000; + 0o0000, `Symbolic [`Group (`Add `Read)], 0o0040; + 0o0040, `Symbolic [`Group (`Remove `Read)], 0o0000; + 0o0000, `Symbolic [`Other (`Add `Read)], 0o0004; + 0o0004, `Symbolic [`Other (`Remove `Read)], 0o0000; + 0o0000, `Symbolic [`All (`Add `Read)], 0o0444; + 0o0444, `Symbolic [`All (`Remove `Read)], 0o0000; + 0o0000, `Octal 0o644, 0o0644; + 0o0100, + (* u=r,g=u,u+w *) + `Symbolic [`User (`Set `Read); + `Group (`Set `User); + `User (`Add `Write)], + 0o640; + ] + in + let tmp_dir = bracket_tmpdir test_ctxt in + let fn = make_filename [tmp_dir; "essai6"] in + touch fn; + Unix.chmod fn 0o0000; + chmod ~recurse:true (`Symbolic [`User (`Add `Read)]) [tmp_dir]; + assert_perm fn 0o0400); + + + "Cp v1" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let file = make_filename [tmp_dir; "essai6"] in + let fn0 = make_filename [tmp_dir; "essai0"] in + touch fn0; + cp [fn0] file; + assert_bool "cp" (test Exists file)); + + "Cp v2" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let file = make_filename [tmp_dir; "essai4"] in + let fn0 = make_filename [tmp_dir; "essai0"] in + touch fn0; + cp [fn0] file; + assert_bool "cp" (test Exists file)); + + "Cp with space" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let dirspace = make_filename [tmp_dir; "essai 7"] in + let file = make_filename [dirspace; "essai0"] in + let fn0 = make_filename [tmp_dir; "essai0"] in + touch fn0; + mkdir dirspace; + cp [fn0] file; + assert_bool "cp" (test Exists file)); + + "Cp dir to dir" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let dir1 = make_filename [tmp_dir; "dir1"] in + let dir2 = make_filename [tmp_dir; "dir2"] in + mkdir dir1; + touch (make_filename [dir1; "file.txt"]); + cp ~recurse:true [dir1] dir2; + assert_bool "cp" (test Exists (make_filename [dir2; "file.txt"])); + cp ~recurse:true [dir1] dir2; + assert_bool "cp dir" (test Is_dir (make_filename [dir2; "dir1"]))); + + "Cp ACL" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let fn1 = make_filename [tmp_dir; "foo1.txt"] in + let fn2 = make_filename [tmp_dir; "foo2.txt"] in + let fn3 = make_filename [tmp_dir; "foo3.txt"] in + touch fn1; + Unix.chmod fn1 0o444; + assert_perm fn1 0o444; + cp [fn1] fn2; + assert_perm fn2 0o444; + if Sys.os_type = "Unix" then begin + Unix.chmod fn1 0o555; + assert_perm fn1 0o555; + cp [fn1] fn3; + assert_perm fn3 0o555 + end); + + "Cp preserve" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let dir1 = make_filename [tmp_dir; "dir1"] in + let fn1 = make_filename [dir1; "fn1.txt"] in + let dir2 = make_filename [tmp_dir; "dir2"] in + let fn2 = make_filename [dir2; "fn1.txt"] in + let assert_equal_time ?msg exp got = + assert_equal ?msg ~printer:string_of_float exp got + in + mkdir dir1; + touch ~time:(Touch_timestamp 1.0) ~mtime:true fn1; + touch ~time:(Touch_timestamp 2.0) ~atime:true fn1; + touch ~time:(Touch_timestamp 3.0) ~mtime:true dir1; + touch ~time:(Touch_timestamp 4.0) ~atime:true dir1; + assert_equal_time ~msg:"fn1 mtime" 1.0 (stat fn1).modification_time; + assert_equal_time ~msg:"fn1 atime" 2.0 (stat fn1).access_time; + assert_equal_time ~msg:"dir1 mtime" 3.0 (stat dir1).modification_time; + assert_equal_time ~msg:"dir1 atime" 4.0 (stat dir1).access_time; + cp ~recurse:true ~preserve:true [dir1] dir2; + assert_equal_time ~msg:"fn2 mtime" 1.0 (stat fn2).modification_time; + assert_equal_time ~msg:"fn2 atime" 2.0 (stat fn2).access_time; + assert_equal_time ~msg:"dir2 mtime" 3.0 (stat dir2).modification_time; + assert_equal_time ~msg:"dir2 atime" 4.0 (stat dir2).access_time); + + "Cp POSIX" >:: + (fun test_ctxt -> + let tmp_dir1 = bracket_tmpdir test_ctxt in + let tmp_dir2 = bracket_tmpdir test_ctxt in + touch (concat tmp_dir1 "foo.txt"); + with_bracket_chdir test_ctxt tmp_dir1 + (fun _ -> + cp ~recurse:true [current_dir] tmp_dir2); + assert_bool "file" (test Is_file (concat tmp_dir2 "foo.txt"))); + + "Mv simple" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let file0 = make_filename [tmp_dir; "essai0"] in + let file1 = make_filename [tmp_dir; "essai10"] in + let file2 = make_filename [tmp_dir; "essai9"] in + touch file0; + cp [file0] file1; + mv file1 file2; + cp [file0] file1; + mv file1 file2; + assert_bool "mv" (test Exists file2)); + + "Mv otherfs" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let file_test = make_filename [tmp_dir; "essai12"] in + let sfs = SafeFS.create tmp_dir [] ["essai12"] in + let file = + let fn = Filename.temp_file ~temp_dir:(pwd ()) "otherfs" ".txt" in + Sys.remove fn; + bracket ignore + (fun () _ -> + rm ~force:(SafeFS.auto_ask_user sfs) [fn]) + test_ctxt; + fn + in + mv file_test file; + SafeFS.mark sfs file; + assert_bool "mv" (test Exists file)); + + "Rm simple" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let file = (make_filename [tmp_dir; "essai0"]) in + let sfs = SafeFS.create tmp_dir [] ["essai0"] in + rm ~force:(SafeFS.auto_ask_user sfs) [file]; + assert_bool "rm" (test (Not Exists) file)); + + "Rm no recurse" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let dir = (make_filename [tmp_dir; "essai4"]) in + let sfs = SafeFS.create tmp_dir ["essai4"] ["essai0"] in + mkdir dir; + assert_error + "rm should have failed trying to delete a directory" + (function + | `NoRecurse _ -> true + | _ -> false) + (fun error -> rm ~error ~force:(SafeFS.auto_ask_user sfs) [dir])); + + "Rm ask duplicate" >:: + (fun test_ctxt -> + let tmp_dir = bracket_tmpdir test_ctxt in + let dir = make_filename [tmp_dir; "ask-duplicate"] in + let sfs = + SafeFS.create tmp_dir + ["ask-duplicate"] + [make_filename ["ask-duplicate"; "toto.txt"]] + in + let set_asked = ref SetFilename.empty in + let set_duplicated = ref SetFilename.empty in + let ask_register fn = + if SetFilename.mem fn !set_asked then + set_duplicated := SetFilename.add fn !set_duplicated; + set_asked := SetFilename.add fn !set_asked; + match SafeFS.auto_ask_user sfs with + | Ask f -> f fn + | _ -> false + in + rm ~force:(Ask ask_register) ~recurse:true [dir]; + assert_equal + ~msg:"duplicate file asked when removing" + SetFilename.empty + !set_duplicated); + + "Which ocamlc" >:: + (fun _ -> + try + let _str: string = which "ocamlc" in + () + with Not_found -> + assert_failure "Cannot find ocamlc"); + + "Umask" >:: + (fun test_ctxt -> + assert_equal + ~printer:(Printf.sprintf "0o%04o") + test_umask + (umask (`Octal (fun i -> i))); + assert_equal + ~printer:FileUtilMode.to_string + [`User (`Set (`List [`Read; `Write; `Exec])); + `Group (`Set (`List [`Read; `Exec])); + `Other (`Set (`List [`Read; `Exec]))] + (umask (`Symbolic (fun s -> s))); + List.iter + (fun (i, e) -> + assert_equal + ~printer:(Printf.sprintf "0o%04o") + e (umask_apply i)) + [ + 0o777, 0o755; + 0o1777, 0o1755 + ]; + with_bracket_umask test_ctxt test_umask + (fun _ _ -> + umask ~mode:(`Octal 0o0222) (`Octal ignore); + assert_equal + ~printer:(Printf.sprintf "0o%04o") + 0o0222 (umask (`Octal (fun i -> i)))); + with_bracket_umask test_ctxt test_umask + (fun _ _ -> + assert_raises + (UmaskError("Cannot set sticky bit in umask 0o1222")) + (fun () -> + umask ~mode:(`Octal 0o1222) (`Octal ignore))); + List.iter + (fun (s, e) -> + with_bracket_umask test_ctxt test_umask + (fun msk _ -> + assert_equal + ~msg:(Printf.sprintf + "0o%04o + %s -> 0o%04o" + msk (FileUtilMode.to_string s) e) + ~printer:(Printf.sprintf "0o%04o") + e (umask ~mode:(`Symbolic s) (`Octal (fun i -> i))))) + [ + [`None (`Add `Read)], 0o0022; + [`None (`Add (`List [`Read; `Write]))], 0o0000; + [`All (`Remove `Read)], 0o0466; + [`Group (`Set (`List [`Read; `Write; `Exec]))], 0o0002; + ]; + () + ); + + "Size" >::: + [ + + "string_of_size" >::: + ( + let i64_unit = + 1025L + in + let i64_unit2 = + Int64.succ (Int64.mul 1024L 1024L) + in + let test_of_vector fuzzy (str, sz) = + test_case + (fun _ -> + assert_equal + ~printer:(fun s -> s) + str + (string_of_size ~fuzzy:fuzzy sz)) + in + + [ + "exact" >::: + (List.map + (test_of_vector false) + [ + "0 TB", TB 0L; + "0 GB", GB 0L; + "0 MB", MB 0L; + "0 KB", KB 0L; + "0 B", B 0L; + "1 TB", TB 1L; + "1 GB", GB 1L; + "1 MB", MB 1L; + "1 KB", KB 1L; + "1 B", B 1L; + "1025 TB", TB i64_unit; + "1 TB 1 GB", GB i64_unit; + "1 GB 1 MB", MB i64_unit; + "1 MB 1 KB", KB i64_unit; + "1 KB 1 B", B i64_unit; + "1024 TB 1 GB", GB i64_unit2; + "1 TB 1 MB", MB i64_unit2; + "1 GB 1 KB", KB i64_unit2; + "1 MB 1 B", B i64_unit2; + "97 MB 728 KB 349 B", B 102457693L; + ]); + + "fuzzy" >::: + (List.map + (test_of_vector true) + [ + "0.00 TB", TB 0L; + "0.00 GB", GB 0L; + "0.00 MB", MB 0L; + "0.00 KB", KB 0L; + "0.00 B", B 0L; + "1.00 TB", TB 1L; + "1.00 GB", GB 1L; + "1.00 MB", MB 1L; + "1.00 KB", KB 1L; + "1.00 B", B 1L; + "1025.00 TB", TB i64_unit; + "1.00 TB", GB i64_unit; + "1.00 GB", MB i64_unit; + "1.00 MB", KB i64_unit; + "1.00 KB", B i64_unit; + "1024.00 TB", GB i64_unit2; + "1.00 TB", MB i64_unit2; + "1.00 GB", KB i64_unit2; + "1.00 MB", B i64_unit2; + "97.71 MB", B 102457693L; + ]); + ]); + + "size_add" >::: + (let test_of_vector (str, szs) = + test_case + (fun _ -> + assert_equal + ~printer:(fun s -> s) + str + (string_of_size + (List.fold_left size_add (B 0L) szs))) + in + List.map + test_of_vector + [ + "1 TB 10 MB 12 KB", [TB 1L; KB 12L; MB 10L]; + "2 MB 976 KB", [KB 2000L; MB 1L] + ]); + + "size_compare" >::: + ( + let test_of_vector (sz1, sz2, res) = + test_case + (fun _ -> + let cmp = + size_compare sz1 sz2 + in + let norm i = + if i < 0 then + -1 + else if i > 0 then + 1 + else + 0 + in + assert_equal + ~printer:string_of_int + (norm res) + cmp) + in + List.map + test_of_vector + [ + TB 1L, TB 1L, 0; + GB 1L, GB 1L, 0; + MB 1L, MB 1L, 0; + KB 1L, KB 1L, 0; + B 1L, B 1L, 0; + TB 1L, B 1L, 1; + GB 1L, B 1L, 1; + MB 1L, B 1L, 1; + KB 1L, B 1L, 1; + B 2L, B 1L, 1; + ]); + ]; + ] + + +let () = + let _i: int = Unix.umask test_umask in + run_test_tt_main + ("ocaml-fileutils" >::: + [ + "FilePath" >::: + [ + test_unix; + test_win32; + test_macos; + ]; + + test_fileutil; + ]) diff --git a/website/Makefile b/website/Makefile new file mode 100644 index 0000000..3f6a5ae --- /dev/null +++ b/website/Makefile @@ -0,0 +1,82 @@ +############################################################################## +# ocaml-fileutils: files and filenames common operations # +# # +# Copyright (C) 2003-2014, Sylvain Le Gall # +# # +# This library is free software; you can redistribute it and/or modify it # +# under the terms of the GNU Lesser General Public License as published by # +# the Free Software Foundation; either version 2.1 of the License, or (at # +# your option) any later version, with the OCaml static compilation # +# exception. # +# # +# This library is distributed in the hope that it will be useful, but # +# WITHOUT ANY WARRANTY; without even the implied warranty of # +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file # +# COPYING for more details. # +# # +# You should have received a copy of the GNU Lesser General Public License # +# along with this library; if not, write to the Free Software Foundation, # +# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA # +############################################################################## + +INKSCAPE=inkscape +COMPOSITE=composite +PANDOC=pandoc +TAR=tar +CURL=curl +FAB=fab +LINKCHECKER=linkchecker + +# Name of the product. +NAME = ocaml-fileutils +API_NAME = fileutils + +# Determine if we can scrape host. +ONLINE := $(shell (ping -c 1 forge.ocamlcore.org > /dev/null 2>&1 && echo true) || echo false) + +# HTML page to scrape for data. +FORGE_PAGE = "http://forge.ocamlcore.org/frs/?group_id=128" + +# Dev documetation link. +DEV_DOC_URL = "file:///$(shell pwd)/dist/ocaml-fileutils-doc-dev.tar.gz" + +default: all + +include Makefile.scrape +include website-tools/Makefile.common + +GENERATED_HTML=$(patsubst mkd/%.mkd,html/%.html,$(wildcard mkd/*.mkd)) +GENERATED_HTML+= html/index.html +GENERATED_IMG=html/logo.png + +all: $(GENERATED_HTML) $(GENERATED_IMG) extract-api-documentation + +.PHONY: all + +clean:: distclean + -$(RM) $(GENERATED_HTML) $(GENERATED_IMG) mkd/documentation.mkd mkd/index.mkd + -$(RM) Makefile.scrape + +distclean:: + +.PHONY: clean + +html/%.png: images/%.svg + inkscape $(INKSCAPEFLAGS) -e $@ $< > /dev/null + +# +# Checkout external modules. +# +# Get program from gildor478/website-tools to build everything. +# + +GIT_WEBSITE_TOOLS=https://github.com/gildor478/website-tools.git +checkout-website-tools: + if ! test -d website-tools ; then git clone $(GIT_WEBSITE_TOOLS); fi + cd website-tools && git pull + +website-tools/Makefile.common: checkout-website-tools + +.PHONY: checkout-website-tools + +test: all diff --git a/website/Makefile.scrape.tmpl b/website/Makefile.scrape.tmpl new file mode 100644 index 0000000..9219d53 --- /dev/null +++ b/website/Makefile.scrape.tmpl @@ -0,0 +1,28 @@ +############################################################################## +# ocaml-fileutils: files and filenames common operations # +# # +# Copyright (C) 2003-2014, Sylvain Le Gall # +# # +# This library is free software; you can redistribute it and/or modify it # +# under the terms of the GNU Lesser General Public License as published by # +# the Free Software Foundation; either version 2.1 of the License, or (at # +# your option) any later version, with the OCaml static compilation # +# exception. # +# # +# This library is distributed in the hope that it will be useful, but # +# WITHOUT ANY WARRANTY; without even the implied warranty of # +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file # +# COPYING for more details. # +# # +# You should have received a copy of the GNU Lesser General Public License # +# along with this library; if not, write to the Free Software Foundation, # +# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA # +############################################################################## + +DOC_VERSIONS=dev ${ocaml_fileutils_doc.latest.version} +cache/ocaml-fileutils-doc-${ocaml_fileutils_doc.latest.version}.tar.gz: URL = ${ocaml_fileutils_doc.latest.url} +% for version in ocaml_fileutils_doc.others: +DOC_VERSIONS+=${version.version} +cache/ocaml-fileutils-doc-${version.version}.tar.gz: URL = ${version.url} +% endfor +LATEST_VERSION=${ocaml_fileutils.latest.version} diff --git a/website/fabfile.py b/website/fabfile.py new file mode 100644 index 0000000..c550c08 --- /dev/null +++ b/website/fabfile.py @@ -0,0 +1,14 @@ + +import sys + +sys.path.insert(0, "website-tools") + +import fabfilemeta + +website = fabfilemeta.GenericWebsite('/home/groups/ocaml-fileutils') + +def deploy(): + website.deploy() + +def rollback(): + website.rollback() diff --git a/website/html/caml.ico b/website/html/caml.ico new file mode 100644 index 0000000..5e79c2a Binary files /dev/null and b/website/html/caml.ico differ diff --git a/website/html/default.css b/website/html/default.css new file mode 100644 index 0000000..24365aa --- /dev/null +++ b/website/html/default.css @@ -0,0 +1,229 @@ +/******************************************************************************/ +/* ocaml-fileutils: files and filenames common operations */ +/* */ +/* Copyright (C) 2003-2014, Sylvain Le Gall */ +/* */ +/* This library is free software; you can redistribute it and/or modify it */ +/* under the terms of the GNU Lesser General Public License as published by */ +/* the Free Software Foundation; either version 2.1 of the License, or (at */ +/* your option) any later version, with the OCaml static compilation */ +/* exception. */ +/* */ +/* This library is distributed in the hope that it will be useful, but */ +/* WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file */ +/* COPYING for more details. */ +/* */ +/* You should have received a copy of the GNU Lesser General Public License */ +/* along with this library; if not, write to the Free Software Foundation, */ +/* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ +/******************************************************************************/ + +/* General settings */ + +body +{ + background: #E8F3F8; +} + +#top +{ + margin-left: auto; + margin-right: auto; + width: 960px; + margin-top: 10px; + border-left: solid 2px #A4BCC2; + border-right: solid 2px #A4BCC2; + border-bottom: solid 2px #A4BCC2; +} + +h1 { color: #555; font-size: xx-large;} +h2 { color: #552; font-size; large;} +h3 { color: #662; font-size; medium;} + +#content h1 a { color: #555; font-size: xx-large;} +#content h2 a { color: #552; font-size; large;} +#content h3 a { color: #662; font-size; medium;} + +/* Header */ +#header +{ + clear: both; + position: relative; + height: 85px; + background: #A4BCC2; +} + +#header h1.logo +{ + position: relative; + float: left; + padding-top: 0px; + padding-left: 15px; +} + +#header h1.logo a +{ + text-decoration: none; +} + +#header h1.logo img +{ + border: none; +} + +#header .subtitle +{ + color:#FFFFFF; + float:left; + font-size:16pt; + font-weight:bold; + margin-top:34px; + margin-left:10px; +} + +/* Menu */ +#menu +{ + text-align: center; + padding: 10px; + background: #C2CBCE; + border-top: solid 2px #A4BCC2; + border-bottom: solid 2px #A4BCC2; +} + +#menu a +{ + text-decoration: none; + font-weight: bold; + font-size: 110%; + color: black; + margin: 0; + padding: 0; +} + +#menu a:hover +{ + color: #81A8B8; + border-bottom:1px dotted green; +} + +#menu li +{ + display: inline; + margin: 0; + padding: 3em; +} + +#menu ul +{ + list-style-type: none; + margin: 0; + padding: 0; +} + +/* Content */ + +#content #header { + display: none; +} + +#content +{ + padding: 2em; + padding-top: 0.5em; + background: #DBE6EC; +} + +#content hr +{ + color: grey; + width: 90%; +} + +#content a +{ + color: #67a76d; + text-decoration: none; + font-weight: bold; +} + +#content a:hover +{ + text-decoration: underline; +} + +#content code +{ + font-family: monospace; + color: #1e6694; +} + +#content pre +{ + border-left-style: double; + border-left-color: #1e6694; + padding-left: 1em; +} + +#video +{ + text-align: center; +} + +#download-latest +{ + text-align: center; +} + +#download-latest a +{ + font-weight: bold; + font-size: x-large; + padding-left: 24px; + background: url(download.png) no-repeat; +} + +#news .subtitle +{ + font-style: italic; + font-size: 80%; +} + +/* Footer */ + +#footer { + clear: both; + position: relative; + color: black; + font-size: 70%; + padding: 5px; + background: #C2CBCE; + border-top: solid 2px #A4BCC2; +} + +#footer .copyright { + position: relative; + width: 33%; +} + +#footer .lastmodified { + position: relative; + float: right; + width: 33%; + text-align: right; +} + +#footer .badge { + position: relative; + float: right; + width: 33%; + text-align: center; +} + +#footer .copyright a { + text-decoration: none; + color: black; +} + + diff --git a/website/html/download.png b/website/html/download.png new file mode 100644 index 0000000..5c50eb3 Binary files /dev/null and b/website/html/download.png differ diff --git a/website/images/logo.svg b/website/images/logo.svg new file mode 100644 index 0000000..eface4c --- /dev/null +++ b/website/images/logo.svg @@ -0,0 +1,178 @@ + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + + + + diff --git a/website/mkd/contribute.mkd b/website/mkd/contribute.mkd new file mode 100644 index 0000000..de0422a --- /dev/null +++ b/website/mkd/contribute.mkd @@ -0,0 +1,40 @@ +%Contribute to the OCaml Fileutils project + +##Bugs and feature requests + +We really appreciate to get your feedback. Use [bug reports][] or +[features requests][], you need to sign-in forge.ocamlcore.org first. + + [bug reports]: https://forge.ocamlcore.org/tracker/?func=add&group_id=128&atid=589 + [features requests]: https://forge.ocamlcore.org/tracker/?atid=592&group_id=128&func=add + +##Get the source code + +The main page for development is the [project on forge.ocamlcore.org][]. +You can browse the source code of the [project][]. + + [project on forge.ocamlcore.org]: http://forge.ocamlcore.org/projects/ocaml-fileutils + [project]: http://darcs.ocamlcore.org/cgi-bin/darcsweb.cgi?r=ocaml-fileutils;a=summary + +To get a copy of the source tree, you must use darcs: + + $> darcs get http://darcs.ocamlcore.org/repos/ocaml-fileutils + $> darcs get scm.ocamlcore.org:/darcsroot/ocaml-fileutils/ocaml-fileutils ocaml-fileutils # if you have write access + +Once you have the source code, you can pick a [bug][] or a [feature request][] to fix. + + [bug]: https://forge.ocamlcore.org/tracker/?func=browse&group_id=128&atid=589 + [feature request]: https://forge.ocamlcore.org/tracker/?atid=592&group_id=128&func=browse + +You can send back patches with a [patch report][] + + [patch report]: https://forge.ocamlcore.org/tracker/?func=add&group_id=128&atid=591 + + +To update the source code with the latest available version: + + $> darcs pull http://darcs.ocamlcore.org/repos/ocaml-fileutils + $> darcs pull scm.ocamlcore.org:/darcsroot/ocaml-fileutils/ocaml-fileutils # if you have write access + +Further documentation about darcs on [darcs.net](http://darcs.net/manual/) + diff --git a/website/mkd/index.mkd.tmpl b/website/mkd/index.mkd.tmpl new file mode 100644 index 0000000..616162f --- /dev/null +++ b/website/mkd/index.mkd.tmpl @@ -0,0 +1,40 @@ +${"% OCaml Fileutils "} + +ocaml-fileutils is a library of pure OCaml functions to manipulate real files and filenames. + + + +Features of the project: + +* pure OCaml +* file functions inspired from GNU fileutils (aiming to be POSIX compatible) + * cp: copy files and directories + * mv: rename files and directories + * rm: remove files and directories + * test: check file types and compare values + * find: find files that match certain criteria + * mkdir: create directory and its parents + * ls: list content of a directory + * touch: change file timestamps + * which: locate a command + * readlink: resolve symlink + * du: compute disk usage + * stat: abstract of Unix.stat + * cmp: compare files + * chmod: change permissions of a file +* filename functions support Win32/Unix/MacOS and Cygwin filenames: + * Compare: is_subdir, is_updir, compare + * Transform: make_absolute, make_relative, reduce + * Extension: chop_extension, check_extension + +You can browse the online API documentation of the latest version. + + * [API for version ${ocaml_fileutils.latest.version}, the latest stable version](api-fileutils/index.html) +% for version in ocaml_fileutils_doc.others: + * [API for version ${version.version}](api-fileutils-${version.version}/index.html) +% endfor + * [API for the version under development](api-fileutils-dev/index.html) diff --git a/website/mkd/part-after-body.html b/website/mkd/part-after-body.html new file mode 100644 index 0000000..0688ee1 --- /dev/null +++ b/website/mkd/part-after-body.html @@ -0,0 +1,25 @@ + + + + diff --git a/website/mkd/part-before-body.html b/website/mkd/part-before-body.html new file mode 100644 index 0000000..e0ed78f --- /dev/null +++ b/website/mkd/part-before-body.html @@ -0,0 +1,25 @@ + + +
+ + + + + +
diff --git a/website/mkd/part-header.html b/website/mkd/part-header.html new file mode 100644 index 0000000..b8c1cf7 --- /dev/null +++ b/website/mkd/part-header.html @@ -0,0 +1 @@ +