pax_global_header00006660000000000000000000000064121571274030014514gustar00rootroot0000000000000052 comment=0b511181b86e5686eb1f45afae7cdf048e0a7f26 ocaml-sqlexpr-0.5.5/000077500000000000000000000000001215712740300143125ustar00rootroot00000000000000ocaml-sqlexpr-0.5.5/.gitignore000066400000000000000000000004311215712740300163000ustar00rootroot00000000000000*.annot *.a *.o *.opt *.run *.cmx* *.cmi *.cmo *.cma *.cmxa *.omc .omakedb* .*swp *.s gmon.out /t_sqlexpr_sqlite # generated by OASIS /_build /META /Makefile /configure /myocamlbuild.ml /setup.ml /setup.data /setup.log /sqlexpr.mllib /sqlexpr.odocl /sqlexpr_syntax.mllib /toplevel ocaml-sqlexpr-0.5.5/AUTHORS000066400000000000000000000000411215712740300153550ustar00rootroot00000000000000Mauricio Fernandez ocaml-sqlexpr-0.5.5/COPYING000066400000000000000000000654641215712740300153640ustar00rootroot00000000000000 As a special exception to the GNU Library General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library as distributed by upstream author, or a modified version of the Library that is distributed under the conditions defined in clause 2 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. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the 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. ^L 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. ^L 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. ^L 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. ^L 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. ^L 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. ^L 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. ^L 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 ^L 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! ocaml-sqlexpr-0.5.5/INSTALL000066400000000000000000000016501215712740300153450ustar00rootroot00000000000000This is the INSTALL file for the ocaml-sqlexpr 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 * findlib * estring * csv * batteries * sqlite3 * lwt * unix Installing ========== 1. Uncompress source directory and got to the root of the package 2. Run 'ocaml setup.ml -configure' 3. Run 'ocaml setup.ml -build' 4. Run 'ocaml setup.ml -install' Alternatively: 1. Uncompress source directory and got to the root of the package 2. Run './configure" 3. Run 'make" 4. Run 'make install" Uninstalling ============ 1. Go to the root of the package 2. Run 'ocaml setup.ml -uninstall' OASIS ===== OASIS is a software that helps to write setup.ml using a simple '_oasis' configuration file. The generated setup only depends on standard OCaml installation, no additional library is required. ocaml-sqlexpr-0.5.5/META000066400000000000000000000011071215712740300147620ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 241cffd68e9612eb6fa812c6118b726f) version = "0.5.5" description = "SQLite database access." requires = "csv batteries sqlite3 estring lwt lwt.syntax lwt.unix unix threads" archive(byte) = "sqlexpr.cma" archive(native) = "sqlexpr.cmxa" exists_if = "sqlexpr.cma" package "syntax" ( version = "0.5.5" description = "Syntax extension for SQL statements/expressions" requires = "camlp4 estring" archive(syntax, preprocessor) = "sqlexpr_syntax.cma" archive(syntax, toploop) = "sqlexpr_syntax.cma" exists_if = "sqlexpr_syntax.cma" ) # OASIS_STOP ocaml-sqlexpr-0.5.5/Makefile000066400000000000000000000012761215712740300157600ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb) 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) .PHONY: build doc test all install uninstall reinstall clean distclean configure # OASIS_STOP ocaml-sqlexpr-0.5.5/OMakefile000066400000000000000000000033021215712740300160670ustar00rootroot00000000000000NATIVE_ENABLED = true BYTE_ENABLED = true USE_OCAMLFIND = true OCAMLPACKS[] = csv batteries sqlite3 estring lwt lwt.unix lwt.syntax threads OCAMLFINDFLAGS = -syntax camlp4o OCAMLFLAGS += -thread OCAMLOPTFLAGS = OCAMLDEP_MODULES_ENABLED = false %.sig: %.ml %.cmo $(OCAMLFIND) $(OCAMLC) -package $(concat \,, $(OCAMLPACKS)) \ $(OCAMLFINDFLAGS) \ $(mapprefix -I, $(OCAMLINCLUDES)) \ $(OCAMLFLAGS) $(OCAMLCFLAGS) -i $< > $@ section NATIVE_ENABLED = false OCAMLPACKS[] = estring camlp4.quotations pa_sql.cmi pa_sql.cmo: pa_sql.ml .SCANNER: scan-ocaml-%.ml: %.ml pa_sql.cmo .SCANNER: scan-ocaml-%.mli: %.mli pa_sql.cmo OCAMLFINDFLAGS += -syntax camlp4o -ppopt pa_sql.cmo OCamlLibrary(sqlexpr, sqlexpr_concurrency sqlexpr_sqlite sqlexpr_sqlite_lwt) section OCAMLPACKS[] += oUnit OCAML_LIBS[] += sqlexpr OCamlProgram(t_sqlexpr_sqlite, t_sqlexpr_sqlite) $(addsuffixes .o .cmx .cmi .cmo, t_sqlexpr_sqlite): section VERSION = $`(shell oasis query Version | tail -1) NAME = $`(string ocaml-sqlexpr-$(VERSION)) DATE = $`(shell date +%F) BRANCH = $`(string $(VERSION)_$(DATE)) .PHONY: release release: git checkout -b $(BRANCH) oasis setup git add -f META sqlexpr.odocl Makefile _tags configure \ myocamlbuild.ml setup.ml sqlexpr.mllib sqlexpr_syntax.mllib git commit -m "Add OASIS-generated build system." git archive -v --prefix $(NAME)/ -o $(NAME).tar HEAD rm -f $(NAME).tar.gz gzip $(NAME).tar git checkout master git branch -D $(BRANCH) .DEFAULT: pa_sql.cmo sqlexpr.cma sqlexpr.cmxa .PHONY: test test: t_sqlexpr_sqlite ./t_sqlexpr_sqlite .PHONY: clean clean: rm -f $(filter-proper-targets $(ls R, .)) *.s *.annot *.so *.a ocaml-sqlexpr-0.5.5/OMakeroot000066400000000000000000000001001215712740300161240ustar00rootroot00000000000000open build/C open build/OCaml DefineCommandVars() .SUBDIRS: . ocaml-sqlexpr-0.5.5/README000066400000000000000000000121301215712740300151670ustar00rootroot00000000000000 ocaml-sqlexpr is a simple library and syntax extension for type-safe, convenient execution of SQL statements, currently compatible with Sqlite3. The latest version can be found at https://github.com/mfp/ocaml-sqlexpr Sqlexpr features: * automated prepared statement caching, param binding, data extraction, error checking (including automatic stmt reset to avoid BUSY/LOCKED errors in subsequent queries), stmt finalization on db close, etc. * HOFs like iter, fold, transaction * support for different concurrency models: everything is functorized over a THREAD monad, so you can for instance do concurrent folds/iters with Lwt * support for SQL stmt syntax checks and some extra semantic checking (column names, etc) Sqlexpr is used as follows: module Sqlexpr = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) module S = Sqlexpr let () = let db = S.open_db "foo.db" in S.iter db (fun (n, p) -> Printf.printf "User %S, password %S\n" n p) sqlc"SELECT @s{login}, @s{password} FROM users"; List.iter (fun (n, p) -> S.execute db sqlc"INSERT INTO users VALUES(%s, %s)" n p) [ "coder24", "badpass"; "tokyo3", "12345" ] See also example.ml. Dependencies ============ csv, batteries, sqlite3, estring, lwt (>= 2.2.0), lwt.syntax, lwt.unix, unix, threads Syntax extension ================ ocaml-sqlexpr includes a syntax extension to build type-safe SQL statements/expressions: sql"..." denotes a SQL statement/expression sqlc"..." denotes a SQL statement/expression that is to be cached sql_check"sqlite" returns a tuple of functions to initialize, check the validity of the SQL statements/expressions and check against an auto-initialized temporary database. sqlinit"..." is equivalent to sql"...", but the statement will be added to the list of statements to be executed in the automatically generated initialization function sql_check"sqlite" is used as follows: let auto_init_db, check_db, auto_check_db = sql_check"sqlite" which creates 3 functions val auto_init_db : Sqlite3.db -> Format.formatter -> bool val check_db : Sqlite3.db -> Format.formatter -> bool val auto_check_db : Format.formatter -> bool each of them returns [false] on error, and writes the error messages to the provided formatter. SQL statement/expression syntax ------------------------------- sql/sqlc literals are similar to Printf's format strings and their precise types depend on their contents. They accept input parameters (similarly to Printf) and, in the case of SQL expressions, their execution will yield a tuple whose type is determined by the output parameters. Input parameters are denoted with %X where X is one of: input parameter OCaml type --------------- ---------- %d int %l Int32.t %L Int64.t %s string %S string (handled as BLOB by SQLite) %f float %b bool %a ('a -> string) (resulting string handled as BLOB by SQLite) A literal '%' is denoted with '%%'. A parameter is made nullable (turning the OCaml type into a [_ option]) by appending a '?', e.g. '%d?'. Output parameters are denoted with @X{SQL expression} where X is one of: output parameter OCaml type ---------------- ---------- @d int @l Int32.t @L Int64.t @s string @S string (handled as BLOB by SQLite) @f float @b bool A literal '@' is denoted with '@@'. As in the case of input parameters, output parameters can be made nullable by appending a '?'. A sql"..." or sqlc"..." literal is of type [_ statement] if it has no output parameters, and of type [_ expression] if it has at least one. Examples: sql"SELECT @s{name} FROM users" is an expression sql"SELECT @s{name} FROM users WHERE id = %d" is an expression sql"SELECT @s{name}, @s{email} FROM users" is an expression sql"DELETE FROM users WHERE id = %d" is a statement Statements are executed with [execute] or [insert] (which returns the id of the new row); expressions are "selected" with a function from the [select*] family or a HOF like [iter] or [fold]. Examples: module Sqlexpr = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) module S = Sqlexpr let insert_user_stmt = sqlc"INSERT INTO users(login, password, email) VALUES(%s, %s, %s?)" let insert_user db ~login ?email ~password = S.execute db insert_user_stmt login password email (* insert user and return ID; we use partial application here *) let new_user_id db = S.insert db insert_user_stmt let get_password db = S.select_one db sqlc"SELECT @s{password} FROM users WHERE login = %s" let get_email db = S.select_one db sqlc"SELECT @s?{email} FROM users WHERE login = %s" let iter_users db f = S.iter db f sqlc"SELECT @L{id}, @s{login}, @s{password}, @s?{email} FROM users" ocaml-sqlexpr-0.5.5/_oasis000066400000000000000000000040651215712740300155170ustar00rootroot00000000000000OASISFormat: 0.3 Name: ocaml-sqlexpr Version: 0.5.5 Synopsis: Type-safe, convenient SQLite database access. Authors: Mauricio Fernandez Maintainers: Mauricio Fernandez License: LGPL-2.1 with OCaml linking exception Plugins: DevFiles (0.3), META (0.3) BuildTools: ocamlbuild Homepage: http://github.com/mfp/ocaml-sqlexpr Description: Minimalistic library and syntax extension for type-safe, convenient execution of SQL statements. Currently compatible with Sqlite3. . Sqlexpr features: . * automated prepared statement caching, param binding, data extraction, error checking (including automatic stmt reset to avoid BUSY/LOCKED errors in subsequent queries), stmt finalization on db close, etc. . * HOFs like iter, fold, transaction . * support for different concurrency models: everything is functorized over a THREAD monad, so you can for instance do concurrent folds/iters with Lwt . * support for SQL stmt syntax checks and some extra semantic checking (column names, etc) SourceRepository github Type: git Location: git://github.com/mfp/ocaml-sqlexpr.git Library sqlexpr Path: . BuildTools: ocamlbuild Modules: Sqlexpr_concurrency, Sqlexpr_sqlite, Sqlexpr_sqlite_lwt BuildDepends: csv, batteries, sqlite3, estring, lwt (>= 2.2.0), lwt.syntax, lwt.unix, unix, threads XMETADescription: SQLite database access. Library "sqlexpr_syntax" Path: . FindlibName: syntax FindlibParent: sqlexpr Modules: Pa_sql BuildDepends: camlp4.lib, camlp4.quotations.r, estring XMETADescription: Syntax extension for SQL statements/expressions XMETAType: syntax XMETARequires: camlp4, estring Document sqlexpr Title: API reference for Sqlexpr Type: ocamlbuild (0.3) InstallDir: $htmldir/sqlexpr BuildTools+: ocamldoc XOCamlbuildPath: . XOCamlbuildLibraries: sqlexpr ocaml-sqlexpr-0.5.5/_tags000066400000000000000000000015551215712740300153400ustar00rootroot00000000000000<**/*.ml>: syntax_camlp4o # OASIS_START # DO NOT EDIT (digest: dfffe6ec960f8ff3b4403d34c7548c58) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse ".bzr": not_hygienic ".hg": -traverse ".hg": not_hygienic ".git": -traverse ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic # Library sqlexpr_syntax "sqlexpr_syntax.cmxs": use_sqlexpr_syntax <*.ml{,i}>: pkg_camlp4.quotations.r <*.ml{,i}>: pkg_camlp4.lib # Library sqlexpr "sqlexpr.cmxs": use_sqlexpr <*.ml{,i}>: pkg_unix <*.ml{,i}>: pkg_threads <*.ml{,i}>: pkg_sqlite3 <*.ml{,i}>: pkg_lwt.unix <*.ml{,i}>: pkg_lwt.syntax <*.ml{,i}>: pkg_lwt <*.ml{,i}>: pkg_estring <*.ml{,i}>: pkg_csv <*.ml{,i}>: pkg_batteries # OASIS_STOP ocaml-sqlexpr-0.5.5/configure000077500000000000000000000005541215712740300162250ustar00rootroot00000000000000#!/bin/sh # OASIS_START # DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7) 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 ocaml-sqlexpr-0.5.5/example.ml000066400000000000000000000012701215712740300162770ustar00rootroot00000000000000 module Sqlexpr = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) module S = Sqlexpr let init_db db = S.execute db sqlinit"CREATE TABLE IF NOT EXISTS users( id INTEGER PRIMARY KEY, login TEXT UNIQUE, password TEXT NON NULL, name TEXT, email TEXT );" let fold_users db f acc = S.fold db f acc sqlc"SELECT @s{login}, @s{password}, @s?{email} FROM users" let insert_user db ~login ~password ?name ?email () = S.insert db sqlc"INSERT INTO users(login, password, name, email) VALUES(%s, %s, %s?, %s?)" login password name email let auto_init_db, check_db, auto_check_db = sql_check"sqlite" ocaml-sqlexpr-0.5.5/myocamlbuild.ml000066400000000000000000000422241215712740300173310ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 4b0b54727d86f5e35ee2bb2cd5d0d6c7) *) module OASISGettext = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISGettext.ml" let ns_ str = str let s_ str = str let f_ (str : ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISExpr = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISExpr.ml" open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module BaseEnvLight = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let var_get name env = let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff in var_expand (MapString.find name env) let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end module MyOCamlbuildFindlib = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild * by N. Pouillard and others * * Updated on 2009/02/28 * * Modified by Sylvain Le Gall *) open Ocamlbuild_plugin (* these functions are not really officially exported *) let run_and_read = Ocamlbuild_pack.My_unix.run_and_read let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings let split s ch = let x = ref [] in let rec go s = let pos = String.index s ch in x := (String.before s pos)::!x; go (String.after s (pos + 1)) in try go s with Not_found -> !x let split_nl s = split s '\n' let before_space s = try String.before s (String.index s ' ') with Not_found -> s (* this lists all supported packages *) let find_packages () = List.map before_space (split_nl & run_and_read "ocamlfind list") (* this is supposed to list available syntaxes, but I don't know how to do it. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] (* ocamlfind command *) let ocamlfind x = S[A"ocamlfind"; x] let dispatch = function | Before_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" | After_rules -> (* When one link an OCaml library/binary/package, one should use -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; 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"]) | _ -> () end module MyOCamlbuildBase = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/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 # 56 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" type t = { lib_ocaml: (name * dir list) list; lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) includes: (dir * dir list) list; } let env_filename = Pathname.basename BaseEnvLight.default_filename let dispatch_combine lst = fun e -> List.iter (fun dispatch -> dispatch e) lst let tag_libstubs nm = "use_lib"^nm^"_stubs" let nm_libstubs nm = nm^"_stubs" let dispatch t e = let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then String.sub s 1 ((String.length s) - 1) else s in List.iter (fun (opt, var) -> try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> Printf.eprintf "W: Cannot get variable %s" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; Options.ext_dll, "ext_dll"; ] | Before_rules -> (* TODO: move this into its own file and conditionnaly include it, if * needed. *) (* OCaml cmxs rules: cmxs available in ocamlopt but not ocamlbuild. Copied from ocaml_specific.ml in ocamlbuild sources. *) let has_native_dynlink = try bool_of_string (BaseEnvLight.var_get "native_dynlink" env) with Not_found -> false in if has_native_dynlink && String.sub Sys.ocaml_version 0 4 = "3.11" then begin let ext_lib = !Options.ext_lib in let ext_obj = !Options.ext_obj in let ext_dll = !Options.ext_dll in let x_o = "%"-.-ext_obj in let x_a = "%"-.-ext_lib in let x_dll = "%"-.-ext_dll in let x_p_o = "%.p"-.-ext_obj in let x_p_a = "%.p"-.-ext_lib in let x_p_dll = "%.p"-.-ext_dll in rule "ocaml: mldylib & p.cmx* & p.o* -> p.cmxs & p.so" ~tags:["ocaml"; "native"; "profile"; "shared"; "library"] ~prods:["%.p.cmxs"; x_p_dll] ~dep:"%.mldylib" (OC.native_profile_shared_library_link_mldylib "%.mldylib" "%.p.cmxs"); rule "ocaml: mldylib & cmx* & o* -> cmxs & so" ~tags:["ocaml"; "native"; "shared"; "library"] ~prods:["%.cmxs"; x_dll] ~dep:"%.mldylib" (OC.native_shared_library_link_mldylib "%.mldylib" "%.cmxs"); rule "ocaml: p.cmx & p.o -> p.cmxs & p.so" ~tags:["ocaml"; "native"; "profile"; "shared"; "library"] ~prods:["%.p.cmxs"; x_p_dll] ~deps:["%.p.cmx"; x_p_o] (OC.native_shared_library_link ~tags:["profile"] "%.p.cmx" "%.p.cmxs"); rule "ocaml: p.cmxa & p.a -> p.cmxs & p.so" ~tags:["ocaml"; "native"; "profile"; "shared"; "library"] ~prods:["%.p.cmxs"; x_p_dll] ~deps:["%.p.cmxa"; x_p_a] (OC.native_shared_library_link ~tags:["profile"; "linkall"] "%.p.cmxa" "%.p.cmxs"); rule "ocaml: cmx & o -> cmxs" ~tags:["ocaml"; "native"; "shared"; "library"] ~prods:["%.cmxs"] ~deps:["%.cmx"; x_o] (OC.native_shared_library_link "%.cmx" "%.cmxs"); rule "ocaml: cmx & o -> cmxs & so" ~tags:["ocaml"; "native"; "shared"; "library"] ~prods:["%.cmxs"; x_dll] ~deps:["%.cmx"; x_o] (OC.native_shared_library_link "%.cmx" "%.cmxs"); rule "ocaml: cmxa & a -> cmxs & so" ~tags:["ocaml"; "native"; "shared"; "library"] ~prods:["%.cmxs"; x_dll] ~deps:["%.cmxa"; x_a] (OC.native_shared_library_link ~tags:["linkall"] "%.cmxa" "%.cmxs"); end | After_rules -> (* Declare OCaml libraries *) List.iter (function | nm, [] -> ocaml_lib nm | nm, dir :: tl -> 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) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; (* Declare C libraries *) List.iter (fun (lib, dir, headers) -> (* Handle C part of library *) flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. *) dep ["link"; "ocaml"; "program"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; "program"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) dep ["compile"; "c"] headers; (* Setup search path for lib *) flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; (* Add flags *) List.iter (fun (tags, cond_specs) -> let spec = BaseEnvLight.var_choose cond_specs env in flag tags & spec) t.flags | _ -> () let dispatch_default t = dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch; ] end open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [("sqlexpr_syntax", []); ("sqlexpr", [])]; lib_c = []; flags = []; includes = []; } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; # 559 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; ocaml-sqlexpr-0.5.5/pa_sql.ml000066400000000000000000000236671215712740300161410ustar00rootroot00000000000000 open Printf open Camlp4.PreCast open Pa_estring type output_type = [ `Int | `Text | `Blob | `Float | `Int32 | `Int64 | `Bool] type input_type = [output_type | `Any] type no_output_element = [ `Literal of string | `Input of input_type * bool ] type sql_element = [ no_output_element | `Output of no_output_element list * output_type * bool (* nullable *) ] let collected_statements = ref [] let collected_init_statements = ref [] (* [parse_without_output_exprs continuation acc llist] * parse %x(?) and %%, but don't recognize @x{} expressions, passing a list * of no_output_elements to the continuation (used for open recursion). *) let rec parse_without_output_exprs k acc = function Cons (_, '%', Cons (_, 'd', l)) -> do_parse_in k acc `Int l | Cons (_, '%', Cons (_, 'l', l)) -> do_parse_in k acc `Int32 l | Cons (_, '%', Cons (_, 'L', l)) -> do_parse_in k acc `Int64 l | Cons (_, '%', Cons (_, 's', l)) -> do_parse_in k acc `Text l | Cons (_, '%', Cons (_, 'S', l)) -> do_parse_in k acc `Blob l | Cons (_, '%', Cons (_, 'f', l)) -> do_parse_in k acc `Float l | Cons (_, '%', Cons (_, 'b', l)) -> do_parse_in k acc `Bool l | Cons (_, '%', Cons (_, 'a', l)) -> do_parse_in k acc `Any l | Cons (_, '%', Cons (_, '%', l)) -> begin match acc with `Literal s :: tl -> k (`Literal (s ^ "%") :: tl) l | tl -> k (`Literal "%" :: tl) l end | Cons (_, '%', Cons (loc, c, l)) -> Loc.raise loc (Failure (sprintf "Unknown input directive %C" c)) | Cons (_, c, l) -> begin match acc with `Literal s :: tl -> k (`Literal (s ^ String.make 1 c) :: tl) l | tl -> k (`Literal (String.make 1 c) :: tl) l end | Nil _ -> List.rev acc (* complete the `Input sql_element, recognizing the ? that indicates it's * nullable, if present *) and do_parse_in k acc kind = function | Cons (_, '?', l) -> k (`Input (kind, true) :: acc) l | l -> k (`Input (kind, false) :: acc) l (* @return list of [sql_elements] given a llist *) let rec parse l : sql_element list = do_parse [] l and do_parse acc l = parse_with_output_exprs acc l (* like [parse_with_output_exprs] but also recognize @x{...}, returning * a list of [sql_element]s. Need not use open recursion here, because the * continuation will always be [do_parse]. *) and parse_with_output_exprs acc = function | Cons (_, '@', Cons (_, 'd', l)) -> do_parse_out `Int acc l | Cons (_, '@', Cons (_, 'l', l)) -> do_parse_out `Int32 acc l | Cons (_, '@', Cons (_, 'L', l)) -> do_parse_out `Int64 acc l | Cons (_, '@', Cons (_, 's', l)) -> do_parse_out `Text acc l | Cons (_, '@', Cons (_, 'S', l)) -> do_parse_out `Blob acc l | Cons (_, '@', Cons (_, 'f', l)) -> do_parse_out `Float acc l | Cons (_, '@', Cons (_, 'b', l)) -> do_parse_out `Bool acc l | Cons (_, '@', Cons (_, '@', l)) -> begin match acc with `Literal s :: tl -> do_parse (`Literal (s ^ "@") :: tl) l | tl -> do_parse (`Literal "@" :: tl) l end | Cons (_, '@', Cons (loc, c, l)) -> Loc.raise loc (Failure (sprintf "Unknown output directive %C" c)) | l -> parse_without_output_exprs do_parse acc l (* read the trailing ? and { after a @x output expression delimiter, then read * the expression up to the next } *) and do_parse_out kind acc = function Cons (_, '?', Cons (loc, '{', l)) -> read_expr acc loc true kind l | Cons (loc, '{', l) -> read_expr acc loc false kind l | Cons (loc, _, _) | Nil loc -> Loc.raise loc (Failure "Missing expression for output directive") (* read the output expression up to the trailing '}'. Disallow output * expressions when parsing the inner expression. *) and read_expr acc loc ?(text = "") nullable kind = function Cons (_, '}', l) -> let rec parse_output_expr acc l = parse_without_output_exprs parse_output_expr acc l in let elms : no_output_element list = parse_output_expr [] (unescape loc text) in do_parse (`Output (elms, kind, nullable) :: acc) l | Cons (_, c, l) -> read_expr acc loc ~text:(sprintf "%s%c" text c) nullable kind l | Nil _ -> Loc.raise loc (Failure "Unterminated output directive expression") let new_id = let n = ref 0 in fun () -> incr n; sprintf "__pa_sql_%d" !n let input_directive_id kind nullable = let s = match kind with `Int -> "int" | `Int32 -> "int32" | `Int64 -> "int64" | `Text -> "text" | `Blob -> "blob" | `Float -> "float" | `Bool -> "bool" | `Any -> "any" in if nullable then "maybe_" ^ s else s let directive_expr ?(_loc = Loc.ghost) = function `Input (kind, nullable) -> let id = input_directive_id kind nullable in <:expr< Sqlexpr.Directives.$lid:id$ >> | `Literal s -> <:expr< Sqlexpr.Directives.literal $str:s$ >> let sql_statement l = let b = Buffer.create 10 in let rec append_text = function `Input _ -> Buffer.add_char b '?' | `Literal s -> Buffer.add_string b s in List.iter append_text l; Buffer.contents b let concat_map f l = List.concat (List.map f l) let expand_output_elms = function | `Output (l, _, _) -> l | #no_output_element as d -> [d] let create_sql_statement _loc ~cacheable sql_elms = let sql_elms = concat_map expand_output_elms sql_elms in let k = new_id () in let st = new_id () in let exp = List.fold_right (fun dir e -> <:expr< $directive_expr dir$ $e$ >>) sql_elms <:expr< $lid:k$ >> in let id = let signature = sprintf "%d-%f-%d-%S" (Unix.getpid ()) (Unix.gettimeofday ()) (Random.int 0x3FFFFFF) (sql_statement sql_elms) in Digest.to_hex (Digest.string signature) in let stmt_id = if cacheable then <:expr< Some $str:id$ >> else <:expr< None >> in <:expr< { Sqlexpr.sql_statement = $str:sql_statement sql_elms$; stmt_id = $stmt_id$; directive = (fun [$lid:k$ -> fun [$lid:st$ -> $exp$ $lid:st$]]) } >> let create_sql_expression _loc ~cacheable (sql_elms : sql_element list) = let statement = create_sql_statement _loc ~cacheable sql_elms in let conv_expr kind nullable e = let expr x = let name = (if nullable then "maybe_" else "") ^ x in <:expr< Sqlexpr.Conversion.$lid:name$ $e$ >> in match kind with `Int -> expr "int" | `Int32 -> expr "int32" | `Int64 -> expr "int64" | `Bool -> expr "bool" | `Float -> expr "float" | `Text -> expr "text" | `Blob -> expr "blob" in let id = new_id () in let conv_exprs = let n = ref 0 in concat_map (fun dir -> match dir with `Output (_, kind, nullable) -> let i = string_of_int !n in incr n; [ conv_expr kind nullable <:expr< $lid:id$.($int:i$) >> ] | _ -> []) sql_elms in let tuple_func = let e = match conv_exprs with [] -> assert false | [x] -> x | hd :: tl -> <:expr< ( $hd$, $Ast.exCom_of_list tl$ ) >> in <:expr< fun [$lid:id$ -> $e$] >> in <:expr< { Sqlexpr.statement = $statement$; get_data = ($int:string_of_int (List.length conv_exprs)$, $tuple_func$); } >> let expand_sql_literal ?(is_init = false) ~cacheable ctx _loc str = let sql_elms = parse (unescape _loc str) in let sql_stmt_text = let no_output = concat_map expand_output_elms sql_elms in sql_statement no_output in let push l = l := !l @ [sql_stmt_text] in push (if is_init then collected_init_statements else collected_statements); if List.exists (function `Output _ -> true | _ -> false) sql_elms then create_sql_expression _loc ~cacheable sql_elms else create_sql_statement _loc ~cacheable sql_elms let string_list_expr ?(_loc = Loc.ghost) = function [] -> <:expr< [] >> | l -> List.fold_left (fun l e -> <:expr< [ $e$ :: $l$ ] >>) <:expr< [] >> (List.rev_map (fun s -> <:expr< $str:s$ >>) l) let expand_sqlite_check_functions ctx _loc = let statement_check = <:expr< try ignore (Sqlite3.prepare db stmt) with [Sqlite3.Error s -> do { ret.val := False; Format.fprintf fmt "Error in statement %S: %s\n" stmt s } ] >> in let stmt_list = string_list_expr ~_loc !collected_statements in let check_in_db_expr = <:expr< fun db fmt -> let ret = ref True in do { List.iter (fun stmt -> $statement_check$) $stmt_list$; ret.val; } >> in let init_stmts = string_list_expr ~_loc !collected_init_statements in let init_db_expr = <:expr< fun db fmt -> let ret = ref True in do { List.iter (fun stmt -> match Sqlite3.exec db stmt with [ Sqlite3.Rc.OK -> () | rc -> do { ret.val := False; Format.fprintf fmt "Error in init. SQL statement (%s)@ %S@\n" (Sqlite3.errmsg db) stmt } ]) $init_stmts$; ret.val } >> in let in_mem_check_expr = <:expr< fun fmt -> let db = Sqlite3.db_open ":memory:" in init_db db fmt && check_db db fmt >> in <:expr< let init_db = $init_db_expr$ in let check_db = $check_in_db_expr$ in let in_mem_check = $in_mem_check_expr$ in (init_db, check_db, in_mem_check) >> let _ = Random.self_init (); register_expr_specifier "sql" (fun ctx _loc str -> expand_sql_literal ~cacheable:false ctx _loc str); register_expr_specifier "sqlinit" (fun ctx _loc str -> expand_sql_literal ~is_init:true ~cacheable:false ctx _loc str); register_expr_specifier "sqlc" (fun ctx _loc str -> let expr = expand_sql_literal ~cacheable:true ctx _loc str in let id = register_shared_expr ctx expr in <:expr< $id:id$ >>); register_expr_specifier "sql_check" (fun ctx _loc -> function "sqlite" -> expand_sqlite_check_functions ctx _loc | _ -> <:expr< () >>) ocaml-sqlexpr-0.5.5/setup.ml000066400000000000000000004357171215712740300160250ustar00rootroot00000000000000(* setup.ml generated for the first time by OASIS v0.3.0~rc3 *) (* OASIS_START *) (* DO NOT EDIT (digest: ccd9eaf3540d2c44a7a4a4bea21eb33a) *) (* Regenerated by OASIS v0.3.0~rc3 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISGettext.ml" let ns_ str = str let s_ str = str let f_ (str : ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISContext = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISContext.ml" open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { verbose: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { verbose = true; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; } let quiet = {!default with verbose = false; debug = false; } let args () = ["-quiet", Arg.Unit (fun () -> default := {!default with verbose = false}), (s_ " Run quietly"); "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), (s_ " Output debug message")] end module OASISUtils = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISUtils.ml" open OASISGettext module MapString = Map.Make(String) let map_string_of_assoc assoc = List.fold_left (fun acc (k, v) -> MapString.add k v acc) MapString.empty assoc module SetString = Set.Make(String) let set_string_add_list st lst = List.fold_left (fun acc e -> SetString.add e acc) st lst let set_string_of_list = set_string_add_list SetString.empty let compare_csl s1 s2 = String.compare (String.lowercase s1) (String.lowercase s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (String.lowercase s1) = (String.lowercase s2) let hash s = Hashtbl.hash (String.lowercase s) end) let split sep str = let str_len = String.length str in let rec split_aux acc pos = if pos < str_len then ( 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 = 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 ("" :: acc) ) else ( split_aux acc (pos_sep + 1) ) ) else ( List.rev acc ) in split_aux [] 0 let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buff = Buffer.create (String.length s) in (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then Buffer.add_char buff hyphen; String.iter (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then Buffer.add_char buff c else Buffer.add_char buff hyphen) s; String.lowercase (Buffer.contents buff) end let varname_concat ?(hyphen='_') p s = let p = let p_len = String.length p in if p_len > 0 && p.[p_len - 1] = hyphen then String.sub p 0 (p_len - 1) else p in let s = let s_len = String.length s in if s_len > 0 && s.[0] = hyphen then String.sub s 1 (s_len - 1) else s in Printf.sprintf "%s%c%s" p hyphen s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt let file_exists 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 end module PropList = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/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 # 71 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/PropList.ml" end module Schema = struct type ('ctxt, 'extra) value = { get: Data.t -> string; set: Data.t -> ?context:'ctxt -> string -> unit; help: (unit -> string) option; extra: 'extra; } type ('ctxt, 'extra) t = { name: name; fields: (name, ('ctxt, 'extra) value) Hashtbl.t; order: name Queue.t; name_norm: string -> string; } let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); name_norm = (if case_insensitive then String.lowercase else fun s -> s); } let add t nm set get extra help = let key = t.name_norm nm in if Hashtbl.mem t.fields key then failwith (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); Hashtbl.add t.fields key { set = set; get = get; help = help; extra = extra; }; Queue.add nm t.order let mem t nm = Hashtbl.mem t.fields nm let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> raise (Unknown_field (nm, t.name)) let get t data nm = (find t nm).get data let set t data nm ?context x = (find t nm).set data ?context x let fold f acc t = Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) acc t.order let iter f t = fold (fun () -> f) () t let name t = t.name end module Field = struct type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; get: Data.t -> 'value; sets: Data.t -> ?context:'ctxt -> string -> unit; gets: Data.t -> string; help: (unit -> string) option; extra: 'extra; } let new_id = let last_id = ref 0 in fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) let v = ref None in (* If name is not given, create unique one *) let nm = match name with | Some s -> s | None -> Printf.sprintf "_anon_%d" (new_id ()) in (* Last chance to get a value: the default *) let default () = match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in (* Get data *) let get data = (* Get value *) try (Hashtbl.find data nm) (); match !v with | Some x -> x | None -> default () with Not_found -> default () in (* Set data *) let set data ?context x = let x = match update with | Some f -> begin try f ?context (get data) x with Not_set _ -> x end | None -> x in Hashtbl.replace data nm (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> f | None -> fun ?context s -> failwith (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) in (* Set data, from string *) let sets data ?context s = set ?context data (parse ?context s) in (* Output value as string, if possible *) let print = match print with | Some f -> f | None -> fun _ -> raise (No_printer nm) in (* Get data, as a string *) let gets data = print (get data) in begin match schema with | Some t -> Schema.add t nm sets gets extra help | None -> () end; { set = set; get = get; sets = sets; gets = gets; help = help; extra = extra; } let fset data t ?context x = t.set data ?context x let fget data t = t.get data let fsets data t ?context s = t.sets data ?context s let fgets data t = t.gets data end module FieldRO = struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld end end module OASISMessage = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISMessage.ml" open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = match lvl with | `Debug -> ctxt.debug | _ -> ctxt.verbose 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 # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISVersion.ml" open OASISGettext type s = string type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = String.iter (fun c -> if is_alpha c || is_digit c || is_special c then () else failwith (Printf.sprintf (f_ "Char %C is not allowed in version '%s'") c str)) 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 # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/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 = { license: license; exceptions: license_exception list; version: license_version; } type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISExpr.ml" open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module OASISTypes = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISTypes.ml" type name = string type package_name = string type url = string type unix_dirname = string type unix_filename = string type host_dirname = string type host_filename = string type prog = string type arg = string type args = string list type command_line = (prog * arg list) type findlib_name = string type findlib_full = string type compiled_object = | Byte | Native | Best type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name | InternalExecutable of name type vcs = | Darcs | Git | Svn | Cvs | Hg | Bzr | Arch | Monotone | OtherVCS of url type plugin_kind = [ `Configure | `Build | `Doc | `Test | `Install | `Extra ] type plugin_data_purpose = [ `Configure | `Build | `Install | `Clean | `Distclean | `Install | `Uninstall | `Test | `Doc | `Extra | `Other of string ] type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list # 102 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISTypes.ml" type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; } type executable = { exec_custom: bool; exec_main_is: unix_filename; } type flag = { flag_description: string option; flag_default: bool conditional; } type source_repository = { src_repo_type: vcs; src_repo_location: url; src_repo_browser: url option; src_repo_module: string option; src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; } type test = { test_type: [`Test] plugin; test_command: command_line conditional; test_custom: custom; test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; } type doc_format = | HTML of unix_filename | DocText | PDF | PostScript | Info of unix_filename | DVI | OtherDoc type doc = { doc_type: [`Doc] plugin; doc_custom: custom; doc_build: bool conditional; doc_install: bool conditional; doc_install_dir: unix_filename; doc_title: string; doc_authors: string list; doc_abstract: string option; doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; } type section = | Library of common_section * build_section * library | 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 | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; name: package_name; version: OASISVersion.t; license: OASISLicense.t; license_file: unix_filename option; copyrights: string list; maintainers: string list; authors: string list; homepage: url option; synopsis: string; description: string option; categories: url list; conf_type: [`Configure] plugin; conf_custom: custom; build_type: [`Build] plugin; build_custom: custom; install_type: [`Install] plugin; install_custom: custom; uninstall_custom: custom; clean_custom: custom; distclean_custom: custom; files_ab: unix_filename list; sections: section list; plugins: [`Extra] plugin list; schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISUnixPath = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/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 concat f1 f2 = if f1 = current_dir_name then f2 else if f2 = current_dir_name then f1 else f1^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.capitalize base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize base) end module OASISSection = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISSection.ml" open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, 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) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section sct = let k, nm = section_id sct in (match k with | `Library -> "library" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc") ^" "^nm end module OASISBuildSection = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISBuildSection.ml" end module OASISExecutable = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/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 # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISLibrary.ml" open OASISTypes open OASISUtils open OASISGettext type library_name = name (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists (cs, bs, lib) modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) [modul; OASISUnixPath.uncapitalize_file modul; OASISUnixPath.capitalize_file modul] in (* TODO: we should be able to be able to determine the source for every * files. Hence we should introduce a Module(source: fn) for the fields * Modules and InternalModules *) List.fold_left (fun acc base_fn -> match acc with | `No_sources _ -> begin let file_found = List.fold_left (fun acc ext -> if source_file_exists (base_fn^ext) then (base_fn^ext) :: acc else acc) [] [".ml"; ".mli"; ".mll"; ".mly"] in match file_found with | [] -> acc | lst -> `Sources (base_fn, lst) end | `Sources _ -> acc) (`No_sources possible_base_fn) possible_base_fn let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, _) -> [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; lst in List.map (fun nm -> List.map (fun base_fn -> base_fn ^"."^ext) (find_module nm)) lst in (* The headers that should be compiled along *) let headers = if lib.lib_pack then [] else find_modules lib.lib_modules "cmi" in (* The .cmx that be compiled along *) let cmxs = let should_be_built = (not lib.lib_pack) && (* Do not install .cmx packed submodules *) match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath end else acc_nopath in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) type group_t = | Container of findlib_name * (group_t list) | Package of (findlib_name * common_section * build_section * library * (group_t list)) let group_libs pkg = (** Associate a name with its children *) let children = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> begin match lib.lib_findlib_parent with | Some p_nm -> begin let children = try MapString.find p_nm mp with Not_found -> [] in MapString.add p_nm ((cs, bs, lib) :: children) mp end | None -> mp end | _ -> mp) MapString.empty pkg.sections in (* Compute findlib name of a single node *) let findlib_name (cs, _, lib) = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in (** Build a package tree *) let rec tree_of_library containers ((cs, bs, lib) as acc) = match containers with | hd :: tl -> Container (hd, [tree_of_library tl acc]) | [] -> Package (findlib_name acc, cs, bs, lib, (try List.rev_map (fun ((_, _, child_lib) as child_acc) -> tree_of_library child_lib.lib_findlib_containers child_acc) (MapString.find cs.cs_name children) with Not_found -> [])) in (** Merge containers with the same name *) let rec merge_containers groups = (* Collect packages and create the map "container name -> merged children" *) let packages, containers = List.fold_left (fun (packages, containers) group -> match group with | Container(name, children) -> let children' = try MapString.find name containers with Not_found -> [] in (packages, MapString.add name (children' @ children) containers) | Package(name, cs, bs, lib, children) -> (Package(name, cs, bs, lib, merge_containers children) :: packages, containers)) ([], MapString.empty) groups in (* Recreate the list of groups *) packages @ (MapString.fold (fun name children acc -> Container(name, merge_containers children) :: acc) containers []) in (* TODO: check that libraries are unique *) merge_containers (List.fold_left (fun acc -> function | Library (cs, bs, lib) when lib.lib_findlib_parent = None -> (tree_of_library lib.lib_findlib_containers (cs, bs, lib)) :: acc | _ -> acc) [] pkg.sections) (** Compute internal to findlib library matchings, including subpackage and return a map of it. *) let findlib_name_map pkg = (* Compute names in a tree *) let rec findlib_names_aux path mp grp = let fndlb_nm, children, mp = match grp with | Container (fndlb_nm, children) -> fndlb_nm, children, mp | Package (fndlb_nm, {cs_name = nm}, _, _, children) -> fndlb_nm, children, (MapString.add nm (path, fndlb_nm) mp) in let fndlb_nm_full = (match path with | Some pth -> pth^"." | None -> "")^ fndlb_nm in List.fold_left (findlib_names_aux (Some fndlb_nm_full)) mp children in List.fold_left (findlib_names_aux None) MapString.empty (group_libs pkg) let findlib_of_name ?(recurse=false) map nm = try let (path, fndlb_nm) = MapString.find nm map in match path with | Some pth when recurse -> pth^"."^fndlb_nm | _ -> fndlb_nm with Not_found -> failwithf (f_ "Unable to translate internal library '%s' to findlib name") nm let name_findlib_map pkg = let mp = findlib_name_map pkg in MapString.fold (fun nm _ acc -> let fndlb_nm_full = findlib_of_name ~recurse:true mp nm in MapString.add fndlb_nm_full nm acc) mp MapString.empty let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = function | Container (_, children) -> root_lib_lst children | Package (_, cs, bs, lib, children) -> if lib.lib_findlib_parent = None then cs, bs, lib else root_lib_lst children and root_lib_lst = function | [] -> raise Not_found | hd :: tl -> try root_lib_aux hd with Not_found -> root_lib_lst tl in try root_lib_aux grp with Not_found -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISFlag.ml" end module OASISPackage = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISPackage.ml" end module OASISSourceRepository = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISSourceRepository.ml" end module OASISTest = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISTest.ml" end module OASISDocument = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISDocument.ml" end module BaseEnvLight = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let var_get name env = let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff in var_expand (MapString.find name env) let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end module BaseContext = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseContext.ml" open OASISContext let args = args let default = default end module BaseMessage = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/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 BaseFilePath = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseFilePath.ml" open Filename module Unix = OASISUnixPath let make = function | [] -> invalid_arg "BaseFilename.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = if Sys.os_type = "Unix" then ufn else make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISUtils.split '/' ufn)) end module BaseEnv = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseEnv.ml" open OASISGettext open OASISUtils open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> BaseFilePath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> BaseFilePath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (o, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (e : unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = BaseEnvLight.default_filename let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () let unload () = env_from_file := MapString.empty; Data.clear env let dump ?(filename=default_filename) () = let chn = open_out_bin filename in let output nm value = Printf.fprintf chn "%s=%S\n" nm value in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try let value = Schema.get schema env nm in output nm value with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; (* End of the dump *) close_out chn let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration: \n"; List.iter (fun (name,value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseExec = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseExec.ml" open OASISGettext open OASISUtils open BaseMessage let run ?f_exit_code cmd args = let cmdline = String.concat " " (cmd :: args) in info (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 ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in let () = try run ?f_exit_code cmd (args @ [">"; Filename.quote fn]) with e -> Sys.remove fn; raise e in let chn = open_in fn in let routput = ref [] in ( try while true do routput := (input_line chn) :: !routput done with End_of_file -> () ); close_in chn; Sys.remove fn; List.rev !routput let run_read_one_line ?f_exit_code cmd args = match run_read_output ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module BaseFileUtil = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseFileUtil.ml" open OASISGettext let find_file 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 OASISUtils.file_exists alternatives let which prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISUtils.split path_sep (Sys.getenv "PATH") in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISUtils.split path_sep (Sys.getenv "PATHEXT")) | _ -> [""] in find_file [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 src tgt = BaseExec.run (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir tgt = BaseExec.run (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent f tgt = let tgt = fix_dir tgt in if OASISUtils.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 f (Filename.dirname tgt); if not (OASISUtils.file_exists tgt) then begin f tgt; mkdir tgt end end let rmdir tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> BaseExec.run "rd" [q tgt] | _ -> BaseExec.run "rm" ["-r"; q tgt] end let glob 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 OASISUtils.file_exists fn then [fn] else [] end end module BaseArgExt = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/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 # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/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 (BaseFileUtil.which 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 = BaseExec.run_read_one_line (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 = BaseExec.run_read_one_line (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 # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/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 (BaseExec.run_read_output (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 # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseStandardVar.ml" open OASISGettext open OASISTypes open OASISExpr open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") (**/**) let 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 p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" then BaseFilePath.Unix.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" -> ".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 ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false") let docs = var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true") let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = if bool_of_string (is_native ()) then begin let ocamlfind = ocamlfind () in try let fn = BaseExec.run_read_one_line ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false end else false in string_of_bool res) let init pkg = rpkg := Some pkg end module BaseFileAB = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseFileAB.ml" open BaseEnv open OASISGettext open BaseMessage let to_filename fn = let fn = BaseFilePath.of_unix fn in if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; Filename.chop_extension fn let replace fn_lst = let buff = Buffer.create 13 in List.iter (fun fn -> let fn = BaseFilePath.of_unix fn in let chn_in = open_in fn in let chn_out = open_out (to_filename fn) in ( try while true do Buffer.add_string buff (var_expand (input_line chn_in)); Buffer.add_char buff '\n' done with End_of_file -> () ); Buffer.output_buffer chn_out buff; Buffer.clear buff; close_in chn_in; close_out chn_out) fn_lst end module BaseLog = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseLog.ml" open OASISUtils let default_filename = Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" module SetTupleString = Set.Make (struct type t = string * string let compare (s11, s12) (s21, s22) = match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) let load () = if Sys.file_exists default_filename then begin let chn = open_in default_filename in let scbuf = Scanf.Scanning.from_file default_filename in let rec read_aux (st, lst) = if not (Scanf.Scanning.end_of_input scbuf) then begin let acc = try Scanf.bscanf scbuf "%S %S\n" (fun e d -> let t = e, d in if SetTupleString.mem t st then st, lst else SetTupleString.add t st, t :: lst) with Scanf.Scan_failure _ -> failwith (Scanf.bscanf scbuf "%l" (fun line -> Printf.sprintf "Malformed log file '%s' at line %d" default_filename line)) in read_aux acc end else begin close_in chn; List.rev lst end in read_aux (SetTupleString.empty, []) end else begin [] end let register event data = let chn_out = open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename in Printf.fprintf chn_out "%S %S\n" event data; close_out chn_out let unregister event data = if Sys.file_exists default_filename then begin let lst = load () in let chn_out = open_out default_filename in let write_something = ref false in List.iter (fun (e, d) -> if e <> event || d <> data then begin write_something := true; Printf.fprintf chn_out "%S %S\n" e d end) lst; close_out chn_out; if not !write_something then Sys.remove default_filename end let filter events = let st_events = List.fold_left (fun st e -> SetString.add e st) SetString.empty events in List.filter (fun (e, _) -> SetString.mem e st_events) (load ()) let exists event data = List.exists (fun v -> (event, data) = v) (load ()) end module BaseBuilt = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseBuilt.ml" open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register t nm lst = BaseLog.register (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISUtils.file_exists fn then begin BaseLog.register (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else registered) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister t nm = List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [to_log_event_file t nm; to_log_event_done t nm]) let fold t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISUtils.file_exists 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") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter [to_log_event_file t nm]) let is_built t nm = List.fold_left (fun is_built (_, d) -> (try bool_of_string d with _ -> false)) false (BaseLog.filter [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISUtils.file_exists (BaseFilePath.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 end module BaseCustom = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseCustom.ml" open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = BaseExec.run (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 # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseDynVar.ml" open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init pkg = List.iter (function | Executable (cs, bs, exec) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) cs.cs_name (fun () -> let fn_opt = fold BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseTest.ml" open BaseEnv open BaseMessage open OASISTypes open OASISExpr open OASISGettext let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let (failed, n) = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg end module BaseDoc = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseDoc.ml" open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin pkg (cs, doc)) extra_args end in List.iter one_doc lst end module BaseSetup = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseSetup.ml" open BaseEnv open BaseMessage open OASISTypes open OASISSection open OASISGettext open OASISUtils type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load (); with _ -> () end; (* Run plugin's configure *) t.configure t.package args; (* Dump to allow postconf to change it *) dump ()) (); (* Reload environment *) unload (); load (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace t.package.files_ab let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args let doc t args = if bool_of_string (BaseStandardVar.docs ()) then BaseDoc.doc (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args else BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" let test t args = if bool_of_string (BaseStandardVar.tests ()) then BaseTest.test (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args else BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" let all t args = let rno_doc = ref false in let rno_test = ref false 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"; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure t [||]; info "Running build step"; build t [||]; (* Load setup.log dynamic variables *) BaseDynVar.init t.package; if not !rno_doc then begin info "Running doc step"; doc t [||]; end else begin info "Skipping doc step" end; if not !rno_test then begin info "Running test step"; test t [||] end else begin info "Skipping test step" end let install t args = BaseCustom.hook t.package.install_custom (t.install t.package) args let uninstall t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall t.package) args let reinstall t args = uninstall t args; install t args let clean, distclean = let failsafe f a = try f a with e -> warning (f_ "Action fail with error: %s") (match e with | Failure msg -> msg | e -> Printexc.to_string e) in let generic_clean t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm (fun () -> (* Clean section *) List.iter (function | Test (cs, test) -> let f = try List.assoc cs.cs_name tests with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, test)) args | Doc (cs, doc) -> let f = try List.assoc cs.cs_name docs with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, doc)) args | Library _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f t.package) args) mains) () in let clean t args = generic_clean t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean t args = (* Call clean *) clean t args; (* Remove generated file *) List.iter (fun fn -> if Sys.file_exists fn then begin info (f_ "Remove '%s'") fn; Sys.remove fn end) (BaseEnv.default_filename :: BaseLog.default_filename :: (List.rev_map BaseFileAB.to_filename t.package.files_ab)); (* Call distclean code *) generic_clean t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args in clean, distclean let version t _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> "_oasis" 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 = BaseExec.run_read_one_line ~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 BaseExec.run ~f_exit_code: (function | 0 -> () | n -> failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); BaseExec.run 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 "_oasis" then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in try let act_ref = ref (fun _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in Arg.parse (Arg.align [ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; no_update_setup_ml_cli; ] @ (BaseContext.args ())) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n"); (* Build initial environment *) load ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init t.package; if not (update_setup_ml t) then !act_ref t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end module InternalConfigurePlugin = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/internal/InternalConfigurePlugin.ml" (** Configure using internal scheme @author Sylvain Le Gall *) open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage (** Configure build using provided series of check to be done * and then output corresponding file. *) let configure pkg argv = let var_ignore_eval var = let _s : string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf (fun b -> errors := SetString.add (Buffer.contents b) !errors; Buffer.clear b) buff fmt in let warn_exception e = warning "%s" (Printexc.to_string e) in (* Check tools *) let check_tools lst = List.iter (function | ExternalTool tool -> begin try var_ignore_eval (BaseCheck.prog tool) with e -> warn_exception e; add_errors (f_ "Cannot find external tool '%s'") tool end | InternalExecutable nm1 -> (* Check that matching tool is built *) List.iter (function | Executable ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal executable \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) lst in let build_checks sct bs = if var_choose bs.bs_build then begin if bs.bs_compiled_object = Native then begin try var_ignore_eval BaseStandardVar.ocamlopt with e -> warn_exception e; add_errors (f_ "Section %s requires native compilation") (OASISSection.string_of_section sct) end; (* Check tools *) check_tools bs.bs_build_tools; (* Check depends *) List.iter (function | FindlibPackage (findlib_pkg, version_comparator) -> begin try var_ignore_eval (BaseCheck.package ?version_comparator findlib_pkg) with e -> warn_exception e; match version_comparator with | None -> add_errors (f_ "Cannot find findlib package %s") findlib_pkg | Some ver_cmp -> add_errors (f_ "Cannot find findlib package %s (%s)") findlib_pkg (OASISVersion.string_of_comparator ver_cmp) end | InternalLibrary nm1 -> (* Check that matching library is built *) List.iter (function | Library ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal library \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) bs.bs_build_depends end in (* Parse command line *) BaseArgExt.parse argv (BaseEnv.args ()); (* OCaml version *) begin match pkg.ocaml_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "ocaml" ver_cmp BaseStandardVar.ocaml_version) with e -> warn_exception e; add_errors (f_ "OCaml version %s doesn't match version constraint %s") (BaseStandardVar.ocaml_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Findlib version *) begin match pkg.findlib_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "findlib" ver_cmp BaseStandardVar.findlib_version) with e -> warn_exception e; add_errors (f_ "Findlib version %s doesn't match version constraint %s") (BaseStandardVar.findlib_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* 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 # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/internal/InternalInstallPlugin.ml" (** Install using internal scheme @author Sylvain Le Gall *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISLibrary open OASISGettext open OASISUtils let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) let doc_hook = ref (fun (cs, doc) -> cs, doc) let install_file_ev = "install-file" let install_dir_ev = "install-dir" let install_findlib_ev = "install-findlib" let install pkg argv = let in_destdir = try let destdir = destdir () in (* Practically speaking destdir is prepended * at the beginning of the target filename *) fun fn -> destdir^fn with PropList.Not_set _ -> fun fn -> fn in let install_file ?tgt_fn src_file envdir = let tgt_dir = in_destdir (envdir ()) in let tgt_file = Filename.concat tgt_dir (match tgt_fn with | Some fn -> fn | None -> Filename.basename src_file) in (* Create target directory if needed *) BaseFileUtil.mkdir_parent (fun dn -> info (f_ "Creating directory '%s'") dn; BaseLog.register install_dir_ev dn) tgt_dir; (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; BaseFileUtil.cp src_file tgt_file; BaseLog.register install_file_ev tgt_file in (* Install data into defined directory *) let install_data srcdir lst tgtdir = let tgtdir = BaseFilePath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> let real_srcs = BaseFileUtil.glob (Filename.concat srcdir src) in if real_srcs = [] then failwithf (f_ "Wildcard '%s' doesn't match any files") src; List.iter (fun fn -> install_file fn (fun () -> match tgt_opt with | Some s -> BaseFilePath.of_unix (var_expand s) | None -> tgtdir)) real_srcs) lst in (** Install all libraries *) let install_libs pkg = let files_of_library (f_data, acc) data_lib = let cs, bs, lib, lib_extra = !lib_hook data_lib in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then begin let acc = (* Start with acc + lib_extra *) List.rev_append lib_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = BaseFilePath.of_unix bs.bs_path in List.fold_left (fun acc modul -> try List.find OASISUtils.file_exists (List.map (Filename.concat path) [modul^".mli"; modul^".ml"; String.uncapitalize modul^".mli"; String.capitalize modul^".mli"; String.uncapitalize modul^".ml"; String.capitalize modul^".ml"]) :: acc with Not_found -> begin warning (f_ "Cannot find source header for module %s \ in library %s") modul cs.cs_name; acc end) acc lib.lib_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BLib cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the library *) install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end 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, lib, children) -> files_of_library data_and_files (cs, bs, lib), 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 (OASISUtils.file_exists res) then failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) let remove_prefix p n = let plen = String.length p in let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in String.sub n cutpoint (nlen - cutpoint) end else n in List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") findlib_name; BaseExec.run (ocamlfind ()) ("install" :: findlib_name :: meta :: files); BaseLog.register install_findlib_ev findlib_name end; (* Install data files *) f_data (); in (* We install libraries in groups *) List.iter install_group_lib (group_libs pkg) in let install_execs pkg = let install_exec data_exec = let (cs, bs, exec) = !exec_hook data_exec in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then begin let exec_libdir () = Filename.concat (libdir ()) pkg.name in BaseBuilt.fold BaseBuilt.BExec cs.cs_name (fun () fn -> install_file ~tgt_fn:cs.cs_name fn bindir) (); BaseBuilt.fold BaseBuilt.BExecLib cs.cs_name (fun () fn -> install_file fn exec_libdir) (); install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name) end in List.iter (function | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) | _ -> ()) pkg.sections in let install_docs pkg = let install_doc data = let (cs, doc) = !doc_hook data in if var_choose doc.doc_install && BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then begin let tgt_dir = BaseFilePath.of_unix (var_expand doc.doc_install_dir) in BaseBuilt.fold BaseBuilt.BDoc cs.cs_name (fun () fn -> install_file fn (fun () -> tgt_dir)) (); install_data Filename.current_dir_name doc.doc_data_files doc.doc_install_dir end in List.iter (function | Doc (cs, doc) -> install_doc (cs, doc) | _ -> ()) pkg.sections in install_libs pkg; install_execs pkg; install_docs pkg (* Uninstall already installed data *) let uninstall _ argv = List.iter (fun (ev, data) -> if ev = install_file_ev then begin if OASISUtils.file_exists 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 OASISUtils.file_exists data && Sys.is_directory data then begin if Sys.readdir data = [||] then begin info (f_ "Removing directory '%s'") data; BaseFileUtil.rmdir 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; BaseExec.run (ocamlfind ()) ["remove"; data] end else failwithf (f_ "Unknown log event '%s'") ev; BaseLog.unregister ev data) (* We process event in reverse order *) (List.rev (BaseLog.filter [install_file_ev; install_dir_ev; install_findlib_ev;])) end module OCamlbuildCommon = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/ocamlbuild/OCamlbuildCommon.ml" (** Functions common to OCamlbuild build and doc plugin *) open OASISGettext open BaseEnv open BaseStandardVar let ocamlbuild_clean_ev = "ocamlbuild-clean" let ocamlbuildflags = var_define ~short_desc:(fun () -> "OCamlbuild additional flags") "ocamlbuildflags" (fun () -> "") (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten [ if (os_type ()) = "Win32" then [ "-classic-display"; "-no-log"; "-no-links"; "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") ] else []; if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then [ "-byte-plugin" ] else []; args; if bool_of_string (debug ()) then ["-tag"; "debug"] else []; if bool_of_string (profile ()) then ["-tag"; "profile"] else []; OASISUtils.split ' ' (ocamlbuildflags ()); Array.to_list extra_argv; ] (** Run 'ocamlbuild -clean' if not already done *) let run_clean extra_argv = let extra_cli = String.concat " " (Array.to_list extra_argv) in (* Run if never called with these args *) if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then begin BaseExec.run (ocamlbuild ()) (fix_args ["-clean"] extra_argv); BaseLog.register ocamlbuild_clean_ev extra_cli; at_exit (fun () -> try BaseLog.unregister ocamlbuild_clean_ev extra_cli with _ -> ()) end (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html *) BaseExec.run (ocamlbuild ()) (fix_args args extra_argv); (* Remove any clean event, we must run it again *) List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [ocamlbuild_clean_ev]) (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = function | "-build-dir" :: dir :: tl -> search_args dir tl | _ :: tl -> search_args dir tl | [] -> dir in search_args "_build" (fix_args [] extra_argv) end module OCamlbuildPlugin = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" (** Build using ocamlbuild @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISUtils open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage let cond_targets_hook = ref (fun lst -> lst) let build 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 (BaseFilePath.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 ends_with nd fn = let nd_len = String.length nd in (String.length fn >= nd_len) && (String.sub fn (String.length fn - nd_len) nd_len) = nd in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ".cma" fn || ends_with ".cmxs" fn || ends_with ".cmxa" fn || ends_with (ext_lib ()) fn || ends_with (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 | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) in let target ext = let unix_tgt = (BaseFilePath.Unix.concat bs.bs_path (BaseFilePath.Unix.chop_extension exec.exec_main_is))^ext in let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs in evs, [unix_tgt] in (* Add executable *) let acc = match bs.bs_compiled_object with | Native -> (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte | Best -> (target ".byte") :: acc in acc end | Library _ | 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 OASISUtils.file_exists fns) then failwithf (f_ "No one of expected built files %s exists") (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in let cond_targets = (* Run the hook *) !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild (List.flatten (List.map snd cond_targets)) argv; (* ... and register events *) List.iter check_and_register (List.flatten (List.map fst cond_targets)) let clean pkg extra_args = run_clean extra_args; List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections end module OCamlbuildDocPlugin = struct # 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISMessage open OCamlbuildCommon open BaseStandardVar let doc_build path pkg (cs, doc) argv = let index_html = BaseFilePath.Unix.make [ path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = BaseFilePath.make [ build_dir argv; BaseFilePath.of_unix path; cs.cs_name^".docdir"; ] in run_ocamlbuild [index_html] argv; List.iter (fun glb -> BaseBuilt.register BaseBuilt.BDoc cs.cs_name [BaseFileUtil.glob (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] let doc_clean t pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name end open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build; test = []; doc = [("sqlexpr", OCamlbuildDocPlugin.doc_build ".")]; install = InternalInstallPlugin.install; uninstall = InternalInstallPlugin.uninstall; clean = [OCamlbuildPlugin.clean]; clean_test = []; clean_doc = [("sqlexpr", OCamlbuildDocPlugin.doc_clean ".")]; distclean = []; distclean_test = []; distclean_doc = []; package = { oasis_version = "0.3"; ocaml_version = None; findlib_version = None; name = "ocaml-sqlexpr"; version = "0.5.5"; license = OASISLicense.DEP5License { OASISLicense.license = "LGPL"; exceptions = ["OCaml linking"]; version = OASISLicense.Version "2.1"; }; license_file = None; copyrights = []; maintainers = ["Mauricio Fernandez "]; authors = ["Mauricio Fernandez "]; homepage = Some "http://github.com/mfp/ocaml-sqlexpr"; synopsis = "Type-safe, convenient SQLite database access."; description = Some "Minimalistic library and syntax extension for type-safe, convenient execution\nof SQL statements. Currently compatible with Sqlite3.\n\nSqlexpr features:\n\n* automated prepared statement caching, param binding, data extraction, error\n checking (including automatic stmt reset to avoid BUSY/LOCKED errors in\n subsequent queries), stmt finalization on db close, etc.\n\n* HOFs like iter, fold, transaction\n\n* support for different concurrency models: everything is functorized over a\n THREAD monad, so you can for instance do concurrent folds/iters with Lwt\n\n* support for SQL stmt syntax checks and some extra semantic checking (column\n names, etc)"; categories = []; conf_type = (`Configure, "internal", Some "0.3"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; build_type = (`Build, "ocamlbuild", Some "0.3"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; install_type = (`Install, "internal", Some "0.3"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; files_ab = []; sections = [ Doc ({ cs_name = "sqlexpr"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { doc_type = (`Doc, "ocamlbuild", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; doc_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "docs", true) ]; doc_install = [(OASISExpr.EBool true, true)]; doc_install_dir = "$htmldir/sqlexpr"; doc_title = "API reference for Sqlexpr"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = []; doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; }); Library ({ cs_name = "sqlexpr_syntax"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "."; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("camlp4.lib", None); FindlibPackage ("camlp4.quotations.r", None); FindlibPackage ("estring", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { lib_modules = ["Pa_sql"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "sqlexpr"; lib_findlib_name = Some "syntax"; lib_findlib_containers = []; }); Library ({ cs_name = "sqlexpr"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "."; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("csv", None); FindlibPackage ("batteries", None); FindlibPackage ("sqlite3", None); FindlibPackage ("estring", None); FindlibPackage ("lwt", Some (OASISVersion.VGreaterEqual "2.2.0")); FindlibPackage ("lwt.syntax", None); FindlibPackage ("lwt.unix", None); FindlibPackage ("unix", None); FindlibPackage ("threads", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "ocamlbuild" ]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { lib_modules = [ "Sqlexpr_concurrency"; "Sqlexpr_sqlite"; "Sqlexpr_sqlite_lwt" ]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = []; }); SrcRepo ({ cs_name = "github"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { src_repo_type = Git; src_repo_location = "git://github.com/mfp/ocaml-sqlexpr.git"; src_repo_browser = None; src_repo_module = None; src_repo_branch = None; src_repo_tag = None; src_repo_subdir = None; }) ]; plugins = [(`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3")]; schema_data = PropList.Data.create (); plugin_data = []; }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0~rc3"; oasis_digest = Some "\bG\174\172EN\182VF8\027\012\023k\029_"; oasis_exec = None; oasis_setup_args = []; };; let setup () = BaseSetup.setup setup_t;; # 5415 "setup.ml" (* OASIS_STOP *) let () = setup ();; ocaml-sqlexpr-0.5.5/sqlexpr.mllib000066400000000000000000000002121215712740300170240ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 219809673045ff2e78607ac0875b3fb1) Sqlexpr_concurrency Sqlexpr_sqlite Sqlexpr_sqlite_lwt # OASIS_STOP ocaml-sqlexpr-0.5.5/sqlexpr.odocl000066400000000000000000000002121215712740300170250ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 219809673045ff2e78607ac0875b3fb1) Sqlexpr_concurrency Sqlexpr_sqlite Sqlexpr_sqlite_lwt # OASIS_STOP ocaml-sqlexpr-0.5.5/sqlexpr_concurrency.ml000066400000000000000000000045201215712740300207550ustar00rootroot00000000000000 module type THREAD_LOCAL_STATE = sig type 'a t type 'a key val new_key : unit -> 'a key val get : 'a key -> 'a option val with_value : 'a key -> 'a option -> (unit -> 'b t) -> 'b t end module type THREAD = sig type 'a t val return : 'a -> 'a t val bind : 'a t -> ('a -> 'b t) -> 'b t val fail : exn -> 'a t val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t val sleep : float -> unit t val auto_yield : float -> (unit -> unit t) type mutex val create_recursive_mutex : unit -> mutex val with_lock : mutex -> (unit -> 'a t) -> 'a t val register_finaliser : ('a -> unit t) -> 'a -> unit include THREAD_LOCAL_STATE with type 'a t := 'a t end module Id = struct type 'a t = 'a let return x = x let bind x f = f x let fail = raise let catch f g = try f () with e -> g e let finalize f g = match try `Ok (f ()) with e -> `Exn e with `Ok x -> g (); x | `Exn e -> g (); raise e let sleep dt = let _, _, _ = Unix.select [] [] [] dt in () let auto_yield _ = (fun () -> ()) type mutex = unit let create_recursive_mutex () = () let with_lock () f = f () type 'a key = 'a Lwt.key let new_key = Lwt.new_key let get = Lwt.get let with_value = Lwt.with_value let register_finaliser f x = (* FIXME: should run finalisers sequentially in separate thread *) Gc.finalise f x end module Lwt = struct include Lwt let auto_yield = Lwt_unix.auto_yield let sleep = Lwt_unix.sleep type mutex = { id : int; m : Lwt_mutex.t } let new_id = let n = ref 0 in (fun () -> incr n; !n) module LOCKS = Set.Make(struct type t = int let compare (x : int) y = if x < y then -1 else if x > y then 1 else 0 end) let locks = Lwt.new_key () let create_recursive_mutex () = { id = new_id (); m = Lwt_mutex.create () } let with_lock m f = match Lwt.get locks with None -> Lwt_mutex.with_lock m.m (fun () -> Lwt.with_value locks (Some (LOCKS.singleton m.id)) f) | Some s when LOCKS.mem m.id s -> f () | Some s -> Lwt_mutex.with_lock m.m (fun () -> Lwt.with_value locks (Some (LOCKS.add m.id s)) f) let register_finaliser = Lwt_gc.finalise end ocaml-sqlexpr-0.5.5/sqlexpr_concurrency.mli000066400000000000000000000033551215712740300211330ustar00rootroot00000000000000(** Concurrency monad. *) (** Thread local state. *) module type THREAD_LOCAL_STATE = sig type 'a t type 'a key val new_key : unit -> 'a key val get : 'a key -> 'a option val with_value : 'a key -> 'a option -> (unit -> 'b t) -> 'b t end (** The THREAD monad. *) module type THREAD = sig type 'a t val return : 'a -> 'a t val bind : 'a t -> ('a -> 'b t) -> 'b t val fail : exn -> 'a t val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t val sleep : float -> unit t val auto_yield : float -> unit -> unit t type mutex (** Create a recursive mutex that can be locked recursively by the same * thread; i.e., unlike a regular mutex, * [with_lock m (fun () -> ... with_lock m (fun () -> ... ))] * will not block. *) val create_recursive_mutex : unit -> mutex (* [with_lock m f] blocks until the [m] mutex can be locked, runs [f ()] and * unlocks the mutex (also if [f ()] raises an exception) *) val with_lock : mutex -> (unit -> 'a t) -> 'a t val register_finaliser : ('a -> unit t) -> 'a -> unit include THREAD_LOCAL_STATE with type 'a t := 'a t end (** Identity concurrency monad. Note that [Id.mutex] is a dummy type that * doesn't actually work like a mutex (i.e., [Id.with_lock m f] is equivalent * to [f ()]. This is so because in ocaml-sqlexpr's context [Sqlite] handles * can only be used from the thread where they were created, so there's no * need for mutual exclusion because trying to use the same handle from * different threads would be an error anyway. *) module Id : THREAD with type 'a t = 'a and type 'a key = 'a Lwt.key (** Lwt concurrency monad. *) module Lwt : THREAD with type 'a t = 'a Lwt.t and type 'a key = 'a Lwt.key ocaml-sqlexpr-0.5.5/sqlexpr_sqlite.ml000066400000000000000000000626671215712740300177440ustar00rootroot00000000000000 open Printf module List = struct include List include BatList end module Option = BatOption exception Error of string * exn exception Sqlite_error of string * Sqlite3.Rc.t let tx_id_counter = ref 0 let curr_thread_id () = Thread.id (Thread.self ()) let raise_thread_error ?msg expected = let actual = curr_thread_id () in let s = sprintf "Trying to run Sqlite3 function in different thread \ than the one where the db was created \ (expected %d, got %d)%s." expected actual (Option.map_default ((^) " ") "" msg) in raise (Error (s, (Failure s))) module Stmt = struct type t = { thread_id : int; dbhandle : Sqlite3.db; handle : Sqlite3.stmt; } let check_thread t = if curr_thread_id () <> t.thread_id then raise_thread_error ~msg:"in Stmt" t.thread_id let wrap f t = check_thread t; f t.handle let prepare dbhandle sql = { thread_id = curr_thread_id (); dbhandle = dbhandle; handle = Sqlite3.prepare dbhandle sql; } let db_handle t = t.dbhandle let finalize t = ignore (wrap Sqlite3.finalize t) let reset = wrap Sqlite3.reset let step = wrap Sqlite3.step let bind t n v = check_thread t; Sqlite3.bind t.handle n v let row_data = wrap Sqlite3.row_data end module Types = struct (* (params, nparams, sql, stmt_id) *) type st = (Sqlite3.Data.t list * int * string * string option) end include Types let () = Printexc.register_printer (function | Error (s, exn) -> Some (sprintf "Sqlexpr_sqlite.Error (%S, %s)" s (Printexc.to_string exn)) | Sqlite_error (s, rc) -> Some (sprintf "Sqlexpr_sqlite.Sqlite_error (%S, %s)" s (Sqlite3.Rc.to_string rc)) | _ -> None) let new_id = let n = ref 0 in fun () -> incr n; !n module Stmt_cache = struct module H = Hashtbl.Make (struct type t = string let hash s = Char.code (String.unsafe_get s 0) + Char.code (String.unsafe_get s 1) lsl 8 + Char.code (String.unsafe_get s 2) lsl 16 + Char.code (String.unsafe_get s 3) lsl 24 let equal (s1 : string) s2 = s1 = s2 end) type t = Stmt.t H.t let create () = H.create 13 let flush_stmts t = H.clear t let find_remove_stmt t id = try let r = H.find t id in H.remove t id; Some r with Not_found -> None let add_stmt t id stmt = H.add t id stmt end module type THREAD = Sqlexpr_concurrency.THREAD let prettify_sql_stmt sql = let b = Buffer.create 80 in let last_was_space = ref false in for i = 0 to String.length sql - 1 do match sql.[i] with '\r' | '\n' | '\t' | ' ' -> if not !last_was_space then Buffer.add_char b ' '; last_was_space := true | c -> Buffer.add_char b c; last_was_space := false done; (Buffer.contents b) let string_of_param = function Sqlite3.Data.NONE -> "NONE" | Sqlite3.Data.NULL -> "NULL" | Sqlite3.Data.INT n -> Int64.to_string n | Sqlite3.Data.FLOAT f -> string_of_float f | Sqlite3.Data.TEXT s | Sqlite3.Data.BLOB s -> sprintf "%S" s let string_of_params l = String.concat ", " (List.map string_of_param l) module Directives = struct module D = Sqlite3.Data type ('a, 'b) statement = { sql_statement : string; stmt_id : string option; directive : ('a, 'b) directive } and ('a, 'b) directive = (st -> 'b) -> st -> 'a let literal x k st = k st let param f k (params, nparams, sql, prep) x = k (f x :: params, nparams + 1, sql, prep) let int k st n = param (fun n -> D.INT (Int64.of_int n)) k st n let int64 k st n = param (fun n -> D.INT n) k st n let int32 k st n = param (fun n -> D.INT (Int64.of_int32 n)) k st n let text k st s = param (fun s -> D.TEXT s) k st s let blob k st s = param (fun s -> D.BLOB s) k st s let float k st f = param (fun f -> D.FLOAT f) k st f let bool k st b = param (fun b -> D.INT (if b then 1L else 0L)) k st b let any k st f x = blob k st (f x) let maybe_int k st n = param (Option.map_default (fun n -> D.INT (Int64.of_int n)) D.NULL) k st n let maybe_int32 k st n = param (Option.map_default (fun n -> D.INT (Int64.of_int32 n)) D.NULL) k st n let maybe_int64 k st n = param (Option.map_default (fun n -> D.INT n) D.NULL) k st n let maybe_text k st s = param (Option.map_default (fun s -> D.TEXT s) D.NULL) k st s let maybe_blob k st s = param (Option.map_default (fun s -> D.BLOB s) D.NULL) k st s let maybe_float k st f = param (Option.map_default (fun f -> D.FLOAT f) D.NULL) k st f let maybe_bool k st b = param (Option.map_default (fun b -> D.INT (if b then 1L else 0L)) D.NULL) k st b let maybe_any k st f x = maybe_blob k st (Option.map f x) end module Conversion = struct open Sqlite3.Data let failwithfmt fmt = ksprintf failwith fmt let error s x = failwithfmt "Sqlexpr_sqlite error: bad data (expected %s but got %s)" s (Sqlite3.Data.to_string_debug x) let text = function TEXT s | BLOB s -> s | INT n -> Int64.to_string n | FLOAT f -> string_of_float f | x -> error "text" x let blob = function BLOB s | TEXT s -> s | x -> error "blob" x let int = function INT n -> Int64.to_int n | x -> error "int" x let int32 = function INT n -> Int64.to_int32 n | x -> error "int" x let int64 = function INT n -> n | x -> error "int" x let bool = function INT 0L -> false | INT _ -> true | x -> error "int" x let float = function INT n -> Int64.to_float n | FLOAT n -> n | x -> error "float" x let maybe f = function NULL -> None | x -> Some (f x) let maybe_text = maybe text let maybe_blob = maybe blob let maybe_int = maybe int let maybe_int32 = maybe int32 let maybe_int64 = maybe int64 let maybe_float = maybe float let maybe_bool = maybe bool end type 'a ret = Ret of 'a | Exn of exn let profile_ch = try Some (open_out_gen [Open_append; Open_creat; Open_binary] 0o644 (Unix.getenv "OCAML_SQLEXPR_PROFILE")) with Not_found -> None let raw_profile_ch = try Some (open_out_gen [Open_append; Open_creat; Open_binary] 0o644 (Unix.getenv "OCAML_SQLEXPR_LOG")) with Not_found -> None let profile_uuid = let uuid = sprintf "%s %d %d %g %s %g" (Unix.gethostname ()) (Unix.getpid ()) (Unix.getppid ()) (Unix.gettimeofday ()) Sys.executable_name ((Unix.times ()).Unix.tms_utime) in Digest.to_hex (Digest.string uuid) (* pgocaml_prof wants to see a connect entry *) let () = Option.may (fun ch -> let detail = [ "user"; ""; "database"; ""; "host"; ""; "port"; "0"; "prog"; Sys.executable_name ] in Csv.save_out ch [[ "1"; profile_uuid; "connect"; "0"; "ok" ] @ detail]; flush ch) profile_ch module Error(M : THREAD) = struct let raise_exn ?(msg="") exn = M.fail (Error (msg, exn)) let failwithfmt fmt = Printf.ksprintf (fun s -> M.fail (Error (s, Failure s))) fmt end module Profile(Lwt : Sqlexpr_concurrency.THREAD) = struct open Lwt let profile_op ?(uuid = profile_uuid) op detail f = match profile_ch with None -> f () | Some ch -> let t0 = Unix.gettimeofday () in lwt ret = try_lwt lwt y = f () in return (Ret y) with e -> return (Exn e) in let dt = Unix.gettimeofday () -. t0 in let elapsed_time_us = int_of_float (1e6 *. dt) in (* the format used by PGOcaml *) let ret_txt = match ret with Ret _ -> "ok" | Exn e -> Printexc.to_string e in let row = [ "1"; uuid; op; string_of_int elapsed_time_us; ret_txt] @ detail in Csv.save_out ch [row]; flush ch; match ret with Ret r -> return r | Exn e -> raise_lwt e (* accept a reversed list of params *) let profile_execute_sql sql ?(params = []) f = match profile_ch with None -> f () | Some ch -> let details = [ "name"; Digest.to_hex (Digest.string sql); "portal"; " " ] in profile_op "execute" details f let profile_execute_sql sql ?(full_sql=sql) ?params f = let param_str = match params with None -> "" | Some l -> String.concat "\t" (List.rev_map string_of_param l) in Option.may (fun ch -> fprintf ch "%s\t%s\n%!" (String.escaped full_sql) param_str) raw_profile_ch; profile_execute_sql sql ?params f let profile_prepare_stmt sql f = match profile_ch with None -> f () | Some ch -> let details = [ "query"; sql; "name"; Digest.to_hex (Digest.string sql) ] in profile_op "prepare" details f end module type POOL = sig type 'a result module TLS : Sqlexpr_concurrency.THREAD_LOCAL_STATE with type 'a t := 'a result type db type stmt val open_db : ?init:(Sqlite3.db -> unit) -> string -> db val close_db : db -> unit val prepare : db -> (stmt -> string -> Sqlite3.Data.t list -> 'a result) -> st -> 'a result val step : ?sql:string -> ?params:Sqlite3.Data.t list -> stmt -> Sqlite3.Rc.t result val step_with_last_insert_rowid : ?sql:string -> ?params:Sqlite3.Data.t list -> stmt -> Int64.t result val reset : stmt -> unit result val row_data : stmt -> Sqlite3.Data.t array result val raise_error : stmt -> ?sql:string -> ?params:Sqlite3.Data.t list -> ?errmsg:string -> Sqlite3.Rc.t -> 'a result val unsafe_execute : db -> ?retry_on_busy:bool -> string -> unit result val borrow_worker : db -> (db -> 'a result) -> 'a result val steal_worker : db -> (db -> 'a result) -> 'a result val transaction_key : db -> unit TLS.key end module WT = Weak.Make(struct type t = Stmt.t let hash = Hashtbl.hash let equal = (==) end) type single_worker_db = { handle : Sqlite3.db; thread_id : int; id : int; stmts : WT.t; stmt_cache : Stmt_cache.t; } let identity_pool_transaction_key_table = Hashtbl.create 13 module IdentityPool(M: THREAD with type 'a key = 'a Lwt.key) = struct module Lwt = M open Lwt include Profile(M) include Error(M) type db = single_worker_db type stmt = Stmt.t type 'a result = 'a Lwt.t let get_handle db = db.handle let transaction_key = let t = identity_pool_transaction_key_table in (fun db -> try Hashtbl.find t db.id with Not_found -> let k = M.new_key () in Hashtbl.add t db.id k; register_finaliser (fun db -> Hashtbl.remove t db.id; return ()) db; k) let handle db = if db.thread_id <> curr_thread_id () then try_lwt (raise_thread_error ~msg:"in IdentityPool.handle" db.thread_id) else return db.handle let close_db db = try WT.iter (fun stmt -> Stmt.finalize stmt) db.stmts; Stmt_cache.flush_stmts db.stmt_cache; ignore begin try_lwt lwt db = handle db in ignore (Sqlite3.db_close db); return () with e -> (* FIXME: log? *) return () end with Sqlite3.Error _ -> () (* FIXME: raise? *) let mutex_tbl = Hashtbl.create 13 let get_db_mutex db = (* different modules having the same type db = single_worker_db will have * different mutex_tbl tables, so must create the mutex lazily *) let id = db.id in try Hashtbl.find mutex_tbl id with Not_found -> let m = M.create_recursive_mutex () in Hashtbl.add mutex_tbl id m; M.register_finaliser (fun _ -> Hashtbl.remove mutex_tbl id; return ()) db; m let make handle = let id = new_id () in { handle = handle; id = id; stmts = WT.create 13; thread_id = Thread.id (Thread.self ()); stmt_cache = Stmt_cache.create (); } let open_db ?(init = fun _ -> ()) fname = let handle = Sqlite3.db_open fname in init handle; make handle let raise_error db ?sql ?params ?(errmsg = Sqlite3.errmsg db) errcode = let msg = Sqlite3.Rc.to_string errcode ^ " " ^ errmsg in let msg = match sql with None -> msg | Some sql -> sprintf "%s in %s" msg (prettify_sql_stmt sql) in let msg = match params with None | Some [] -> msg | Some params -> sprintf "%s with params %s" msg (string_of_params (List.rev params)) in M.fail (Error (msg, Sqlite_error (msg, errcode))) let rec run ?(retry_on_busy=false) ?stmt ?sql ?params db f x = match f x with Sqlite3.Rc.OK | Sqlite3.Rc.ROW | Sqlite3.Rc.DONE as r -> return r | Sqlite3.Rc.BUSY when retry_on_busy -> M.sleep 0.010 >> run ~retry_on_busy ?sql ?stmt ?params db f x | code -> let errmsg = Sqlite3.errmsg db in Option.may (fun stmt -> ignore (Stmt.reset stmt)) stmt; raise_error db ?sql ?params ~errmsg code let check_ok ?retry_on_busy ?stmt ?sql ?params db f x = lwt _ = run ?retry_on_busy ?stmt ?sql ?params db f x in return () let prepare db f (params, nparams, sql, stmt_id) = lwt dbh = handle db in lwt stmt = try_lwt match stmt_id with None -> profile_prepare_stmt sql (fun () -> let stmt = Stmt.prepare dbh sql in WT.add db.stmts stmt; return stmt) | Some id -> match Stmt_cache.find_remove_stmt db.stmt_cache id with Some stmt -> begin try_lwt check_ok ~stmt dbh Stmt.reset stmt with e -> (* drop the stmt *) Stmt.finalize stmt; fail e end >> return stmt | None -> profile_prepare_stmt sql (fun () -> let stmt = Stmt.prepare dbh sql in WT.add db.stmts stmt; return stmt) with e -> let msg = sprintf "Error with SQL statement %S:\n%s" sql (Printexc.to_string e) in raise_exn ~msg e in let rec iteri ?(i = 0) f = function [] -> return () | hd :: tl -> f i hd >> iteri ~i:(i + 1) f tl in (* the list of params is reversed *) iteri (fun n v -> check_ok ~sql ~stmt dbh (Stmt.bind stmt (nparams - n)) v) params >> profile_execute_sql ~full_sql:sql sql ~params (fun () -> try_lwt f stmt sql params finally match stmt_id with Some id -> Stmt_cache.add_stmt db.stmt_cache id stmt; return () | None -> return ()) let borrow_worker db f = f db let steal_worker db f = M.with_lock (get_db_mutex db) (fun () -> f db) let step ?sql ?params stmt = run ?sql ?params ~stmt (Stmt.db_handle stmt) Stmt.step stmt let step_with_last_insert_rowid ?sql ?params stmt = step ?sql ?params stmt >> return (Sqlite3.last_insert_rowid (Stmt.db_handle stmt)) let reset_with_errcode stmt = return (Stmt.reset stmt) let reset stmt = ignore (Stmt.reset stmt); return () let row_data stmt = return (Stmt.row_data stmt) let unsafe_execute db ?retry_on_busy sql = lwt dbh = handle db in check_ok ?retry_on_busy ~sql dbh (Sqlite3.exec dbh) sql let raise_error stmt ?sql ?params ?errmsg errcode = raise_error (Stmt.db_handle stmt) ?sql ?params ?errmsg errcode module TLS = M end module type S = sig type 'a result type ('a, 'b) statement = { sql_statement : string; stmt_id : string option; directive : (st -> 'b) -> st -> 'a; } type ('a, 'b, 'c) expression = { statement : ('a, 'c) statement; get_data : int * (Sqlite3.Data.t array -> 'b); } type db exception Error of string * exn exception Sqlite_error of string * Sqlite3.Rc.t val open_db : ?init:(Sqlite3.db -> unit) -> string -> db val close_db : db -> unit val borrow_worker : db -> (db -> 'a result) -> 'a result val steal_worker : db -> (db -> 'a result) -> 'a result val execute : db -> ('a, unit result) statement -> 'a val insert : db -> ('a, int64 result) statement -> 'a val select : db -> ('c, 'a, 'a list result) expression -> 'c val select_f : db -> ('a -> 'b result) -> ('c, 'a, 'b list result) expression -> 'c val select_one : db -> ('c, 'a, 'a result) expression -> 'c val select_one_maybe : db -> ('c, 'a, 'a option result) expression -> 'c val select_one_f : db -> ('a -> 'b result) -> ('c, 'a, 'b result) expression -> 'c val select_one_f_maybe : db -> ('a -> 'b result) -> ('c, 'a, 'b option result) expression -> 'c val transaction : db -> ?kind:[`DEFERRED | `IMMEDIATE | `EXCLUSIVE] -> (db -> 'a result) -> 'a result val fold : db -> ('a -> 'b -> 'a result) -> 'a -> ('c, 'b, 'a result) expression -> 'c val iter : db -> ('a -> unit result) -> ('b, 'a, unit result) expression -> 'b module Directives : sig type ('a, 'b) directive = (st -> 'b) -> st -> 'a val literal : string -> ('a, 'a) directive val int : (int -> 'a, 'a) directive val text : (string -> 'a, 'a) directive val blob : (string -> 'a, 'a) directive val float : (float -> 'a, 'a) directive val int32 : (int32 -> 'a, 'a) directive val int64 : (int64 -> 'a, 'a) directive val bool : (bool -> 'a, 'a) directive val any : (('b -> string) -> 'b -> 'a, 'a) directive val maybe_int : (int option -> 'a, 'a) directive val maybe_text : (string option -> 'a, 'a) directive val maybe_blob : (string option -> 'a, 'a) directive val maybe_float : (float option -> 'a, 'a) directive val maybe_int32 : (int32 option -> 'a, 'a) directive val maybe_int64 : (int64 option -> 'a, 'a) directive val maybe_bool : (bool option -> 'a, 'a) directive val maybe_any : (('b -> string) -> 'b option -> 'a, 'a) directive end module Conversion : sig val text : Sqlite3.Data.t -> string val blob : Sqlite3.Data.t -> string val int : Sqlite3.Data.t -> int val int32 : Sqlite3.Data.t -> int32 val int64 : Sqlite3.Data.t -> int64 val float : Sqlite3.Data.t -> float val bool : Sqlite3.Data.t -> bool val maybe : (Sqlite3.Data.t -> 'a) -> Sqlite3.Data.t -> 'a option val maybe_text : Sqlite3.Data.t -> string option val maybe_blob : Sqlite3.Data.t -> string option val maybe_int : Sqlite3.Data.t -> int option val maybe_int32 : Sqlite3.Data.t -> int32 option val maybe_int64 : Sqlite3.Data.t -> int64 option val maybe_float : Sqlite3.Data.t -> float option val maybe_bool : Sqlite3.Data.t -> bool option end end module Make_gen(M : THREAD)(POOL : POOL with type 'a result = 'a M.t) = struct module Lwt = M open Lwt include Error(M) include Profile(M) module Directives = Directives module Conversion = Conversion open Directives let (>>=) = bind type 'a result = 'a M.t type ('a, 'b) statement = ('a, 'b) Directives.statement = { sql_statement : string; stmt_id : string option; directive : ('a, 'b) directive } type ('a, 'b, 'c) expression = { statement : ('a, 'c) statement; get_data : int * (Sqlite3.Data.t array -> 'b); } type db = POOL.db exception Error = Error exception Sqlite_error = Sqlite_error let open_db = POOL.open_db let close_db = POOL.close_db let borrow_worker = POOL.borrow_worker let steal_worker = POOL.steal_worker let do_select f db p = p.directive (POOL.prepare db f) ([], 0, p.sql_statement, p.stmt_id) let execute db (p : ('a, _ M.t) statement) = do_select (fun stmt sql params -> POOL.step ~sql ~params stmt >> return ()) db p let insert db p = do_select (fun stmt sql params -> POOL.step_with_last_insert_rowid ~sql ~params stmt) db p let check_num_cols s stmt expr data = let expected = fst expr.get_data in let actual = Array.length data in if expected = actual then return () else failwithfmt "Sqlexpr_sqlite.%s: wrong number of columns \ (expected %d, got %d) in SQL: %s" s expected actual expr.statement.sql_statement let ensure_reset_stmt stmt f x = try_lwt f x finally POOL.reset stmt let select_f db f expr = do_select (fun stmt sql params -> let auto_yield = M.auto_yield 0.01 in let rec loop l = auto_yield () >> POOL.step stmt >>= function Sqlite3.Rc.ROW -> lwt data = POOL.row_data stmt in check_num_cols "select" stmt expr data >> lwt x = try_lwt f (snd expr.get_data data) in loop (x :: l) | Sqlite3.Rc.DONE -> return (List.rev l) | rc -> POOL.raise_error ~sql ~params stmt rc in ensure_reset_stmt stmt loop []) db expr.statement let select db expr = select_f db (fun x -> return x) expr let select_one_f_aux db f not_found expr = do_select (fun stmt sql params -> ensure_reset_stmt stmt begin fun () -> POOL.step stmt >>= function Sqlite3.Rc.ROW -> lwt data = POOL.row_data stmt in try_lwt f (snd expr.get_data data) | Sqlite3.Rc.DONE -> not_found () | rc -> POOL.raise_error ~sql ~params stmt rc end ()) db expr.statement let select_one db expr = select_one_f_aux db (fun x -> return x) (fun () -> M.fail Not_found) expr let select_one_f db f expr = select_one_f_aux db f (fun () -> M.fail Not_found) expr let select_one_maybe db expr = select_one_f_aux db (fun x -> return (Some x)) (fun () -> return None) expr let select_one_f_maybe db f expr = select_one_f_aux db (fun x -> lwt y = f x in return (Some y)) (fun () -> return None) expr let new_tx_id = let pid = Unix.getpid () in fun () -> (* No allocation here, so cannot have a context change until the * sprintf, at least in native code. *) let n = !tx_id_counter in incr tx_id_counter; if !tx_id_counter < 0 then tx_id_counter := 0; sprintf "__sqlexpr_sqlite_tx_%d_%d" pid n let unsafe_execute db ?retry_on_busy fmt = ksprintf (POOL.unsafe_execute db ?retry_on_busy) fmt let unsafe_execute_prof text db ?retry_on_busy fmt = ksprintf (fun sql -> profile_prepare_stmt text (fun () -> return ()) >> profile_execute_sql ~full_sql:sql text (fun () -> POOL.unsafe_execute db ?retry_on_busy sql)) fmt (* wrap in BEGIN/COMMIT only for outermost txs *) let outer_transaction_wrap ~kind f db = match POOL.TLS.get (POOL.transaction_key db) with Some _ -> f db | None -> let tx_kind = match kind with `DEFERRED -> "DEFERRED" | `IMMEDIATE -> "IMMEDIATE" | `EXCLUSIVE -> "EXCLUSIVE" in unsafe_execute_prof ~retry_on_busy:true "BEGIN" db "BEGIN %s" tx_kind >> match_lwt try_lwt lwt x = POOL.TLS.with_value (POOL.transaction_key db) (Some ()) (fun () -> f db) in return (`OK x) with exn -> return (`EXN exn) with | `OK x -> unsafe_execute_prof ~retry_on_busy:true "COMMIT" db "COMMIT" >> return x | `EXN exn -> unsafe_execute_prof "ROLLBACK" db "ROLLBACK" >> fail exn let transaction db ?(kind = `DEFERRED) f = let txid = new_tx_id () in POOL.steal_worker db (outer_transaction_wrap ~kind begin fun db -> unsafe_execute_prof "SAVEPOINT" db "SAVEPOINT %s" txid >> try_lwt lwt x = f db in unsafe_execute_prof "RELEASE" db "RELEASE %s" txid >> return x with e -> unsafe_execute_prof "ROLLBACK" db "ROLLBACK TO %s" txid >> unsafe_execute_prof "RELEASE" db "RELEASE %s" txid >> fail e end) let fold db f init expr = do_select (fun stmt sql params -> let auto_yield = M.auto_yield 0.01 in let rec loop acc = auto_yield () >> POOL.step stmt >>= function Sqlite3.Rc.ROW -> begin try_lwt lwt data = POOL.row_data stmt in check_num_cols "fold" stmt expr data >> f acc (snd expr.get_data data) end >>= loop | Sqlite3.Rc.DONE -> return acc | rc -> POOL.raise_error ~sql ~params stmt rc in ensure_reset_stmt stmt loop init) db expr.statement let iter db f expr = do_select (fun stmt sql params -> let auto_yield = M.auto_yield 0.01 in let rec loop () = auto_yield () >> POOL.step stmt >>= function Sqlite3.Rc.ROW -> begin try_lwt lwt data = POOL.row_data stmt in check_num_cols "iter" stmt expr data >> f (snd expr.get_data data) end >>= loop | Sqlite3.Rc.DONE -> return () | rc -> POOL.raise_error stmt ~sql ~params rc in ensure_reset_stmt stmt loop ()) db expr.statement end module Make(M : THREAD with type 'a key = 'a Lwt.key) = struct module Id = IdentityPool(M) include Make_gen(M)(Id) let make = Id.make let sqlite_db db = Id.get_handle db end ocaml-sqlexpr-0.5.5/sqlexpr_sqlite.mli000066400000000000000000000247761215712740300201140ustar00rootroot00000000000000(** Sqlexpr access to SQLite databases. *) (**/**) module Types : sig (** Type used internally. *) type st = Sqlite3.Data.t list * int * string * string option end type st = Types.st (**/**) (** All the exceptions raised by the code in {Sqlexpr_sqlite} are wrapped in Error except when indicated otherwise. *) exception Error of string * exn (** Errors reported by SQLite are converted into [Sqlite_error _] exceptions, so they can be matched with [try ... with Sqlexpr.Error (_, Sqlexpr.sqlite_error _)] *) exception Sqlite_error of string * Sqlite3.Rc.t (** *) module type S = sig (** Concurrency monad value. *) type 'a result (** Type of SQL statements (no output parameters). *) type ('a, 'b) statement = { sql_statement : string; stmt_id : string option; directive : (st -> 'b) -> st -> 'a; } (** Type of SQL expressions (output parameters). *) type ('a, 'b, 'c) expression = { statement : ('a, 'c) statement; get_data : int * (Sqlite3.Data.t array -> 'b); } (** Database type *) type db (** Exception identical to the toplevel [Error], provided for convenience. Note that [Sqlexpr_sqlite.Error _] matches this exception. *) exception Error of string * exn (** Exception identical to the toplevel [Sqlite_error], provided for convenience. Note that [Sqlexpr_sqlite.Sqlite_error _] matches this exception. *) exception Sqlite_error of string * Sqlite3.Rc.t (** Open the DB whose filename is given. [":memory:"] refers to an in-mem DB. * @param [init] function to be applied to [Sqlite3.db] handle(s) before * they are used (can be used to register functions or initialize schema in * in-mem tables. *) val open_db : ?init:(Sqlite3.db -> unit) -> string -> db (** Close the DB and finalize all the associated prepared statements. *) val close_db : db -> unit (** [borrow_worker db f] evaluates [f db'] where [db'] borrows a 'worker' * from [db] and [db'] is only valid inside [f]. All the operations on * [db'] will use the same worker. Use this e.g. if you have an in-mem * database and a number of operations that must go against the same * instance (since data is not shared across different [:memory:] * databases). [db'] will not spawn new workers and will be closed and * invalidated automatically. *) val borrow_worker : db -> (db -> 'a result) -> 'a result (** [steal_worker db f] is similar to [borrow_worker db f], but ensures * that [f] is given exclusive access to the worker while it is being * evaluated. *) val steal_worker : db -> (db -> 'a result) -> 'a result (** Execute a SQL statement. *) val execute : db -> ('a, unit result) statement -> 'a (** Execute an INSERT SQL statement and return the last inserted row id. Example: [insert db sqlc"INSERT INTO users(name, pass) VALUES(%s, %s)" name pass] *) val insert : db -> ('a, int64 result) statement -> 'a (** "Select" a SELECT SQL expression and return a list of tuples; e.g. [select db sqlc"SELECT \@s\{name\}, \@s\{pass\} FROM users"] [select db sqlc"SELECT \@s\{pass\} FROM users WHERE id = %L" user_id] *) val select : db -> ('c, 'a, 'a list result) expression -> 'c (** [select_f db f expr ...] is similar to [select db expr ...] but maps the results using the provided [f] function. *) val select_f : db -> ('a -> 'b result) -> ('c, 'a, 'b list result) expression -> 'c (** [select_one db expr ...] takes the first result from [select db expr ...]. @raise Not_found if no row is found. *) val select_one : db -> ('c, 'a, 'a result) expression -> 'c (** [select_one_maybe db expr ...] takes the first result from [select db expr ...]. @return None if no row is found. *) val select_one_maybe : db -> ('c, 'a, 'a option result) expression -> 'c (** [select_one_f db f expr ...] is returns the first result from [select_f db f expr ...]. @raise Not_found if no row is found. *) val select_one_f : db -> ('a -> 'b result) -> ('c, 'a, 'b result) expression -> 'c (** [select_one_f_maybe db expr ...] takes the first result from [select_f db f expr ...]. @return None if no row is found. *) val select_one_f_maybe : db -> ('a -> 'b result) -> ('c, 'a, 'b option result) expression -> 'c (** Run the provided function in a DB transaction. A rollback is performed if an exception is raised inside the transaction. If the BEGIN or COMMIT SQL statements from the outermost transaction fail with [SQLITE_BUSY], they will be retried until they can be executed. A [SQLITE_BUSY] (or any other) error code in any other operation inside a transaction will result in an [Error (_, Sqlite_error (code, _))] exception being thrown, and a rollback performed. One consequence of this is that concurrency control is very simple if you use [`EXCLUSIVE] transactions: the code can be written straightforwardly as [S.transaction db (fun db -> ...)], and their execution will be serialized (across both threads and processes). Note that, for [`IMMEDIATE] and [`DEFERRED] transactions, you will have to retry manually if an [Error (_, Sqlite_error (Sqlite3.Rc.Busy, _))] is raised. All SQL operations performed within a transaction will use the same worker. This worker is used exclusively by only one thread per instantiated module (see {!steal_worker}). That is, given {[ module S1 = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) module S2 = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Lwt) let db = S1.open_db somefile ]} there is no exclusion between functions from [S1] and those from [S2]. @param kind transaction kind, only meaningful for outermost transaction (default [`DEFERRED]) *) val transaction : db -> ?kind:[`DEFERRED | `IMMEDIATE | `EXCLUSIVE] -> (db -> 'a result) -> 'a result (** [fold db f a expr ...] is [f (... (f (f a r1) r2) ...) rN] where [rN] is the n-th row returned for the SELECT expression [expr]. *) val fold : db -> ('a -> 'b -> 'a result) -> 'a -> ('c, 'b, 'a result) expression -> 'c (** Iterate through the rows returned for the supplied expression. *) val iter : db -> ('a -> unit result) -> ('b, 'a, unit result) expression -> 'b (** Module used by the code generated for SQL literals. *) module Directives : sig type ('a, 'b) directive = (st -> 'b) -> st -> 'a val literal : string -> ('a, 'a) directive val int : (int -> 'a, 'a) directive val text : (string -> 'a, 'a) directive val blob : (string -> 'a, 'a) directive val float : (float -> 'a, 'a) directive val int32 : (int32 -> 'a, 'a) directive val int64 : (int64 -> 'a, 'a) directive val bool : (bool -> 'a, 'a) directive val any : (('b -> string) -> 'b -> 'a, 'a) directive val maybe_int : (int option -> 'a, 'a) directive val maybe_text : (string option -> 'a, 'a) directive val maybe_blob : (string option -> 'a, 'a) directive val maybe_float : (float option -> 'a, 'a) directive val maybe_int32 : (int32 option -> 'a, 'a) directive val maybe_int64 : (int64 option -> 'a, 'a) directive val maybe_bool : (bool option -> 'a, 'a) directive val maybe_any : (('b -> string) -> 'b option -> 'a, 'a) directive end (** Module used by the code generated for SQL literals. *) module Conversion : sig val text : Sqlite3.Data.t -> string val blob : Sqlite3.Data.t -> string val int : Sqlite3.Data.t -> int val int32 : Sqlite3.Data.t -> int32 val int64 : Sqlite3.Data.t -> int64 val float : Sqlite3.Data.t -> float val bool : Sqlite3.Data.t -> bool val maybe : (Sqlite3.Data.t -> 'a) -> Sqlite3.Data.t -> 'a option val maybe_text : Sqlite3.Data.t -> string option val maybe_blob : Sqlite3.Data.t -> string option val maybe_int : Sqlite3.Data.t -> int option val maybe_int32 : Sqlite3.Data.t -> int32 option val maybe_int64 : Sqlite3.Data.t -> int64 option val maybe_float : Sqlite3.Data.t -> float option val maybe_bool : Sqlite3.Data.t -> bool option end end (** [db] type shared by single-worker ("identity pool") {!S} implementations. *) type single_worker_db module Make : functor (M : Sqlexpr_concurrency.THREAD with type 'a key = 'a Lwt.key) -> sig include S with type 'a result = 'a M.t and type db = single_worker_db val make : Sqlite3.db -> db (** Return the [Sqlite3.db] handle from a [db]. *) val sqlite_db : db -> Sqlite3.db end module type POOL = sig type 'a result module TLS : Sqlexpr_concurrency.THREAD_LOCAL_STATE with type 'a t := 'a result type db type stmt val open_db : ?init:(Sqlite3.db -> unit) -> string -> db val close_db : db -> unit val prepare : db -> (stmt -> string -> Sqlite3.Data.t list -> 'a result) -> st -> 'a result val step : ?sql:string -> ?params:Sqlite3.Data.t list -> stmt -> Sqlite3.Rc.t result val step_with_last_insert_rowid : ?sql:string -> ?params:Sqlite3.Data.t list -> stmt -> Int64.t result val reset : stmt -> unit result val row_data : stmt -> Sqlite3.Data.t array result val raise_error : stmt -> ?sql:string -> ?params:Sqlite3.Data.t list -> ?errmsg:string -> Sqlite3.Rc.t -> 'a result val unsafe_execute : db -> ?retry_on_busy:bool -> string -> unit result val borrow_worker : db -> (db -> 'a result) -> 'a result val steal_worker : db -> (db -> 'a result) -> 'a result val transaction_key : db -> unit TLS.key end module Make_gen : functor (M : Sqlexpr_concurrency.THREAD) -> functor(P : POOL with type 'a result = 'a M.t) -> S with type 'a result = 'a M.t (**/**) val prettify_sql_stmt : string -> string val string_of_param : Sqlite3.Data.t -> string val string_of_params : Sqlite3.Data.t list -> string module Stmt : sig type t val prepare : Sqlite3.db -> string -> t val db_handle : t -> Sqlite3.db val finalize : t -> unit val reset : t -> Sqlite3.Rc.t val step : t -> Sqlite3.Rc.t val bind : t -> int -> Sqlite3.Data.t -> Sqlite3.Rc.t val row_data : t -> Sqlite3.Data.t array end module Stmt_cache : sig type t val create : unit -> t val flush_stmts : t -> unit val find_remove_stmt : t -> string -> Stmt.t option val add_stmt : t -> string -> Stmt.t -> unit end module Profile : functor (M : Sqlexpr_concurrency.THREAD) -> sig val profile_execute_sql : string -> ?full_sql:string -> ?params:Sqlite3.Data.t list -> (unit -> 'b M.t) -> 'b M.t val profile_prepare_stmt : string -> (unit -> 'a M.t) -> 'a M.t end (**/**) ocaml-sqlexpr-0.5.5/sqlexpr_sqlite_lwt.ml000066400000000000000000000303431215712740300206140ustar00rootroot00000000000000open Printf open Sqlexpr_sqlite open Lwt module CONC = Sqlexpr_concurrency.Lwt let failwithfmt fmt = ksprintf (fun s -> try_lwt failwith s) fmt (* Total number of threads currently running: *) let thread_count = ref 0 (* Max allowed number of threads *) let max_threads = ref 4 let set_max_threads n = max_threads := max n !thread_count; !max_threads module POOL = struct include Sqlexpr_sqlite.Profile(CONC) module WT = Weak.Make(struct type t = Stmt.t let hash = Hashtbl.hash let equal = (==) end) module rec Ty : sig type db = { id : int; file : string; mutable db_finished : bool; mutable max_workers : int; mutable worker_count : int; init_func : Sqlite3.db -> unit; mutable workers : worker list; free_workers : WSet.t; db_waiters : worker Lwt.u Lwt_sequence.t; tx_key : unit Lwt.key; } and thread = { mutable thread : Thread.t; task_channel : (int * (unit -> unit)) Event.channel; mutex : Lwt_mutex.t; } and worker = { worker_id : int; mutable handle : Sqlite3.db; stmts : WT.t; stmt_cache : Stmt_cache.t; worker_thread : thread; db : db; } end = Ty and WSet : sig type t val create : unit -> t val is_empty : t -> bool val add : t -> Ty.worker -> unit val take : t -> Ty.worker val remove : t -> Ty.worker -> unit end = struct module S = Set.Make(struct type t = Ty.worker let compare w1 w2 = w1.Ty.worker_id - w2.Ty.worker_id end) type t = S.t ref let create () = ref S.empty let is_empty t = S.is_empty !t let add t x = t := S.add x !t let remove t x = t := S.remove x !t let take t = let x = S.min_elt !t in remove t x; x end include Ty type stmt = worker * Stmt.t type 'a result = 'a Lwt.t module TLS = Lwt (* Pool of threads: *) let threads : thread Queue.t = Queue.create () (* Queue of clients waiting for a thread to be available: *) let waiters : thread Lwt.u Lwt_sequence.t = Lwt_sequence.create () (* will be set to [detach] later, done this way to avoid cumbersome gigantic * let rec definition *) let do_detach = ref (fun _ _ _ -> return ()) let rec close_db db = db.db_finished <- true; List.iter close_worker db.workers and close_worker w = Stmt_cache.flush_stmts w.stmt_cache; (* must run Stmt.finalize and Sqlite3.db_close in the same thread where * the handles were created! *) ignore begin try_lwt !do_detach w (fun handle () -> WT.iter (fun stmt -> Stmt.finalize stmt) w.stmts; ignore (Sqlite3.db_close handle)) () with e -> return () (* FIXME: log? *) end let new_id = let n = ref 0 in fun () -> incr n; !n let transaction_key db = db.tx_key let open_db ?(init = fun _ -> ()) file = let id = new_id () in let r = { id = id; file = file; init_func = init; max_workers = !max_threads; worker_count = 0; workers = []; free_workers = WSet.create (); db_waiters = Lwt_sequence.create (); db_finished = false; tx_key = Lwt.new_key (); } in Lwt_gc.finalise (fun db -> close_db db; return ()) r; r let rec thread_loop thread = let id, task = Event.sync (Event.receive thread.task_channel) in task (); Lwt_unix.send_notification id; thread_loop thread let make_thread () = let t = { thread = Thread.self (); task_channel = Event.new_channel (); mutex = Lwt_mutex.create (); } in t.thread <- Thread.create thread_loop t; incr thread_count; t let check_worker_finished worker = if worker.db.db_finished then failwith (sprintf "db %d:%S is closed" worker.db.id worker.db.file) let detach worker f args = let result = ref `Nothing in let task dbh () = try result := `Success (f dbh args) with exn -> result := `Failure exn in let waiter, wakener = wait () in let id = Lwt_unix.make_notification ~once:true (fun () -> match !result with | `Nothing -> wakeup_exn wakener (Failure "Sqlexpr_sqlite.detach") | `Success value -> wakeup wakener value | `Failure exn -> wakeup_exn wakener exn) in try_lwt WSet.remove worker.db.free_workers worker; Lwt_mutex.with_lock worker.worker_thread.mutex (fun () -> try_lwt check_worker_finished worker; (* Send the id and the task to the worker: *) Event.sync (Event.send worker.worker_thread.task_channel (id, (task worker.handle))); return () with e -> wakeup_exn wakener e; return ()) >> waiter finally WSet.add worker.db.free_workers worker; return () let () = do_detach := detach (* Add a thread to the pool: *) let add_thread thread = match Lwt_sequence.take_opt_l waiters with | None -> Queue.add thread threads | Some t -> wakeup t thread (* Add a worker to the pool: *) let add_worker db worker = match Lwt_sequence.take_opt_l db.db_waiters with | None -> WSet.add db.free_workers worker | Some w -> wakeup w worker (* Wait for thread to be available, then return it: *) let rec get_thread () = if not (Queue.is_empty threads) then return (Queue.take threads) else if !thread_count < !max_threads then return (make_thread ()) else begin let (res, w) = Lwt.task () in let node = Lwt_sequence.add_r w waiters in Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); res end let make_worker db = db.worker_count <- db.worker_count + 1; lwt thread = get_thread () in try_lwt let worker = { db = db; worker_id = new_id (); handle = Sqlite3.db_open ":memory:"; stmts = WT.create 13; stmt_cache = Stmt_cache.create (); worker_thread = thread; } in lwt handle = detach worker (fun _ () -> let handle = Sqlite3.db_open db.file in db.init_func handle; handle) () in worker.handle <- handle; db.workers <- worker :: db.workers; add_worker db worker; return worker with e -> db.worker_count <- db.worker_count - 1; raise_lwt e finally add_thread thread; return () let do_raise_error ?sql ?params ?errmsg errcode = let msg = Sqlite3.Rc.to_string errcode ^ BatOption.map_default ((^) " ") "" errmsg in let msg = match sql with None -> msg | Some sql -> sprintf "%s in %s" msg (prettify_sql_stmt sql) in let msg = match params with None | Some [] -> msg | Some params -> sprintf "%s with params %s" msg (string_of_params (List.rev params)) in raise (Error (msg, Sqlite_error (msg, errcode))) let raise_error worker ?sql ?params ?errmsg errcode = lwt errmsg = match errmsg with Some e -> return e | None -> detach worker (fun dbh () -> Sqlite3.errmsg dbh) () in try_lwt return (do_raise_error ?sql ?params ~errmsg errcode) let rec run ?(retry_on_busy = false) ?stmt ?sql ?params worker f x = detach worker f x >>= function Sqlite3.Rc.OK | Sqlite3.Rc.ROW | Sqlite3.Rc.DONE as r -> return r | Sqlite3.Rc.BUSY when retry_on_busy -> Lwt_unix.sleep 0.010 >> run ~retry_on_busy ?sql ?stmt ?params worker f x | code -> lwt errmsg = detach worker (fun dbh () -> Sqlite3.errmsg dbh) () in begin match stmt with None -> return () | Some stmt -> detach worker (fun dbh -> Stmt.reset) stmt >> return () end >> raise_error worker ?sql ?params ~errmsg code let check_ok ?retry_on_busy ?stmt ?sql ?params worker f x = lwt _ = run ?retry_on_busy ?stmt ?sql ?params worker f x in return () (* Wait for worker to be available, then return it: *) let rec get_worker db = if not (WSet.is_empty db.free_workers) then return (WSet.take db.free_workers) else if db.worker_count < db.max_workers then make_worker db else begin let (res, w) = Lwt.task () in let node = Lwt_sequence.add_r w db.db_waiters in Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); res end let prepare db f (params, nparams, sql, stmt_id) = lwt worker = get_worker db in (try_lwt return (check_worker_finished worker)) >> lwt stmt = try_lwt match stmt_id with None -> profile_prepare_stmt sql (fun () -> lwt stmt = detach worker Stmt.prepare sql in WT.add worker.stmts stmt; return stmt) | Some id -> match Stmt_cache.find_remove_stmt worker.stmt_cache id with Some stmt -> begin try_lwt check_ok ~stmt worker (fun _ -> Stmt.reset) stmt with e -> (* drop the stmt *) detach worker (fun _ -> Stmt.finalize) stmt >> raise_lwt e end >> return stmt | None -> profile_prepare_stmt sql (fun () -> lwt stmt = detach worker Stmt.prepare sql in WT.add worker.stmts stmt; return stmt) with e -> add_worker db worker; let s = sprintf "Error with SQL statement %s" sql in raise_lwt (Error (s, e)) in (* the list of params is reversed *) begin try_lwt detach worker (fun dbh stmt -> let n = ref nparams in List.iter (fun v -> match Stmt.bind stmt !n v with Sqlite3.Rc.OK -> decr n | code -> do_raise_error ~sql ~params code) params) stmt finally add_worker db worker; return () end >> profile_execute_sql sql ~params (fun () -> try_lwt f (worker, stmt) sql params finally match stmt_id with Some id -> Stmt_cache.add_stmt worker.stmt_cache id stmt; return () | None -> return ()) let borrow_worker db f = let db' = { open_db ~init:db.init_func db.file with max_workers = 1; tx_key = db.tx_key; } in lwt worker = get_worker db in add_worker db' { worker with db = db' } ; add_worker db worker; try_lwt f db' finally db'.workers <- []; close_db db'; return () let steal_worker db f = let db' = { open_db ~init:db.init_func db.file with max_workers = 1; tx_key = db.tx_key; } in lwt worker = get_worker db in add_worker db' { worker with db = db' } ; try_lwt f db' finally db'.workers <- []; close_db db'; add_worker db worker; return () let step ?sql ?params (worker, stmt) = run ?sql ?params ~stmt worker (fun _ -> Stmt.step) stmt let step_with_last_insert_rowid ?sql ?params ((worker, _) as stmt) = step ?sql ?params stmt >> detach worker (fun dbh () -> Sqlite3.last_insert_rowid dbh) () let reset_with_errcode (worker, stmt) = detach worker (fun _ -> Stmt.reset) stmt let reset x = reset_with_errcode x >> return () let row_data (worker, stmt) = detach worker (fun _ -> Stmt.row_data) stmt let unsafe_execute db ?retry_on_busy sql = lwt worker = get_worker db in try_lwt check_ok ?retry_on_busy ~sql worker (fun dbh sql -> Sqlite3.exec dbh sql) sql finally add_worker db worker; return () let raise_error (worker, _) ?sql ?params ?errmsg errcode = raise_error worker ?sql ?params ?errmsg errcode end include Sqlexpr_sqlite.Make_gen(CONC)(POOL) ocaml-sqlexpr-0.5.5/sqlexpr_sqlite_lwt.mli000066400000000000000000000005261215712740300207650ustar00rootroot00000000000000(** {!Sqlexpr_sqlite.S} implementation for the Lwt monad that uses thread * pools to avoid blocking on sqlite3 API calls. *) include Sqlexpr_sqlite.S with type 'a result = 'a Lwt.t (** [set_max_threads n] sets the maximum number of threads to * [max n current_thread_count] and returns the new limit *) val set_max_threads : int -> int ocaml-sqlexpr-0.5.5/sqlexpr_syntax.mllib000066400000000000000000000001331215712740300204340ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: ba8b667d903c84d19afcf0723c7c1fa6) Pa_sql # OASIS_STOP ocaml-sqlexpr-0.5.5/t_sqlexpr_sqlite.ml000066400000000000000000000317131215712740300202530ustar00rootroot00000000000000 open Printf open OUnit open Lwt let aeq_int = assert_equal ~printer:(sprintf "%d") let aeq_str = assert_equal ~printer:(sprintf "%S") let aeq_float = assert_equal ~printer:(sprintf "%f") let aeq_int32 = assert_equal ~printer:(sprintf "%ld") let aeq_int64 = assert_equal ~printer:(sprintf "%Ld") let aeq_bool = assert_equal ~printer:string_of_bool let aeq_list ~printer = assert_equal ~printer:(fun l -> "[ " ^ String.concat "; " (List.map printer l) ^ " ]") module Test (Lwt : sig include Sqlexpr_concurrency.THREAD val iter : ('a -> unit t) -> 'a list -> unit t val run : 'a t -> 'a end) (Sqlexpr : sig include Sqlexpr_sqlite.S with type 'a result = 'a Lwt.t end) = struct open Lwt module S = Sqlexpr let (>|=) f g = bind f (fun x -> return (g x)) (* schema changes to :memory: db made by a Sqlexpr_sqlite_lwt worker are not * seen by the others, so allow to use a file by doing ~in_mem:false *) let with_db ?(in_mem = true) f x = let file = if in_mem then ":memory:" else Filename.temp_file "t_sqlexpr_sqlite_" "" in let db = S.open_db file in try_lwt f db x finally S.close_db db; if not in_mem then Sys.remove file; return () let test_execute () = with_db (fun db () -> S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY)" >> S.execute db sqlc"CREATE TABLE bar(id INTEGER PRIMARY KEY)") () let insert_d db l = S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v INTEGER)" >> iter (S.execute db sql"INSERT INTO foo(v) VALUES(%d)") l let insert_l db l = S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v INTEGER)" >> iter (S.execute db sql"INSERT INTO foo(v) VALUES(%l)") l let insert_L db l = S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v INTEGER)" >> iter (S.execute db sql"INSERT INTO foo(v) VALUES(%L)") l let insert_f db l = S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v FLOAT)" >> iter (S.execute db sql"INSERT INTO foo(v) VALUES(%f)") l let insert_s db l = S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v TEXT)" >> iter (S.execute db sql"INSERT INTO foo(v) VALUES(%s)") l let insert_S db l = S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v BLOB)" >> iter (S.execute db sql"INSERT INTO foo(v) VALUES(%S)") l let insert_b db l = S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v BOOLEAN)" >> iter (S.execute db sql"INSERT INTO foo(v) VALUES(%b)") l let test_directive_d () = with_db insert_d [1] let test_directive_l () = with_db insert_l [1l] let test_directive_L () = with_db insert_L [1L] let test_directive_f () = with_db insert_f [3.14] let test_directive_s () = with_db insert_s ["foo"] let test_directive_S () = with_db insert_S ["blob"] let test_directive_b () = with_db insert_b [true] let test_oexpr fmt insert expr l () = with_db (fun db () -> let n = ref 1 in insert db l >> let l = List.map (fun x -> let i = !n in incr n; (i, x)) l in lwt l' = S.select db expr in let l' = List.sort compare l' in aeq_list ~printer:(fun (id, x) -> sprintf ("(%d, " ^^ fmt ^^ ")") id x) l l'; return ()) () let test_nullable_oexpr fmt insert expr l () = with_db (fun db () -> let n = ref 1 in insert db l >> let l = List.map (fun x -> let i = !n in incr n; (i, Some x)) l in lwt l' = S.select db expr in let l' = List.sort compare l' in aeq_list ~printer:(fun (id, x) -> match x with None -> sprintf "(%d, None)" id | Some x -> sprintf ("(%d, Some " ^^ fmt ^^ ")") id x) l l'; return ()) () let test_oexpr_directives = with_db (fun db () -> S.select db sql"SELECT @d{%d}" 42 >|= aeq_list ~printer:(sprintf "%d") [42] >> S.select db sql"SELECT @f{%d}" 42 >|= aeq_list ~printer:(sprintf "%f") [42.] >> S.select db sql"SELECT @s{%d}" 42 >|= aeq_list ~printer:(sprintf "%s") ["42"]) let (>::) name f = name >:: (fun () -> run (f ())) let test_directives = [ "%d" >:: test_directive_d; "%l" >:: test_directive_l; "%L" >:: test_directive_L; "%f" >:: test_directive_f; "%s" >:: test_directive_s; "%S" >:: test_directive_S; "%b" >:: test_directive_b; ] let test_outputs = let t = test_oexpr in let tn = test_nullable_oexpr in [ "%d" >:: t "%d" insert_d sql"SELECT @d{id}, @d{v} FROM foo" [1;-1;3;4]; "%l" >:: t "%ld" insert_l sql"SELECT @d{id}, @l{v} FROM foo" [1l;-1l;3l;4l]; "%L" >:: t "%Ld" insert_L sql"SELECT @d{id}, @L{v} FROM foo" [1L;-1L;3L;4L]; "%f" >:: t "%f" insert_f sql"SELECT @d{id}, @f{v} FROM foo" [1.;-1.; 10.; 1e2]; "%s" >:: t "%s" insert_s sql"SELECT @d{id}, @s{v} FROM foo" ["foo"; "bar"; "baz"]; "%S" >:: t "%S" insert_s sql"SELECT @d{id}, @S{v} FROM foo" ["foo"; "bar"; "baz"]; "%b" >:: t "%b" insert_b sql"SELECT @d{id}, @b{v} FROM foo" [true; false]; (* nullable *) "%d" >:: tn "%d" insert_d sql"SELECT @d{id}, @d?{v} FROM foo" [1;-1;3;4]; "%l" >:: tn "%ld" insert_l sql"SELECT @d{id}, @l?{v} FROM foo" [1l;-1l;3l;4l]; "%L" >:: tn "%Ld" insert_L sql"SELECT @d{id}, @L?{v} FROM foo" [1L;-1L;3L;4L]; "%f" >:: tn "%f" insert_f sql"SELECT @d{id}, @f?{v} FROM foo" [1.;-1.; 10.; 1e2]; "%s" >:: tn "%s" insert_s sql"SELECT @d{id}, @s?{v} FROM foo" ["foo"; "bar"; "baz"]; "%S" >:: tn "%S" insert_s sql"SELECT @d{id}, @S?{v} FROM foo" ["foo"; "bar"; "baz"]; "%b" >:: tn "%b" insert_b sql"SELECT @d{id}, @b?{v} FROM foo" [true; false]; ] exception Cancel let test_transaction () = with_db begin fun db () -> let s_of_pair (id, data) = sprintf "(%d, %S)" id data in let get_rows db = S.select db sql"SELECT @d{id}, @s{data} FROM foo ORDER BY id" in let get_one db = S.select_one db sql"SELECT @d{id}, @s{data} FROM foo ORDER BY id" in let get_one' db = S.select_one db sqlc"SELECT @d{id}, @s{data} FROM foo ORDER BY id" in let insert db = S.execute db sql"INSERT INTO foo(id, data) VALUES(%d, %s)" in let aeq = aeq_list ~printer:s_of_pair in let aeq_one = assert_equal ~printer:s_of_pair in S.execute db sql"CREATE TABLE foo(id INTEGER NOT NULL, data TEXT NOT NULL)" >> get_rows db >|= aeq ~msg:"Init" [] >> S.transaction db (fun db -> get_rows db >|= aeq [] >> insert db 1 "foo" >> get_rows db >|= aeq ~msg:"One insert in TX" [1, "foo"] >> get_one db >|= aeq_one ~msg:"select_one after 1 insert in TX" (1, "foo") >> get_one' db >|= aeq_one ~msg:"select_one (cached) after 1 insert in TX" (1, "foo") >> try_lwt S.transaction db (fun db -> insert db 2 "bar" >> get_rows db >|= aeq ~msg:"Insert in nested TX" [1, "foo"; 2, "bar";] >> fail Cancel) with Cancel -> get_rows db >|= aeq ~msg:"After nested TX is canceled" [1, "foo"]) >> get_rows db >|= aeq [1, "foo"]; end () let test_retry_begin () = let count_rows db = S.select_one db sqlc"SELECT @d{COUNT(*)} FROM foo" in let insert v db = (* SELECT acquires a SHARED lock if needed *) lwt _ = count_rows db in Lwt.sleep 0.010 >> (* RESERVED lock acquired if needed *) S.insert db sqlc"INSERT INTO foo VALUES(%d)" v in let fname = Filename.temp_file "t_sqlexpr_sqlite_excl_retry" "" in let db1 = S.open_db fname in let db2 = S.open_db fname in S.execute db1 sqlc"CREATE TABLE foo(id INTEGER PRIMARY KEY)" >> (* these 2 TXs are serialized because they are EXCLUSIVE *) lwt _ = S.transaction ~kind:`EXCLUSIVE db1 (insert 1) and _ = S.transaction ~kind:`EXCLUSIVE db2 (insert 2) in lwt n = count_rows db1 in aeq_int ~msg:"number of rows inserted" 2 n; return () let test_fold_and_iter () = with_db begin fun db () -> S.execute db sql"CREATE TABLE foo(n INTEGER NOT NULL)" >> let l = Array.to_list (Array.init 100 (fun n -> 1 + Random.int 100000)) in iter (S.execute db sqlc"INSERT INTO foo(n) VALUES(%d)") l >> let sum = List.fold_left (+) 0 l in lwt count, sum' = S.fold db (fun (count, sum) n -> return (count + 1, sum + n)) (0, 0) sqlc"SELECT @d{n} FROM foo" in aeq_int ~msg:"fold: number of elements" (List.length l) count; aeq_int ~msg:"fold: sum of elements" sum sum'; let count = ref 0 in let sum' = ref 0 in lwt () = S.iter db (fun n -> incr count; sum' := !sum' + n; return ()) sqlc"SELECT @d{n} FROM foo" in aeq_int ~msg:"iter: number of elements" (List.length l) !count; aeq_int ~msg:"iter: sum of elements" sum !sum'; return () end () let rec do_test_nested_iter_and_fold db () = nested_iter_and_fold_write db >> nested_iter_and_fold_read db and nested_iter_and_fold_write db = S.execute db sql"CREATE TABLE foo(n INTEGER NOT NULL)" >> iter (S.execute db sqlc"INSERT INTO foo(n) VALUES(%d)") [1; 2; 3] and nested_iter_and_fold_read db = let q = Queue.create () in let expected = List.rev [ 1, 3; 1, 2; 1, 1; 2, 3; 2, 2; 2, 1; 3, 3; 3, 2; 3, 1; ] in let inner = sqlc"SELECT @d{n} FROM foo ORDER BY n DESC" in let outer = sqlc"SELECT @d{n} FROM foo ORDER BY n ASC" in let printer (a, b) = sprintf "(%d, %d)" a b in lwt () = S.iter db (fun a -> S.iter db (fun b -> Queue.push (a, b) q; return ()) inner) outer in aeq_list ~printer expected (Queue.fold (fun l x -> x :: l) [] q); lwt l = S.fold db (fun l a -> S.fold db (fun l b -> return ((a, b) :: l)) l inner) [] outer in aeq_list ~printer expected l; return () let test_nested_iter_and_fold () = (* nested iter/folds will spawn multiple Sqlexpr_sqlite_lwt workers, so * cannot use in-mem DB, lest the table not be created in other workers * than the one where it was created *) with_db ~in_mem:false do_test_nested_iter_and_fold () let expect_missing_table tbl f = try_lwt f () >> assert_failure (sprintf "Expected Sqlite3.Error: missing table %s" tbl) with Sqlexpr_sqlite.Error _ -> return () let test_borrow_worker () = with_db begin fun db () -> (* we borrow a worker repeatedly, but since we're doing everything * sequentially we end up using the same one all the time *) S.borrow_worker db (fun db' -> S.borrow_worker db (fun db'' -> do_test_nested_iter_and_fold db'' ()) >> nested_iter_and_fold_read db') >> nested_iter_and_fold_read db end () let test_borrow_worker has_real_borrow_worker () = if has_real_borrow_worker then test_borrow_worker () else return () let all_tests has_real_borrow_worker = [ "Directives" >::: test_directives; "Outputs" >::: test_outputs; "Directives in output exprs" >:: test_oexpr_directives; "Transactions" >:: test_transaction; "Auto-retry BEGIN" >:: test_retry_begin; "Fold and iter" >:: test_fold_and_iter; "Nested fold and iter" >:: test_nested_iter_and_fold; "Borrow worker" >:: test_borrow_worker has_real_borrow_worker; ] end let test_lwt_recursive_mutex () = let module M = Sqlexpr_concurrency.Lwt in let mv = Lwt_mvar.create () in let m = M.create_recursive_mutex () in let l = ref [] in let push x = l := x :: !l; return () in lwt n = M.with_lock m (fun () -> M.with_lock m (fun () -> return 42)) in aeq_int 42 n; let t1 = M.with_lock m (fun () -> push 1 >> Lwt_mvar.take mv >> push 2) in let t2 = M.with_lock m (fun () -> push 3) in lwt () = Lwt.join [ t1; t2; Lwt_mvar.put mv () ] in aeq_list ~printer:string_of_int [3; 2; 1] !l; return () module IdConc = struct include Sqlexpr_concurrency.Id let iter = List.iter let run x = x end module LwtConc = struct include Sqlexpr_concurrency.Lwt let run x = Lwt_unix.run (Lwt.pick [x; Lwt_unix.timeout 1.0]) let iter = Lwt_list.iter_s end let lwt_run f () = LwtConc.run (f ()) let all_tests = [ "Sqlexpr_concurrency.Lwt.with_lock" >:: lwt_run test_lwt_recursive_mutex; (let module M = Test(IdConc)(Sqlexpr_sqlite.Make(IdConc)) in "Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id)" >::: M.all_tests false); (let module M = Test(LwtConc)(Sqlexpr_sqlite.Make(LwtConc)) in "Sqlexpr_sqlite.Make(LwtConcurrency)" >::: M.all_tests false); (let module M = Test(LwtConc)(Sqlexpr_sqlite_lwt) in "Sqlexpr_sqlite_lwt" >::: M.all_tests true); ] let _ = run_test_tt_main ("All" >::: all_tests)